tcl7.4b4/004077500630510000012000000000000577032347300130435ustar00ousterstaff00002300000001tcl7.4b4/Makefile.in010066400630510000012000000262170577032340400151070ustar00ousterstaff00002300000001# # This file is a Makefile for Tcl. If it has the name "Makefile.in" # then it is a template for a Makefile; to generate the actual Makefile, # run "./configure", which is a configuration script generated by the # "autoconf" program (constructs like "@foo@" will get replaced in the # actual Makefile. # # @(#) Makefile.in 1.23 95/06/08 13:13:36 # Current Tcl version; used in various names. VERSION = 7.4 #---------------------------------------------------------------- # Things you can change to personalize the Makefile for your own # site (you can make these changes in either Makefile.in or # Makefile, but changes to Makefile will get lost if you re-run # the configuration script). #---------------------------------------------------------------- # Default top-level directories in which to install architecture- # specific files (exec_prefix) and machine-independent files such # as scripts (prefix). The values specified here may be overridden # at configure-time with the --exec-prefix and --prefix options # to the "configure" script. prefix = @prefix@ exec_prefix = @exec_prefix@ # The following definition can be set to non-null for special systems # like AFS with replication. It allows the pathnames used for installation # to be different than those used for actually reference files at # run-time. INSTALL_ROOT is prepended to $prefix and $exec_prefix # when installing files. INSTALL_ROOT = # Directory from which applications will reference the library of Tcl # scripts (note: you can set the TCL_LIBRARY environment variable at # run-time to override this value): TCL_LIBRARY = $(prefix)/lib/tcl$(VERSION) # Path name to use when installing library scripts: SCRIPT_INSTALL_DIR = $(INSTALL_ROOT)$(TCL_LIBRARY) # Directory in which to install the archive libtcl.a: LIB_INSTALL_DIR = $(INSTALL_ROOT)$(exec_prefix)/lib # Directory in which to install the program tclsh: BIN_INSTALL_DIR = $(INSTALL_ROOT)$(exec_prefix)/bin # Directory in which to install the include file tcl.h: INCLUDE_INSTALL_DIR = $(INSTALL_ROOT)$(prefix)/include # Top-level directory in which to install manual entries: MAN_INSTALL_DIR = $(INSTALL_ROOT)$(prefix)/man # Directory in which to install manual entry for tclsh: MAN1_INSTALL_DIR = $(MAN_INSTALL_DIR)/man1 # Directory in which to install manual entries for Tcl's C library # procedures: MAN3_INSTALL_DIR = $(MAN_INSTALL_DIR)/man3 # Directory in which to install manual entries for the built-in # Tcl commands: MANN_INSTALL_DIR = $(MAN_INSTALL_DIR)/mann # To change the compiler switches, for example to change from -O # to -g, change the following line: CFLAGS = -O # To disable ANSI-C procedure prototypes reverse the comment characters # on the following lines: PROTO_FLAGS = #PROTO_FLAGS = -DNO_PROTOTYPE # Mathematical functions like sin and atan2 are enabled for expressions # by default. To disable them, reverse the comment characters on the # following pairs of lines: MATH_FLAGS = #MATH_FLAGS = -DTCL_NO_MATH MATH_LIBS = @MATH_LIBS@ #MATH_LIBS = # To compile for non-UNIX systems (so that only the non-UNIX-specific # commands are available), reverse the comment characters on the # following pairs of lines. In addition, you'll have to provide your # own replacement for the "panic" procedure (see panic.c for what # the current one does). GENERIC_FLAGS = #GENERIC_FLAGS = -DTCL_GENERIC_ONLY UNIX_OBJS = panic.o tclEnv.o tclGlob.o tclMain.o tclMtherr.o \ tclUnixAZ.o tclUnixStr.o tclUnixUtil.o #UNIX_OBJS = # To enable memory debugging reverse the comment characters on the following # lines. Warning: if you enable memory debugging, you must do it # *everywhere*, including all the code that calls Tcl, and you must use # ckalloc and ckfree everywhere instead of malloc and free. MEM_DEBUG_FLAGS = #MEM_DEBUG_FLAGS = -DTCL_MEM_DEBUG # Some versions of make, like SGI's, use the following variable to # determine which shell to use for executing commands: SHELL = /bin/sh # Tcl used to let the configure script choose which program to use # for installing, but there are just too many different versions of # "install" around; better to use the install-sh script that comes # with the distribution, which is slower but guaranteed to work. INSTALL = @srcdir@/install-sh -c #---------------------------------------------------------------- # The information below is modified by the configure script when # Makefile is generated from Makefile.in. You shouldn't normally # modify any of this stuff by hand. #---------------------------------------------------------------- COMPAT_OBJS = @LIBOBJS@ AC_FLAGS = @DEFS@ INSTALL_PROGRAM = @INSTALL_PROGRAM@ INSTALL_DATA = @INSTALL_DATA@ RANLIB = @RANLIB@ SRC_DIR = @srcdir@ VPATH = @srcdir@ #---------------------------------------------------------------- # The information below should be usable as is. The configure # script won't modify it and you shouldn't need to modify it # either. #---------------------------------------------------------------- CC = @CC@ CC_SWITCHES = ${CFLAGS} -I. -I${SRC_DIR} ${AC_FLAGS} ${MATH_FLAGS} \ ${GENERIC_FLAGS} ${PROTO_FLAGS} ${MEM_DEBUG_FLAGS} \ -DTCL_LIBRARY=\"${TCL_LIBRARY}\" GENERIC_OBJS = regexp.o tclAsync.o tclBasic.o tclCkalloc.o \ tclCmdAH.o tclCmdIL.o tclCmdMZ.o tclExpr.o tclGet.o \ tclHash.o tclHistory.o tclLink.o tclParse.o tclProc.o \ tclUtil.o tclVar.o OBJS = ${GENERIC_OBJS} ${UNIX_OBJS} ${COMPAT_OBJS} SRCS= regexp.c tclAsync.c tclBasic.c tclCkalloc.c \ tclCmdAH.c tclCmdIL.c tclCmdMZ.c tclExpr.c tclGet.c \ tclHash.c tclHistory.c tclLink.c tclParse.c tclProc.c \ tclUtil.c tclVar.c panic.c tclEnv.c tclGlob.c tclMain.c \ tclMtherr.c tclUnixAZ.c tclUnixStr.c tclUnixUtil.c \ tclTest.c tclAppInit.c all: libtcl.a tclsh libtcl.a: ${OBJS} rm -f libtcl.a ar cr libtcl.a ${OBJS} $(RANLIB) libtcl.a tclsh: tclAppInit.o libtcl.a ${CC} ${CC_SWITCHES} tclAppInit.o libtcl.a ${MATH_LIBS} -o tclsh tcltest: tclTest.o libtcl.a ${CC} ${CC_SWITCHES} tclTest.o libtcl.a ${MATH_LIBS} -o tcltest test: tcltest @cwd=`pwd`; \ cd $(SRC_DIR); TCL_LIBRARY=`pwd`/library; export TCL_LIBRARY; \ cd $$cwd; ( echo cd $(SRC_DIR)/tests\; source all ) | ./tcltest configInfo: Makefile @rm -f configInfo @echo "# Definitions and libraries needed to build Tcl applications" >> configInfo @echo "# (generated by the configure script):" >> configInfo @echo "TCL_CC_SWITCHES = ${AC_FLAGS} ${MEM_DEBUG_FLAGS}" >> configInfo @echo "TCL_LIBS = ${MATH_LIBS} @LIBS@" >> configInfo install: install-binaries install-libraries install-man install-binaries: libtcl.a tclsh @for i in $(LIB_INSTALL_DIR) $(BIN_INSTALL_DIR) ; \ do \ if [ ! -d $$i ] ; then \ echo "Making directory $$i"; \ mkdir $$i; \ chmod 755 $$i; \ else true; \ fi; \ done; @echo "Installing libtcl.a" @$(INSTALL_DATA) libtcl.a $(LIB_INSTALL_DIR)/libtcl$(VERSION).a @$(RANLIB) $(LIB_INSTALL_DIR)/libtcl$(VERSION).a @echo "Installing tclsh" @$(INSTALL_PROGRAM) tclsh $(BIN_INSTALL_DIR)/tclsh$(VERSION) install-libraries: @for i in $(INSTALL_ROOT)$(prefix)/lib $(INCLUDE_INSTALL_DIR) \ $(SCRIPT_INSTALL_DIR) ; \ do \ if [ ! -d $$i ] ; then \ echo "Making directory $$i"; \ mkdir $$i; \ chmod 755 $$i; \ else true; \ fi; \ done; @echo "Installing tcl.h" @$(INSTALL_DATA) $(SRC_DIR)/tcl.h $(INCLUDE_INSTALL_DIR) @for i in $(SRC_DIR)/library/*.tcl $(SRC_DIR)/library/tclIndex $(SRC_DIR)/tclAppInit.c; \ do \ echo "Installing $$i"; \ $(INSTALL_DATA) $$i $(SCRIPT_INSTALL_DIR); \ done; install-man: @for i in $(MAN_INSTALL_DIR) $(MAN1_INSTALL_DIR) $(MAN3_INSTALL_DIR) $(MANN_INSTALL_DIR) ; \ do \ if [ ! -d $$i ] ; then \ echo "Making directory $$i"; \ mkdir $$i; \ chmod 755 $$i; \ else true; \ fi; \ done; @cd $(SRC_DIR)/doc; for i in *.1; \ do \ echo "Installing doc/$$i"; \ rm -f $(MAN1_INSTALL_DIR)/$$i; \ sed -e '/man\.macros/r man.macros' -e '/man\.macros/d' \ $$i > $(MAN1_INSTALL_DIR)/$$i; \ chmod 444 $(MAN1_INSTALL_DIR)/$$i; \ done; @cd $(SRC_DIR)/doc; for i in *.3; \ do \ echo "Installing doc/$$i"; \ rm -f $(MAN3_INSTALL_DIR)/$$i; \ sed -e '/man\.macros/r man.macros' -e '/man\.macros/d' \ $$i > $(MAN3_INSTALL_DIR)/$$i; \ chmod 444 $(MAN3_INSTALL_DIR)/$$i; \ done; @cd $(SRC_DIR)/doc; for i in *.n; \ do \ echo "Installing doc/$$i"; \ rm -f $(MANN_INSTALL_DIR)/$$i; \ sed -e '/man\.macros/r man.macros' -e '/man\.macros/d' \ $$i > $(MANN_INSTALL_DIR)/$$i; \ chmod 444 $(MANN_INSTALL_DIR)/$$i; \ done; Makefile: $(SRC_DIR)/Makefile.in $(SHELL) config.status clean: rm -f *.a *.o core errs *~ \#* TAGS *.E a.out errors tclsh tcltest \ config.info distclean: clean rm -f Makefile config.status config.cache depend: makedepend -- $(CC_SWITCHES) -- $(SRCS) fixstrtod.o: $(SRC_DIR)/compat/fixstrtod.c $(CC) -c $(CC_SWITCHES) $(SRC_DIR)/compat/fixstrtod.c getcwd.o: $(SRC_DIR)/compat/getcwd.c $(CC) -c $(CC_SWITCHES) $(SRC_DIR)/compat/getcwd.c opendir.o: $(SRC_DIR)/compat/opendir.c $(CC) -c $(CC_SWITCHES) $(SRC_DIR)/compat/opendir.c strerror.o: $(SRC_DIR)/compat/strerror.c $(CC) -c $(CC_SWITCHES) $(SRC_DIR)/compat/strerror.c strncasecmp.o: $(SRC_DIR)/compat/strncasecmp.c $(CC) -c $(CC_SWITCHES) $(SRC_DIR)/compat/strncasecmp.c strstr.o: $(SRC_DIR)/compat/strstr.c $(CC) -c $(CC_SWITCHES) $(SRC_DIR)/compat/strstr.c strtod.o: $(SRC_DIR)/compat/strtod.c $(CC) -c $(CC_SWITCHES) $(SRC_DIR)/compat/strtod.c strtol.o: $(SRC_DIR)/compat/strtol.c $(CC) -c $(CC_SWITCHES) $(SRC_DIR)/compat/strtol.c strtoul.o: $(SRC_DIR)/compat/strtoul.c $(CC) -c $(CC_SWITCHES) $(SRC_DIR)/compat/strtoul.c tmpnam.o: $(SRC_DIR)/compat/tmpnam.c $(CC) -c $(CC_SWITCHES) $(SRC_DIR)/compat/tmpnam.c waitpid.o: $(SRC_DIR)/compat/waitpid.c $(CC) -c $(CC_SWITCHES) $(SRC_DIR)/compat/waitpid.c .c.o: $(CC) -c $(CC_SWITCHES) $< # # Target to check for proper usage of UCHAR macro. # checkuchar: -egrep isalnum\|isalpha\|iscntrl\|isdigit\|islower\|isprint\|ispunct\|isspace\|isupper\|isxdigit $(SRCS) | grep -v UCHAR # # Target to make sure that only symbols with "Tcl" prefixes are # exported. # checkexports: libtcl.a -nm -p libtcl.a | awk '$$2 ~ /[TDB]/ { print $$3 }' | sort -n | grep -v '^[Tt]cl' # # Target to create a proper Tcl distribution from information in the # master source directory. DISTDIR must be defined to indicate where # to put the distribution. # configure: configure.in autoconf dist: configure rm -rf $(DISTDIR) mkdir $(DISTDIR) cp Makefile.in $(DISTDIR) chmod 664 $(DISTDIR)/Makefile.in cp -p $(SRCS) $(DISTDIR) cp -p tclRegexp.h tcl.h tclInt.h tclPort.h patchlevel.h $(DISTDIR) cp configure configure.in $(DISTDIR) chmod 775 $(DISTDIR)/configure $(DISTDIR)/configure.in cp -p changes README porting.notes porting.old license.terms \ install-sh $(DISTDIR) chmod +x $(DISTDIR)/install-sh mkdir $(DISTDIR)/library cp -p license.terms library/*.tcl library/tclIndex $(DISTDIR)/library mkdir $(DISTDIR)/doc cp -p license.terms doc/*.[13n] doc/man.macros $(DISTDIR)/doc mkdir $(DISTDIR)/compat cp -p license.terms compat/*.c compat/*.h compat/README \ $(DISTDIR)/compat mkdir $(DISTDIR)/tests cp -p license.terms $(DISTDIR)/tests cp -p tests/*.test tests/README tests/all tests/defs $(DISTDIR)/tests # DO NOT DELETE THIS LINE -- make depend depends on it. which to install manual entry for tclsh: MAN1_INSTALL_DIR = $(MAN_INSTALL_DIR)/man1 # Directory in which to install manual entries for Tcl's C library # procedures: MAN3_INSTALL_DIR = $(MAN_INSTALL_DIR)/man3 # Directory in which to install manual entries for the built-in # Tcl commands: MANN_INSTALL_DIR = $(MAN_INSTALL_DIR)/mann # To change the compiler switches, tcl7.4b4/regexp.c010044400630510000012000000763510575101434500145000ustar00ousterstaff00002300000001/* * TclRegComp and TclRegExec -- TclRegSub is elsewhere * * Copyright (c) 1986 by University of Toronto. * Written by Henry Spencer. Not derived from licensed software. * * Permission is granted to anyone to use this software for any * purpose on any computer system, and to redistribute it freely, * subject to the following restrictions: * * 1. The author is not responsible for the consequences of use of * this software, no matter how awful, even if they arise * from defects in it. * * 2. The origin of this software must not be misrepresented, either * by explicit claim or by omission. * * 3. Altered versions must be plainly marked as such, and must not * be misrepresented as being the original software. * * Beware that some of this code is subtly aware of the way operator * precedence is structured in regular expressions. Serious changes in * regular-expression syntax might require a total rethink. * * *** NOTE: this code has been altered slightly for use in Tcl: *** * *** 1. Use ckalloc and ckfree instead of malloc and free. *** * *** 2. Add extra argument to regexp to specify the real *** * *** start of the string separately from the start of the *** * *** current search. This is needed to search for multiple *** * *** matches within a string. *** * *** 3. Names have been changed, e.g. from regcomp to *** * *** TclRegComp, to avoid clashes with other *** * *** regexp implementations used by applications. *** * *** 4. Added tclRegexpError declaration and TclRegError *** * *** procedure. *** * *** 5. Various lint-like things, such as casting arguments *** * *** in procedure calls. *** * * *** NOTE: This code has been altered for use in MT-Sturdy Tcl *** * *** 1. All use of static variables has been changed to access *** * *** fields of a structure. *** * *** 2. This in addition to changes to TclRegError makes the *** * *** code multi-thread safe. *** */ static char sccsid[] = "@(#) regexp.c 1.6 95/04/30 16:10:27"; #include "tclInt.h" #include "tclPort.h" /* * The variable below is set to NULL before invoking regexp functions * and checked after those functions. If an error occurred then TclRegError * will set the variable to point to a (static) error message. This * mechanism unfortunately does not support multi-threading, but the * procedures TclRegError and TclGetRegError can be modified to use * thread-specific storage for the variable and thereby make the code * thread-safe. */ static char *tclRegexpError = NULL; /* * The "internal use only" fields in regexp.h are present to pass info from * compile to execute that permits the execute phase to run lots faster on * simple cases. They are: * * regstart char that must begin a match; '\0' if none obvious * reganch is the match anchored (at beginning-of-line only)? * regmust string (pointer into program) that match must include, or NULL * regmlen length of regmust string * * Regstart and reganch permit very fast decisions on suitable starting points * for a match, cutting down the work a lot. Regmust permits fast rejection * of lines that cannot possibly match. The regmust tests are costly enough * that TclRegComp() supplies a regmust only if the r.e. contains something * potentially expensive (at present, the only such thing detected is * or + * at the start of the r.e., which can involve a lot of backup). Regmlen is * supplied because the test in TclRegExec() needs it and TclRegComp() is * computing it anyway. */ /* * Structure for regexp "program". This is essentially a linear encoding * of a nondeterministic finite-state machine (aka syntax charts or * "railroad normal form" in parsing technology). Each node is an opcode * plus a "next" pointer, possibly plus an operand. "Next" pointers of * all nodes except BRANCH implement concatenation; a "next" pointer with * a BRANCH on both ends of it is connecting two alternatives. (Here we * have one of the subtle syntax dependencies: an individual BRANCH (as * opposed to a collection of them) is never concatenated with anything * because of operator precedence.) The operand of some types of node is * a literal string; for others, it is a node leading into a sub-FSM. In * particular, the operand of a BRANCH node is the first node of the branch. * (NB this is *not* a tree structure: the tail of the branch connects * to the thing following the set of BRANCHes.) The opcodes are: */ /* definition number opnd? meaning */ #define END 0 /* no End of program. */ #define BOL 1 /* no Match "" at beginning of line. */ #define EOL 2 /* no Match "" at end of line. */ #define ANY 3 /* no Match any one character. */ #define ANYOF 4 /* str Match any character in this string. */ #define ANYBUT 5 /* str Match any character not in this string. */ #define BRANCH 6 /* node Match this alternative, or the next... */ #define BACK 7 /* no Match "", "next" ptr points backward. */ #define EXACTLY 8 /* str Match this string. */ #define NOTHING 9 /* no Match empty string. */ #define STAR 10 /* node Match this (simple) thing 0 or more times. */ #define PLUS 11 /* node Match this (simple) thing 1 or more times. */ #define OPEN 20 /* no Mark this point in input as start of #n. */ /* OPEN+1 is number 1, etc. */ #define CLOSE 30 /* no Analogous to OPEN. */ /* * Opcode notes: * * BRANCH The set of branches constituting a single choice are hooked * together with their "next" pointers, since precedence prevents * anything being concatenated to any individual branch. The * "next" pointer of the last BRANCH in a choice points to the * thing following the whole choice. This is also where the * final "next" pointer of each individual branch points; each * branch starts with the operand node of a BRANCH node. * * BACK Normal "next" pointers all implicitly point forward; BACK * exists to make loop structures possible. * * STAR,PLUS '?', and complex '*' and '+', are implemented as circular * BRANCH structures using BACK. Simple cases (one character * per match) are implemented with STAR and PLUS for speed * and to minimize recursive plunges. * * OPEN,CLOSE ...are numbered at compile time. */ /* * A node is one char of opcode followed by two chars of "next" pointer. * "Next" pointers are stored as two 8-bit pieces, high order first. The * value is a positive offset from the opcode of the node containing it. * An operand, if any, simply follows the node. (Note that much of the * code generation knows about this implicit relationship.) * * Using two bytes for the "next" pointer is vast overkill for most things, * but allows patterns to get big without disasters. */ #define OP(p) (*(p)) #define NEXT(p) (((*((p)+1)&0377)<<8) + (*((p)+2)&0377)) #define OPERAND(p) ((p) + 3) /* * See regmagic.h for one further detail of program structure. */ /* * Utility definitions. */ #ifndef CHARBITS #define UCHARAT(p) ((int)*(unsigned char *)(p)) #else #define UCHARAT(p) ((int)*(p)&CHARBITS) #endif #define FAIL(m) { TclRegError(m); return(NULL); } #define ISMULT(c) ((c) == '*' || (c) == '+' || (c) == '?') #define META "^$.[()|?+*\\" /* * Flags to be passed up and down. */ #define HASWIDTH 01 /* Known never to match null string. */ #define SIMPLE 02 /* Simple enough to be STAR/PLUS operand. */ #define SPSTART 04 /* Starts with * or +. */ #define WORST 0 /* Worst case. */ /* * Global work variables for TclRegComp(). */ struct regcomp_state { char *regparse; /* Input-scan pointer. */ int regnpar; /* () count. */ char *regcode; /* Code-emit pointer; ®dummy = don't. */ long regsize; /* Code size. */ }; static char regdummy; /* * The first byte of the regexp internal "program" is actually this magic * number; the start node begins in the second byte. */ #define MAGIC 0234 /* * Forward declarations for TclRegComp()'s friends. */ #ifndef STATIC #define STATIC static #endif STATIC char *reg(); STATIC char *regbranch(); STATIC char *regpiece(); STATIC char *regatom(); STATIC char *regnode(); STATIC char *regnext(); STATIC void regc(); STATIC void reginsert(); STATIC void regtail(); STATIC void regoptail(); #ifdef STRCSPN STATIC int strcspn(); #endif /* - TclRegComp - compile a regular expression into internal code * * We can't allocate space until we know how big the compiled form will be, * but we can't compile it (and thus know how big it is) until we've got a * place to put the code. So we cheat: we compile it twice, once with code * generation turned off and size counting turned on, and once "for real". * This also means that we don't allocate space until we are sure that the * thing really will compile successfully, and we never have to move the * code and thus invalidate pointers into it. (Note that it has to be in * one piece because free() must be able to free it all.) * * Beware that the optimization-preparation code in here knows about some * of the structure of the compiled regexp. */ regexp * TclRegComp(exp) char *exp; { register regexp *r; register char *scan; register char *longest; register int len; int flags; struct regcomp_state state; struct regcomp_state *rcstate= &state; if (exp == NULL) FAIL("NULL argument"); /* First pass: determine size, legality. */ rcstate->regparse = exp; rcstate->regnpar = 1; rcstate->regsize = 0L; rcstate->regcode = ®dummy; regc(MAGIC, rcstate); if (reg(0, &flags, rcstate) == NULL) return(NULL); /* Small enough for pointer-storage convention? */ if (rcstate->regsize >= 32767L) /* Probably could be 65535L. */ FAIL("regexp too big"); /* Allocate space. */ r = (regexp *)ckalloc(sizeof(regexp) + (unsigned)rcstate->regsize); if (r == NULL) FAIL("out of space"); /* Second pass: emit code. */ rcstate->regparse = exp; rcstate->regnpar = 1; rcstate->regcode = r->program; regc(MAGIC, rcstate); if (reg(0, &flags, rcstate) == NULL) return(NULL); /* Dig out information for optimizations. */ r->regstart = '\0'; /* Worst-case defaults. */ r->reganch = 0; r->regmust = NULL; r->regmlen = 0; scan = r->program+1; /* First BRANCH. */ if (OP(regnext(scan)) == END) { /* Only one top-level choice. */ scan = OPERAND(scan); /* Starting-point info. */ if (OP(scan) == EXACTLY) r->regstart = *OPERAND(scan); else if (OP(scan) == BOL) r->reganch++; /* * If there's something expensive in the r.e., find the * longest literal string that must appear and make it the * regmust. Resolve ties in favor of later strings, since * the regstart check works with the beginning of the r.e. * and avoiding duplication strengthens checking. Not a * strong reason, but sufficient in the absence of others. */ if (flags&SPSTART) { longest = NULL; len = 0; for (; scan != NULL; scan = regnext(scan)) if (OP(scan) == EXACTLY && ((int) strlen(OPERAND(scan))) >= len) { longest = OPERAND(scan); len = strlen(OPERAND(scan)); } r->regmust = longest; r->regmlen = len; } } return(r); } /* - reg - regular expression, i.e. main body or parenthesized thing * * Caller must absorb opening parenthesis. * * Combining parenthesis handling with the base level of regular expression * is a trifle forced, but the need to tie the tails of the branches to what * follows makes it hard to avoid. */ static char * reg(paren, flagp, rcstate) int paren; /* Parenthesized? */ int *flagp; struct regcomp_state *rcstate; { register char *ret; register char *br; register char *ender; register int parno = 0; int flags; *flagp = HASWIDTH; /* Tentatively. */ /* Make an OPEN node, if parenthesized. */ if (paren) { if (rcstate->regnpar >= NSUBEXP) FAIL("too many ()"); parno = rcstate->regnpar; rcstate->regnpar++; ret = regnode(OPEN+parno,rcstate); } else ret = NULL; /* Pick up the branches, linking them together. */ br = regbranch(&flags,rcstate); if (br == NULL) return(NULL); if (ret != NULL) regtail(ret, br); /* OPEN -> first. */ else ret = br; if (!(flags&HASWIDTH)) *flagp &= ~HASWIDTH; *flagp |= flags&SPSTART; while (*rcstate->regparse == '|') { rcstate->regparse++; br = regbranch(&flags,rcstate); if (br == NULL) return(NULL); regtail(ret, br); /* BRANCH -> BRANCH. */ if (!(flags&HASWIDTH)) *flagp &= ~HASWIDTH; *flagp |= flags&SPSTART; } /* Make a closing node, and hook it on the end. */ ender = regnode((paren) ? CLOSE+parno : END,rcstate); regtail(ret, ender); /* Hook the tails of the branches to the closing node. */ for (br = ret; br != NULL; br = regnext(br)) regoptail(br, ender); /* Check for proper termination. */ if (paren && *rcstate->regparse++ != ')') { FAIL("unmatched ()"); } else if (!paren && *rcstate->regparse != '\0') { if (*rcstate->regparse == ')') { FAIL("unmatched ()"); } else FAIL("junk on end"); /* "Can't happen". */ /* NOTREACHED */ } return(ret); } /* - regbranch - one alternative of an | operator * * Implements the concatenation operator. */ static char * regbranch(flagp, rcstate) int *flagp; struct regcomp_state *rcstate; { register char *ret; register char *chain; register char *latest; int flags; *flagp = WORST; /* Tentatively. */ ret = regnode(BRANCH,rcstate); chain = NULL; while (*rcstate->regparse != '\0' && *rcstate->regparse != '|' && *rcstate->regparse != ')') { latest = regpiece(&flags, rcstate); if (latest == NULL) return(NULL); *flagp |= flags&HASWIDTH; if (chain == NULL) /* First piece. */ *flagp |= flags&SPSTART; else regtail(chain, latest); chain = latest; } if (chain == NULL) /* Loop ran zero times. */ (void) regnode(NOTHING,rcstate); return(ret); } /* - regpiece - something followed by possible [*+?] * * Note that the branching code sequences used for ? and the general cases * of * and + are somewhat optimized: they use the same NOTHING node as * both the endmarker for their branch list and the body of the last branch. * It might seem that this node could be dispensed with entirely, but the * endmarker role is not redundant. */ static char * regpiece(flagp, rcstate) int *flagp; struct regcomp_state *rcstate; { register char *ret; register char op; register char *next; int flags; ret = regatom(&flags,rcstate); if (ret == NULL) return(NULL); op = *rcstate->regparse; if (!ISMULT(op)) { *flagp = flags; return(ret); } if (!(flags&HASWIDTH) && op != '?') FAIL("*+ operand could be empty"); *flagp = (op != '+') ? (WORST|SPSTART) : (WORST|HASWIDTH); if (op == '*' && (flags&SIMPLE)) reginsert(STAR, ret, rcstate); else if (op == '*') { /* Emit x* as (x&|), where & means "self". */ reginsert(BRANCH, ret, rcstate); /* Either x */ regoptail(ret, regnode(BACK,rcstate)); /* and loop */ regoptail(ret, ret); /* back */ regtail(ret, regnode(BRANCH,rcstate)); /* or */ regtail(ret, regnode(NOTHING,rcstate)); /* null. */ } else if (op == '+' && (flags&SIMPLE)) reginsert(PLUS, ret, rcstate); else if (op == '+') { /* Emit x+ as x(&|), where & means "self". */ next = regnode(BRANCH,rcstate); /* Either */ regtail(ret, next); regtail(regnode(BACK,rcstate), ret); /* loop back */ regtail(next, regnode(BRANCH,rcstate)); /* or */ regtail(ret, regnode(NOTHING,rcstate)); /* null. */ } else if (op == '?') { /* Emit x? as (x|) */ reginsert(BRANCH, ret, rcstate); /* Either x */ regtail(ret, regnode(BRANCH,rcstate)); /* or */ next = regnode(NOTHING,rcstate); /* null. */ regtail(ret, next); regoptail(ret, next); } rcstate->regparse++; if (ISMULT(*rcstate->regparse)) FAIL("nested *?+"); return(ret); } /* - regatom - the lowest level * * Optimization: gobbles an entire sequence of ordinary characters so that * it can turn them into a single node, which is smaller to store and * faster to run. Backslashed characters are exceptions, each becoming a * separate node; the code is simpler that way and it's not worth fixing. */ static char * regatom(flagp, rcstate) int *flagp; struct regcomp_state *rcstate; { register char *ret; int flags; *flagp = WORST; /* Tentatively. */ switch (*rcstate->regparse++) { case '^': ret = regnode(BOL,rcstate); break; case '$': ret = regnode(EOL,rcstate); break; case '.': ret = regnode(ANY,rcstate); *flagp |= HASWIDTH|SIMPLE; break; case '[': { register int clss; register int classend; if (*rcstate->regparse == '^') { /* Complement of range. */ ret = regnode(ANYBUT,rcstate); rcstate->regparse++; } else ret = regnode(ANYOF,rcstate); if (*rcstate->regparse == ']' || *rcstate->regparse == '-') regc(*rcstate->regparse++,rcstate); while (*rcstate->regparse != '\0' && *rcstate->regparse != ']') { if (*rcstate->regparse == '-') { rcstate->regparse++; if (*rcstate->regparse == ']' || *rcstate->regparse == '\0') regc('-',rcstate); else { clss = UCHARAT(rcstate->regparse-2)+1; classend = UCHARAT(rcstate->regparse); if (clss > classend+1) FAIL("invalid [] range"); for (; clss <= classend; clss++) regc(clss,rcstate); rcstate->regparse++; } } else regc(*rcstate->regparse++,rcstate); } regc('\0',rcstate); if (*rcstate->regparse != ']') FAIL("unmatched []"); rcstate->regparse++; *flagp |= HASWIDTH|SIMPLE; } break; case '(': ret = reg(1, &flags, rcstate); if (ret == NULL) return(NULL); *flagp |= flags&(HASWIDTH|SPSTART); break; case '\0': case '|': case ')': FAIL("internal urp"); /* Supposed to be caught earlier. */ /* NOTREACHED */ break; case '?': case '+': case '*': FAIL("?+* follows nothing"); /* NOTREACHED */ break; case '\\': if (*rcstate->regparse == '\0') FAIL("trailing \\"); ret = regnode(EXACTLY,rcstate); regc(*rcstate->regparse++,rcstate); regc('\0',rcstate); *flagp |= HASWIDTH|SIMPLE; break; default: { register int len; register char ender; rcstate->regparse--; len = strcspn(rcstate->regparse, META); if (len <= 0) FAIL("internal disaster"); ender = *(rcstate->regparse+len); if (len > 1 && ISMULT(ender)) len--; /* Back off clear of ?+* operand. */ *flagp |= HASWIDTH; if (len == 1) *flagp |= SIMPLE; ret = regnode(EXACTLY,rcstate); while (len > 0) { regc(*rcstate->regparse++,rcstate); len--; } regc('\0',rcstate); } break; } return(ret); } /* - regnode - emit a node */ static char * /* Location. */ regnode(op, rcstate) char op; struct regcomp_state *rcstate; { register char *ret; register char *ptr; ret = rcstate->regcode; if (ret == ®dummy) { rcstate->regsize += 3; return(ret); } ptr = ret; *ptr++ = op; *ptr++ = '\0'; /* Null "next" pointer. */ *ptr++ = '\0'; rcstate->regcode = ptr; return(ret); } /* - regc - emit (if appropriate) a byte of code */ static void regc(b, rcstate) char b; struct regcomp_state *rcstate; { if (rcstate->regcode != ®dummy) *rcstate->regcode++ = b; else rcstate->regsize++; } /* - reginsert - insert an operator in front of already-emitted operand * * Means relocating the operand. */ static void reginsert(op, opnd, rcstate) char op; char *opnd; struct regcomp_state *rcstate; { register char *src; register char *dst; register char *place; if (rcstate->regcode == ®dummy) { rcstate->regsize += 3; return; } src = rcstate->regcode; rcstate->regcode += 3; dst = rcstate->regcode; while (src > opnd) *--dst = *--src; place = opnd; /* Op node, where operand used to be. */ *place++ = op; *place++ = '\0'; *place++ = '\0'; } /* - regtail - set the next-pointer at the end of a node chain */ static void regtail(p, val) char *p; char *val; { register char *scan; register char *temp; register int offset; if (p == ®dummy) return; /* Find last node. */ scan = p; for (;;) { temp = regnext(scan); if (temp == NULL) break; scan = temp; } if (OP(scan) == BACK) offset = scan - val; else offset = val - scan; *(scan+1) = (offset>>8)&0377; *(scan+2) = offset&0377; } /* - regoptail - regtail on operand of first argument; nop if operandless */ static void regoptail(p, val) char *p; char *val; { /* "Operandless" and "op != BRANCH" are synonymous in practice. */ if (p == NULL || p == ®dummy || OP(p) != BRANCH) return; regtail(OPERAND(p), val); } /* * TclRegExec and friends */ /* * Global work variables for TclRegExec(). */ struct regexec_state { char *reginput; /* String-input pointer. */ char *regbol; /* Beginning of input, for ^ check. */ char **regstartp; /* Pointer to startp array. */ char **regendp; /* Ditto for endp. */ }; /* * Forwards. */ STATIC int regtry(); STATIC int regmatch(); STATIC int regrepeat(); #ifdef DEBUG int regnarrate = 0; void regdump(); STATIC char *regprop(); #endif /* - TclRegExec - match a regexp against a string */ int TclRegExec(prog, string, start) register regexp *prog; register char *string; char *start; { register char *s; struct regexec_state state; struct regexec_state *restate= &state; /* Be paranoid... */ if (prog == NULL || string == NULL) { TclRegError("NULL parameter"); return(0); } /* Check validity of program. */ if (UCHARAT(prog->program) != MAGIC) { TclRegError("corrupted program"); return(0); } /* If there is a "must appear" string, look for it. */ if (prog->regmust != NULL) { s = string; while ((s = strchr(s, prog->regmust[0])) != NULL) { if (strncmp(s, prog->regmust, (size_t) prog->regmlen) == 0) break; /* Found it. */ s++; } if (s == NULL) /* Not present. */ return(0); } /* Mark beginning of line for ^ . */ restate->regbol = start; /* Simplest case: anchored match need be tried only once. */ if (prog->reganch) return(regtry(prog, string, restate)); /* Messy cases: unanchored match. */ s = string; if (prog->regstart != '\0') /* We know what char it must start with. */ while ((s = strchr(s, prog->regstart)) != NULL) { if (regtry(prog, s, restate)) return(1); s++; } else /* We don't -- general case. */ do { if (regtry(prog, s, restate)) return(1); } while (*s++ != '\0'); /* Failure. */ return(0); } /* - regtry - try match at specific point */ static int /* 0 failure, 1 success */ regtry(prog, string, restate) regexp *prog; char *string; struct regexec_state *restate; { register int i; register char **sp; register char **ep; restate->reginput = string; restate->regstartp = prog->startp; restate->regendp = prog->endp; sp = prog->startp; ep = prog->endp; for (i = NSUBEXP; i > 0; i--) { *sp++ = NULL; *ep++ = NULL; } if (regmatch(prog->program + 1,restate)) { prog->startp[0] = string; prog->endp[0] = restate->reginput; return(1); } else return(0); } /* - regmatch - main matching routine * * Conceptually the strategy is simple: check to see whether the current * node matches, call self recursively to see whether the rest matches, * and then act accordingly. In practice we make some effort to avoid * recursion, in particular by going through "ordinary" nodes (that don't * need to know whether the rest of the match failed) by a loop instead of * by recursion. */ static int /* 0 failure, 1 success */ regmatch(prog, restate) char *prog; struct regexec_state *restate; { register char *scan; /* Current node. */ char *next; /* Next node. */ scan = prog; #ifdef DEBUG if (scan != NULL && regnarrate) fprintf(stderr, "%s(\n", regprop(scan)); #endif while (scan != NULL) { #ifdef DEBUG if (regnarrate) fprintf(stderr, "%s...\n", regprop(scan)); #endif next = regnext(scan); switch (OP(scan)) { case BOL: if (restate->reginput != restate->regbol) return(0); break; case EOL: if (*restate->reginput != '\0') return(0); break; case ANY: if (*restate->reginput == '\0') return(0); restate->reginput++; break; case EXACTLY: { register int len; register char *opnd; opnd = OPERAND(scan); /* Inline the first character, for speed. */ if (*opnd != *restate->reginput) return(0); len = strlen(opnd); if (len > 1 && strncmp(opnd, restate->reginput, (size_t) len) != 0) return(0); restate->reginput += len; } break; case ANYOF: if (*restate->reginput == '\0' || strchr(OPERAND(scan), *restate->reginput) == NULL) return(0); restate->reginput++; break; case ANYBUT: if (*restate->reginput == '\0' || strchr(OPERAND(scan), *restate->reginput) != NULL) return(0); restate->reginput++; break; case NOTHING: break; case BACK: break; case OPEN+1: case OPEN+2: case OPEN+3: case OPEN+4: case OPEN+5: case OPEN+6: case OPEN+7: case OPEN+8: case OPEN+9: { register int no; register char *save; no = OP(scan) - OPEN; save = restate->reginput; if (regmatch(next,restate)) { /* * Don't set startp if some later * invocation of the same parentheses * already has. */ if (restate->regstartp[no] == NULL) restate->regstartp[no] = save; return(1); } else return(0); } /* NOTREACHED */ break; case CLOSE+1: case CLOSE+2: case CLOSE+3: case CLOSE+4: case CLOSE+5: case CLOSE+6: case CLOSE+7: case CLOSE+8: case CLOSE+9: { register int no; register char *save; no = OP(scan) - CLOSE; save = restate->reginput; if (regmatch(next,restate)) { /* * Don't set endp if some later * invocation of the same parentheses * already has. */ if (restate->regendp[no] == NULL) restate->regendp[no] = save; return(1); } else return(0); } /* NOTREACHED */ break; case BRANCH: { register char *save; if (OP(next) != BRANCH) /* No choice. */ next = OPERAND(scan); /* Avoid recursion. */ else { do { save = restate->reginput; if (regmatch(OPERAND(scan),restate)) return(1); restate->reginput = save; scan = regnext(scan); } while (scan != NULL && OP(scan) == BRANCH); return(0); /* NOTREACHED */ } } /* NOTREACHED */ break; case STAR: case PLUS: { register char nextch; register int no; register char *save; register int min; /* * Lookahead to avoid useless match attempts * when we know what character comes next. */ nextch = '\0'; if (OP(next) == EXACTLY) nextch = *OPERAND(next); min = (OP(scan) == STAR) ? 0 : 1; save = restate->reginput; no = regrepeat(OPERAND(scan),restate); while (no >= min) { /* If it could work, try it. */ if (nextch == '\0' || *restate->reginput == nextch) if (regmatch(next,restate)) return(1); /* Couldn't or didn't -- back up. */ no--; restate->reginput = save + no; } return(0); } /* NOTREACHED */ break; case END: return(1); /* Success! */ /* NOTREACHED */ break; default: TclRegError("memory corruption"); return(0); /* NOTREACHED */ break; } scan = next; } /* * We get here only if there's trouble -- normally "case END" is * the terminating point. */ TclRegError("corrupted pointers"); return(0); } /* - regrepeat - repeatedly match something simple, report how many */ static int regrepeat(p, restate) char *p; struct regexec_state *restate; { register int count = 0; register char *scan; register char *opnd; scan = restate->reginput; opnd = OPERAND(p); switch (OP(p)) { case ANY: count = strlen(scan); scan += count; break; case EXACTLY: while (*opnd == *scan) { count++; scan++; } break; case ANYOF: while (*scan != '\0' && strchr(opnd, *scan) != NULL) { count++; scan++; } break; case ANYBUT: while (*scan != '\0' && strchr(opnd, *scan) == NULL) { count++; scan++; } break; default: /* Oh dear. Called inappropriately. */ TclRegError("internal foulup"); count = 0; /* Best compromise. */ break; } restate->reginput = scan; return(count); } /* - regnext - dig the "next" pointer out of a node */ static char * regnext(p) register char *p; { register int offset; if (p == ®dummy) return(NULL); offset = NEXT(p); if (offset == 0) return(NULL); if (OP(p) == BACK) return(p-offset); else return(p+offset); } #ifdef DEBUG STATIC char *regprop(); /* - regdump - dump a regexp onto stdout in vaguely comprehensible form */ void regdump(r) regexp *r; { register char *s; register char op = EXACTLY; /* Arbitrary non-END op. */ register char *next; s = r->program + 1; while (op != END) { /* While that wasn't END last time... */ op = OP(s); printf("%2d%s", s-r->program, regprop(s)); /* Where, what. */ next = regnext(s); if (next == NULL) /* Next ptr. */ printf("(0)"); else printf("(%d)", (s-r->program)+(next-s)); s += 3; if (op == ANYOF || op == ANYBUT || op == EXACTLY) { /* Literal string, where present. */ while (*s != '\0') { putchar(*s); s++; } s++; } putchar('\n'); } /* Header fields of interest. */ if (r->regstart != '\0') printf("start `%c' ", r->regstart); if (r->reganch) printf("anchored "); if (r->regmust != NULL) printf("must have \"%s\"", r->regmust); printf("\n"); } /* - regprop - printable representation of opcode */ static char * regprop(op) char *op; { register char *p; static char buf[50]; (void) strcpy(buf, ":"); switch (OP(op)) { case BOL: p = "BOL"; break; case EOL: p = "EOL"; break; case ANY: p = "ANY"; break; case ANYOF: p = "ANYOF"; break; case ANYBUT: p = "ANYBUT"; break; case BRANCH: p = "BRANCH"; break; case EXACTLY: p = "EXACTLY"; break; case NOTHING: p = "NOTHING"; break; case BACK: p = "BACK"; break; case END: p = "END"; break; case OPEN+1: case OPEN+2: case OPEN+3: case OPEN+4: case OPEN+5: case OPEN+6: case OPEN+7: case OPEN+8: case OPEN+9: sprintf(buf+strlen(buf), "OPEN%d", OP(op)-OPEN); p = NULL; break; case CLOSE+1: case CLOSE+2: case CLOSE+3: case CLOSE+4: case CLOSE+5: case CLOSE+6: case CLOSE+7: case CLOSE+8: case CLOSE+9: sprintf(buf+strlen(buf), "CLOSE%d", OP(op)-CLOSE); p = NULL; break; case STAR: p = "STAR"; break; case PLUS: p = "PLUS"; break; default: TclRegError("corrupted opcode"); break; } if (p != NULL) (void) strcat(buf, p); return(buf); } #endif /* * The following is provided for those people who do not have strcspn() in * their C libraries. They should get off their butts and do something * about it; at least one public-domain implementation of those (highly * useful) string routines has been published on Usenet. */ #ifdef STRCSPN /* * strcspn - find length of initial segment of s1 consisting entirely * of characters not from s2 */ static int strcspn(s1, s2) char *s1; char *s2; { register char *scan1; register char *scan2; register int count; count = 0; for (scan1 = s1; *scan1 != '\0'; scan1++) { for (scan2 = s2; *scan2 != '\0';) /* ++ moved down. */ if (*scan1 == *scan2++) return(count); count++; } return(count); } #endif /* *---------------------------------------------------------------------- * * TclRegError -- * * This procedure is invoked by the regexp code when an error * occurs. It saves the error message so it can be seen by the * code that called Spencer's code. * * Results: * None. * * Side effects: * The value of "string" is saved in "tclRegexpError". * *---------------------------------------------------------------------- */ void TclRegError(string) char *string; /* Error message. */ { tclRegexpError = string; } char * TclGetRegError() { return tclRegexpError; } 0) break; /* Found it. */ s++; } if (s == NULL) /* Not present. */ return(0); } /* Mark beginning of line for ^ . */ restate->regbol = start; /* Simplest case: anchored match need be tried only once. */ if (prog->reganch) return(regtry(prog, string, resttcl7.4b4/tclAsync.c010044400630510000012000000144440567467740000147740ustar00ousterstaff00002300000001/* * tclAsync.c -- * * This file provides low-level support needed to invoke signal * handlers in a safe way. The code here doesn't actually handle * signals, though. This code is based on proposals made by * Mark Diekhans and Don Libes. * * Copyright (c) 1993 The Regents of the University of California. * Copyright (c) 1994 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #ifndef lint static char sccsid[] = "@(#) tclAsync.c 1.4 94/12/17 16:14:04"; #endif /* not lint */ #include "tclInt.h" /* * One of the following structures exists for each asynchronous * handler: */ typedef struct AsyncHandler { int ready; /* Non-zero means this handler should * be invoked in the next call to * Tcl_AsyncInvoke. */ struct AsyncHandler *nextPtr; /* Next in list of all handlers for * the process. */ Tcl_AsyncProc *proc; /* Procedure to call when handler * is invoked. */ ClientData clientData; /* Value to pass to handler when it * is invoked. */ } AsyncHandler; /* * The variables below maintain a list of all existing handlers. */ static AsyncHandler *firstHandler; /* First handler defined for process, * or NULL if none. */ static AsyncHandler *lastHandler; /* Last handler or NULL. */ /* * The variable below is set to 1 whenever a handler becomes ready and * it is cleared to zero whenever Tcl_AsyncInvoke is called. It can be * checked elsewhere in the application to see if Tcl_AsyncInvoke * should be invoked. */ int tcl_AsyncReady = 0; /* * The variable below indicates whether Tcl_AsyncInvoke is currently * working. If so then we won't set tcl_AsyncReady again until * Tcl_AsyncInvoke returns. */ static int asyncActive = 0; /* *---------------------------------------------------------------------- * * Tcl_AsyncCreate -- * * This procedure creates the data structures for an asynchronous * handler, so that no memory has to be allocated when the handler * is activated. * * Results: * The return value is a token for the handler, which can be used * to activate it later on. * * Side effects: * Information about the handler is recorded. * *---------------------------------------------------------------------- */ Tcl_AsyncHandler Tcl_AsyncCreate(proc, clientData) Tcl_AsyncProc *proc; /* Procedure to call when handler * is invoked. */ ClientData clientData; /* Argument to pass to handler. */ { AsyncHandler *asyncPtr; asyncPtr = (AsyncHandler *) ckalloc(sizeof(AsyncHandler)); asyncPtr->ready = 0; asyncPtr->nextPtr = NULL; asyncPtr->proc = proc; asyncPtr->clientData = clientData; if (firstHandler == NULL) { firstHandler = asyncPtr; } else { lastHandler->nextPtr = asyncPtr; } lastHandler = asyncPtr; return (Tcl_AsyncHandler) asyncPtr; } /* *---------------------------------------------------------------------- * * Tcl_AsyncMark -- * * This procedure is called to request that an asynchronous handler * be invoked as soon as possible. It's typically called from * an interrupt handler, where it isn't safe to do anything that * depends on or modifies application state. * * Results: * None. * * Side effects: * The handler gets marked for invocation later. * *---------------------------------------------------------------------- */ void Tcl_AsyncMark(async) Tcl_AsyncHandler async; /* Token for handler. */ { ((AsyncHandler *) async)->ready = 1; if (!asyncActive) { tcl_AsyncReady = 1; } } /* *---------------------------------------------------------------------- * * Tcl_AsyncInvoke -- * * This procedure is called at a "safe" time at background level * to invoke any active asynchronous handlers. * * Results: * The return value is a normal Tcl result, which is intended to * replace the code argument as the current completion code for * interp. * * Side effects: * Depends on the handlers that are active. * *---------------------------------------------------------------------- */ int Tcl_AsyncInvoke(interp, code) Tcl_Interp *interp; /* If invoked from Tcl_Eval just after * completing a command, points to * interpreter. Otherwise it is * NULL. */ int code; /* If interp is non-NULL, this gives * completion code from command that * just completed. */ { AsyncHandler *asyncPtr; if (tcl_AsyncReady == 0) { return code; } tcl_AsyncReady = 0; asyncActive = 1; if (interp == NULL) { code = 0; } /* * Make one or more passes over the list of handlers, invoking * at most one handler in each pass. After invoking a handler, * go back to the start of the list again so that (a) if a new * higher-priority handler gets marked while executing a lower * priority handler, we execute the higher-priority handler * next, and (b) if a handler gets deleted during the execution * of a handler, then the list structure may change so it isn't * safe to continue down the list anyway. */ while (1) { for (asyncPtr = firstHandler; asyncPtr != NULL; asyncPtr = asyncPtr->nextPtr) { if (asyncPtr->ready) { break; } } if (asyncPtr == NULL) { break; } asyncPtr->ready = 0; code = (*asyncPtr->proc)(asyncPtr->clientData, interp, code); } asyncActive = 0; return code; } /* *---------------------------------------------------------------------- * * Tcl_AsyncDelete -- * * Frees up all the state for an asynchronous handler. The handler * should never be used again. * * Results: * None. * * Side effects: * The state associated with the handler is deleted. * *---------------------------------------------------------------------- */ void Tcl_AsyncDelete(async) Tcl_AsyncHandler async; /* Token for handler to delete. */ { AsyncHandler *asyncPtr = (AsyncHandler *) async; AsyncHandler *prevPtr; if (firstHandler == asyncPtr) { firstHandler = asyncPtr->nextPtr; if (firstHandler == NULL) { lastHandler = NULL; } } else { prevPtr = firstHandler; while (prevPtr->nextPtr != asyncPtr) { prevPtr = prevPtr->nextPtr; } prevPtr->nextPtr = asyncPtr->nextPtr; if (lastHandler == asyncPtr) { lastHandler = prevPtr; } } ckfree((char *) asyncPtr); } static AsyncHandler *lastHandler; /* Last handler or NULL. */ /* * The variable below is set to 1 whenever a handler becomes ready and * it is cleared to zero whenever Tcl_AsyncInvoke is called. It can be * checked tcl7.4b4/tclBasic.c010044400630510000012000001151310576541016500147250ustar00ousterstaff00002300000001/* * tclBasic.c -- * * Contains the basic facilities for TCL command interpretation, * including interpreter creation and deletion, command creation * and deletion, and command parsing and execution. * * Copyright (c) 1987-1994 The Regents of the University of California. * Copyright (c) 1994-1995 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ static char sccsid[] = "@(#) tclBasic.c 1.165 95/04/25 11:39:49"; #include "tclInt.h" #ifndef TCL_GENERIC_ONLY # include "tclPort.h" #endif /* * The following variable holds the name of a user-specific startup script * to source if the application is being run nteractively (e.g. "~/.tclshrc"). * Set by Tcl_AppInit. NULL means don't source anything ever. */ char *tcl_RcFileName = NULL; /* * The following structure defines all of the commands in the Tcl core, * and the C procedures that execute them. */ typedef struct { char *name; /* Name of command. */ Tcl_CmdProc *proc; /* Procedure that executes command. */ } CmdInfo; /* * Built-in commands, and the procedures associated with them: */ static CmdInfo builtInCmds[] = { /* * Commands in the generic core: */ {"append", Tcl_AppendCmd}, {"array", Tcl_ArrayCmd}, {"break", Tcl_BreakCmd}, {"case", Tcl_CaseCmd}, {"catch", Tcl_CatchCmd}, {"concat", Tcl_ConcatCmd}, {"continue", Tcl_ContinueCmd}, {"error", Tcl_ErrorCmd}, {"eval", Tcl_EvalCmd}, {"expr", Tcl_ExprCmd}, {"for", Tcl_ForCmd}, {"foreach", Tcl_ForeachCmd}, {"format", Tcl_FormatCmd}, {"global", Tcl_GlobalCmd}, {"history", Tcl_HistoryCmd}, {"if", Tcl_IfCmd}, {"incr", Tcl_IncrCmd}, {"info", Tcl_InfoCmd}, {"join", Tcl_JoinCmd}, {"lappend", Tcl_LappendCmd}, {"lindex", Tcl_LindexCmd}, {"linsert", Tcl_LinsertCmd}, {"list", Tcl_ListCmd}, {"llength", Tcl_LlengthCmd}, {"lrange", Tcl_LrangeCmd}, {"lreplace", Tcl_LreplaceCmd}, {"lsearch", Tcl_LsearchCmd}, {"lsort", Tcl_LsortCmd}, {"proc", Tcl_ProcCmd}, {"regexp", Tcl_RegexpCmd}, {"regsub", Tcl_RegsubCmd}, {"rename", Tcl_RenameCmd}, {"return", Tcl_ReturnCmd}, {"scan", Tcl_ScanCmd}, {"set", Tcl_SetCmd}, {"split", Tcl_SplitCmd}, {"string", Tcl_StringCmd}, {"subst", Tcl_SubstCmd}, {"switch", Tcl_SwitchCmd}, {"trace", Tcl_TraceCmd}, {"unset", Tcl_UnsetCmd}, {"uplevel", Tcl_UplevelCmd}, {"upvar", Tcl_UpvarCmd}, {"while", Tcl_WhileCmd}, /* * Commands in the UNIX core: */ #ifndef TCL_GENERIC_ONLY {"cd", Tcl_CdCmd}, {"close", Tcl_CloseCmd}, {"eof", Tcl_EofCmd}, {"exec", Tcl_ExecCmd}, {"exit", Tcl_ExitCmd}, {"file", Tcl_FileCmd}, {"flush", Tcl_FlushCmd}, {"gets", Tcl_GetsCmd}, {"glob", Tcl_GlobCmd}, {"open", Tcl_OpenCmd}, {"pid", Tcl_PidCmd}, {"puts", Tcl_PutsCmd}, {"pwd", Tcl_PwdCmd}, {"read", Tcl_ReadCmd}, {"seek", Tcl_SeekCmd}, {"source", Tcl_SourceCmd}, {"tell", Tcl_TellCmd}, {"time", Tcl_TimeCmd}, #endif /* TCL_GENERIC_ONLY */ {NULL, (Tcl_CmdProc *) NULL} }; /* *---------------------------------------------------------------------- * * Tcl_CreateInterp -- * * Create a new TCL command interpreter. * * Results: * The return value is a token for the interpreter, which may be * used in calls to procedures like Tcl_CreateCmd, Tcl_Eval, or * Tcl_DeleteInterp. * * Side effects: * The command interpreter is initialized with an empty variable * table and the built-in commands. SIGPIPE signals are set to * be ignored (see comment below for details). * *---------------------------------------------------------------------- */ Tcl_Interp * Tcl_CreateInterp() { register Interp *iPtr; register Command *cmdPtr; register CmdInfo *cmdInfoPtr; int i; char *libDir; static int firstInterp = 1; iPtr = (Interp *) ckalloc(sizeof(Interp)); iPtr->result = iPtr->resultSpace; iPtr->freeProc = 0; iPtr->errorLine = 0; Tcl_InitHashTable(&iPtr->commandTable, TCL_STRING_KEYS); Tcl_InitHashTable(&iPtr->mathFuncTable, TCL_STRING_KEYS); Tcl_InitHashTable(&iPtr->globalTable, TCL_STRING_KEYS); iPtr->numLevels = 0; iPtr->maxNestingDepth = 1000; iPtr->framePtr = NULL; iPtr->varFramePtr = NULL; iPtr->activeTracePtr = NULL; iPtr->returnCode = TCL_OK; iPtr->errorInfo = NULL; iPtr->errorCode = NULL; iPtr->numEvents = 0; iPtr->events = NULL; iPtr->curEvent = 0; iPtr->curEventNum = 0; iPtr->revPtr = NULL; iPtr->historyFirst = NULL; iPtr->revDisables = 1; iPtr->evalFirst = iPtr->evalLast = NULL; iPtr->appendResult = NULL; iPtr->appendAvl = 0; iPtr->appendUsed = 0; for (i = 0; i < NUM_REGEXPS; i++) { iPtr->patterns[i] = NULL; iPtr->patLengths[i] = -1; iPtr->regexps[i] = NULL; } strcpy(iPtr->pdFormat, DEFAULT_PD_FORMAT); iPtr->pdPrec = DEFAULT_PD_PREC; iPtr->cmdCount = 0; iPtr->noEval = 0; iPtr->evalFlags = 0; iPtr->scriptFile = NULL; iPtr->flags = 0; iPtr->tracePtr = NULL; iPtr->deleteCallbackPtr = NULL; iPtr->resultSpace[0] = 0; /* * Create the built-in commands. Do it here, rather than calling * Tcl_CreateCommand, because it's faster (there's no need to * check for a pre-existing command by the same name). */ for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL; cmdInfoPtr++) { int new; Tcl_HashEntry *hPtr; hPtr = Tcl_CreateHashEntry(&iPtr->commandTable, cmdInfoPtr->name, &new); if (new) { cmdPtr = (Command *) ckalloc(sizeof(Command)); cmdPtr->hPtr = hPtr; cmdPtr->proc = cmdInfoPtr->proc; cmdPtr->clientData = (ClientData) NULL; cmdPtr->deleteProc = NULL; cmdPtr->deleteData = (ClientData) NULL; Tcl_SetHashValue(hPtr, cmdPtr); } } #ifndef TCL_GENERIC_ONLY TclSetupEnv((Tcl_Interp *) iPtr); /* * The code below causes SIGPIPE (broken pipe) errors to * be ignored. This is needed so that Tcl processes don't * die if they create child processes (e.g. using "exec" or * "open") that terminate prematurely. The signal handler * is only set up when the first interpreter is created; * after this the application can override the handler with * a different one of its own, if it wants. */ if (firstInterp) { (void) signal(SIGPIPE, SIG_IGN); firstInterp = 0; } #endif /* * Set up variables such as tcl_library and tcl_precision. */ libDir = getenv("TCL_LIBRARY"); if (libDir == NULL) { libDir = TCL_LIBRARY; } Tcl_SetVar((Tcl_Interp *) iPtr, "tcl_library", libDir, TCL_GLOBAL_ONLY); Tcl_TraceVar2((Tcl_Interp *) iPtr, "tcl_precision", (char *) NULL, TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, TclPrecTraceProc, (ClientData) NULL); return (Tcl_Interp *) iPtr; } /* *---------------------------------------------------------------------- * * Tcl_Init -- * * This procedure is typically invoked by Tcl_AppInit procedures * to perform additional initialization for a Tcl interpreter, * such as sourcing the "init.tcl" script. * * Results: * Returns a standard Tcl completion code and sets interp->result * if there is an error. * * Side effects: * Depends on what's in the init.tcl script. * *---------------------------------------------------------------------- */ int Tcl_Init(interp) Tcl_Interp *interp; /* Interpreter to initialize. */ { static char initCmd[] = "if [file exists [info library]/init.tcl] {\n\ source [info library]/init.tcl\n\ } else {\n\ set msg \"can't find [info library]/init.tcl; perhaps you \"\n\ append msg \"need to\\ninstall Tcl or set your TCL_LIBRARY \"\n\ append msg \"environment variable?\"\n\ error $msg\n\ }"; return Tcl_Eval(interp, initCmd); } /* *-------------------------------------------------------------- * * Tcl_CallWhenDeleted -- * * Arrange for a procedure to be called before a given * interpreter is deleted. * * Results: * None. * * Side effects: * When Tcl_DeleteInterp is invoked to delete interp, * proc will be invoked. See the manual entry for * details. * *-------------------------------------------------------------- */ void Tcl_CallWhenDeleted(interp, proc, clientData) Tcl_Interp *interp; /* Interpreter to watch. */ Tcl_InterpDeleteProc *proc; /* Procedure to call when interpreter * is about to be deleted. */ ClientData clientData; /* One-word value to pass to proc. */ { DeleteCallback *dcPtr, *prevPtr; Interp *iPtr = (Interp *) interp; dcPtr = (DeleteCallback *) ckalloc(sizeof(DeleteCallback)); dcPtr->proc = proc; dcPtr->clientData = clientData; dcPtr->nextPtr = NULL; if (iPtr->deleteCallbackPtr == NULL) { iPtr->deleteCallbackPtr = dcPtr; } else { prevPtr = iPtr->deleteCallbackPtr; while (prevPtr->nextPtr != NULL) { prevPtr = prevPtr->nextPtr; } prevPtr->nextPtr = dcPtr; } } /* *-------------------------------------------------------------- * * Tcl_DontCallWhenDeleted -- * * Cancel the arrangement for a procedure to be called when * a given interpreter is deleted. * * Results: * None. * * Side effects: * If proc and clientData were previously registered as a * callback via Tcl_CallWhenDeleted, they are unregistered. * If they weren't previously registered then nothing * happens. * *-------------------------------------------------------------- */ void Tcl_DontCallWhenDeleted(interp, proc, clientData) Tcl_Interp *interp; /* Interpreter to watch. */ Tcl_InterpDeleteProc *proc; /* Procedure to call when interpreter * is about to be deleted. */ ClientData clientData; /* One-word value to pass to proc. */ { DeleteCallback *prevPtr, *dcPtr; Interp *iPtr = (Interp *) interp; for (prevPtr = NULL, dcPtr = iPtr->deleteCallbackPtr; dcPtr != NULL; prevPtr = dcPtr, dcPtr = dcPtr->nextPtr) { if ((dcPtr->proc != proc) || (dcPtr->clientData != clientData)) { continue; } if (prevPtr == NULL) { iPtr->deleteCallbackPtr = dcPtr->nextPtr; } else { prevPtr->nextPtr = dcPtr->nextPtr; } ckfree((char *) dcPtr); break; } } /* *---------------------------------------------------------------------- * * Tcl_DeleteInterp -- * * Delete an interpreter and free up all of the resources associated * with it. * * Results: * None. * * Side effects: * The interpreter is destroyed. The caller should never again * use the interp token. * *---------------------------------------------------------------------- */ void Tcl_DeleteInterp(interp) Tcl_Interp *interp; /* Token for command interpreter (returned * by a previous call to Tcl_CreateInterp). */ { Interp *iPtr = (Interp *) interp; Tcl_HashEntry *hPtr; Tcl_HashSearch search; register Command *cmdPtr; DeleteCallback *dcPtr; int i; /* * If the interpreter is in use, delay the deletion until later. */ iPtr->flags |= DELETED; if (iPtr->numLevels != 0) { return; } /* * Invoke deletion callbacks. */ while (iPtr->deleteCallbackPtr != NULL) { dcPtr = iPtr->deleteCallbackPtr; iPtr->deleteCallbackPtr = dcPtr->nextPtr; (*dcPtr->proc)(dcPtr->clientData, interp); ckfree((char *) dcPtr); } /* * Free up any remaining resources associated with the * interpreter. */ for (hPtr = Tcl_FirstHashEntry(&iPtr->commandTable, &search); hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { cmdPtr = (Command *) Tcl_GetHashValue(hPtr); if (cmdPtr->deleteProc != NULL) { (*cmdPtr->deleteProc)(cmdPtr->deleteData); } ckfree((char *) cmdPtr); } Tcl_DeleteHashTable(&iPtr->commandTable); for (hPtr = Tcl_FirstHashEntry(&iPtr->mathFuncTable, &search); hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { ckfree((char *) Tcl_GetHashValue(hPtr)); } Tcl_DeleteHashTable(&iPtr->mathFuncTable); TclDeleteVars(iPtr, &iPtr->globalTable); /* * Free up the result *after* deleting variables, since variable * deletion could have transferred ownership of the result string * to Tcl. */ Tcl_FreeResult(interp); if (iPtr->errorInfo != NULL) { ckfree(iPtr->errorInfo); } if (iPtr->errorCode != NULL) { ckfree(iPtr->errorCode); } if (iPtr->events != NULL) { int i; for (i = 0; i < iPtr->numEvents; i++) { ckfree(iPtr->events[i].command); } ckfree((char *) iPtr->events); } while (iPtr->revPtr != NULL) { HistoryRev *nextPtr = iPtr->revPtr->nextPtr; ckfree((char *) iPtr->revPtr); iPtr->revPtr = nextPtr; } if (iPtr->appendResult != NULL) { ckfree(iPtr->appendResult); } for (i = 0; i < NUM_REGEXPS; i++) { if (iPtr->patterns[i] == NULL) { break; } ckfree(iPtr->patterns[i]); ckfree((char *) iPtr->regexps[i]); } while (iPtr->tracePtr != NULL) { Trace *nextPtr = iPtr->tracePtr->nextPtr; ckfree((char *) iPtr->tracePtr); iPtr->tracePtr = nextPtr; } ckfree((char *) iPtr); } /* *---------------------------------------------------------------------- * * Tcl_CreateCommand -- * * Define a new command in a command table. * * Results: * The return value is a token for the command, which can * be used in future calls to Tcl_NameOfCommand. * * Side effects: * If a command named cmdName already exists for interp, it is * deleted. In the future, when cmdName is seen as the name of * a command by Tcl_Eval, proc will be called. When the command * is deleted from the table, deleteProc will be called. See the * manual entry for details on the calling sequence. * *---------------------------------------------------------------------- */ Tcl_Command Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc) Tcl_Interp *interp; /* Token for command interpreter (returned * by a previous call to Tcl_CreateInterp). */ char *cmdName; /* Name of command. */ Tcl_CmdProc *proc; /* Command procedure to associate with * cmdName. */ ClientData clientData; /* Arbitrary one-word value to pass to proc. */ Tcl_CmdDeleteProc *deleteProc; /* If not NULL, gives a procedure to call when * this command is deleted. */ { Interp *iPtr = (Interp *) interp; register Command *cmdPtr; Tcl_HashEntry *hPtr; int new; hPtr = Tcl_CreateHashEntry(&iPtr->commandTable, cmdName, &new); if (!new) { /* * Command already exists: delete the old one. */ cmdPtr = (Command *) Tcl_GetHashValue(hPtr); if (cmdPtr->deleteProc != NULL) { (*cmdPtr->deleteProc)(cmdPtr->deleteData); } } else { cmdPtr = (Command *) ckalloc(sizeof(Command)); Tcl_SetHashValue(hPtr, cmdPtr); } cmdPtr->hPtr = hPtr; cmdPtr->proc = proc; cmdPtr->clientData = clientData; cmdPtr->deleteProc = deleteProc; cmdPtr->deleteData = clientData; return (Tcl_Command) cmdPtr; } /* *---------------------------------------------------------------------- * * Tcl_SetCommandInfo -- * * Modifies various information about a Tcl command. * * Results: * If cmdName exists in interp, then the information at *infoPtr * is stored with the command in place of the current information * and 1 is returned. If the command doesn't exist then 0 is * returned. * * Side effects: * None. * *---------------------------------------------------------------------- */ int Tcl_SetCommandInfo(interp, cmdName, infoPtr) Tcl_Interp *interp; /* Interpreter in which to look * for command. */ char *cmdName; /* Name of desired command. */ Tcl_CmdInfo *infoPtr; /* Where to store information about * command. */ { Tcl_HashEntry *hPtr; Command *cmdPtr; hPtr = Tcl_FindHashEntry(&((Interp *) interp)->commandTable, cmdName); if (hPtr == NULL) { return 0; } cmdPtr = (Command *) Tcl_GetHashValue(hPtr); cmdPtr->proc = infoPtr->proc; cmdPtr->clientData = infoPtr->clientData; cmdPtr->deleteProc = infoPtr->deleteProc; cmdPtr->deleteData = infoPtr->deleteData; return 1; } /* *---------------------------------------------------------------------- * * Tcl_GetCommandInfo -- * * Returns various information about a Tcl command. * * Results: * If cmdName exists in interp, then *infoPtr is modified to * hold information about cmdName and 1 is returned. If the * command doesn't exist then 0 is returned and *infoPtr isn't * modified. * * Side effects: * None. * *---------------------------------------------------------------------- */ int Tcl_GetCommandInfo(interp, cmdName, infoPtr) Tcl_Interp *interp; /* Interpreter in which to look * for command. */ char *cmdName; /* Name of desired command. */ Tcl_CmdInfo *infoPtr; /* Where to store information about * command. */ { Tcl_HashEntry *hPtr; Command *cmdPtr; hPtr = Tcl_FindHashEntry(&((Interp *) interp)->commandTable, cmdName); if (hPtr == NULL) { return 0; } cmdPtr = (Command *) Tcl_GetHashValue(hPtr); infoPtr->proc = cmdPtr->proc; infoPtr->clientData = cmdPtr->clientData; infoPtr->deleteProc = cmdPtr->deleteProc; infoPtr->deleteData = cmdPtr->deleteData; return 1; } /* *---------------------------------------------------------------------- * * Tcl_GetCommandName -- * * Given a token returned by Tcl_CreateCommand, this procedure * returns the current name of the command (which may have changed * due to renaming). * * Results: * The return value is the name of the given command. * * Side effects: * None. * *---------------------------------------------------------------------- */ char * Tcl_GetCommandName(interp, command) Tcl_Interp *interp; /* Interpreter containing the command. */ Tcl_Command command; /* Token for the command, returned by a * previous call to Tcl_CreateCommand. * The command must not have been deleted. */ { Command *cmdPtr = (Command *) command; Interp *iPtr = (Interp *) interp; return Tcl_GetHashKey(&iPtr->commandTable, cmdPtr->hPtr); } /* *---------------------------------------------------------------------- * * Tcl_DeleteCommand -- * * Remove the given command from the given interpreter. * * Results: * 0 is returned if the command was deleted successfully. * -1 is returned if there didn't exist a command by that * name. * * Side effects: * CmdName will no longer be recognized as a valid command for * interp. * *---------------------------------------------------------------------- */ int Tcl_DeleteCommand(interp, cmdName) Tcl_Interp *interp; /* Token for command interpreter (returned * by a previous call to Tcl_CreateInterp). */ char *cmdName; /* Name of command to remove. */ { Interp *iPtr = (Interp *) interp; Tcl_HashEntry *hPtr; Command *cmdPtr; hPtr = Tcl_FindHashEntry(&iPtr->commandTable, cmdName); if (hPtr == NULL) { return -1; } cmdPtr = (Command *) Tcl_GetHashValue(hPtr); if (cmdPtr->deleteProc != NULL) { (*cmdPtr->deleteProc)(cmdPtr->deleteData); } ckfree((char *) cmdPtr); Tcl_DeleteHashEntry(hPtr); return 0; } /* *----------------------------------------------------------------- * * Tcl_Eval -- * * Parse and execute a command in the Tcl language. * * Results: * The return value is one of the return codes defined in tcl.hd * (such as TCL_OK), and interp->result contains a string value * to supplement the return code. The value of interp->result * will persist only until the next call to Tcl_Eval: copy it or * lose it! *TermPtr is filled in with the character just after * the last one that was part of the command (usually a NULL * character or a closing bracket). * * Side effects: * Almost certainly; depends on the command. * *----------------------------------------------------------------- */ int Tcl_Eval(interp, cmd) Tcl_Interp *interp; /* Token for command interpreter (returned * by a previous call to Tcl_CreateInterp). */ char *cmd; /* Pointer to TCL command to interpret. */ { /* * The storage immediately below is used to generate a copy * of the command, after all argument substitutions. Pv will * contain the argv values passed to the command procedure. */ # define NUM_CHARS 200 char copyStorage[NUM_CHARS]; ParseValue pv; char *oldBuffer; /* * This procedure generates an (argv, argc) array for the command, * It starts out with stack-allocated space but uses dynamically- * allocated storage to increase it if needed. */ # define NUM_ARGS 10 char *(argStorage[NUM_ARGS]); char **argv = argStorage; int argc; int argSize = NUM_ARGS; register char *src; /* Points to current character * in cmd. */ char termChar; /* Return when this character is found * (either ']' or '\0'). Zero means * that newlines terminate commands. */ int flags; /* Interp->evalFlags value when the * procedure was called. */ int result; /* Return value. */ register Interp *iPtr = (Interp *) interp; Tcl_HashEntry *hPtr; Command *cmdPtr; char *termPtr; /* Contains character just after the * last one in the command. */ char *cmdStart; /* Points to first non-blank char. in * command (used in calling trace * procedures). */ char *ellipsis = ""; /* Used in setting errorInfo variable; * set to "..." to indicate that not * all of offending command is included * in errorInfo. "" means that the * command is all there. */ register Trace *tracePtr; int oldCount = iPtr->cmdCount; /* Used to tell whether any commands * at all were executed. */ /* * Initialize the result to an empty string and clear out any * error information. This makes sure that we return an empty * result if there are no commands in the command string. */ Tcl_FreeResult((Tcl_Interp *) iPtr); iPtr->result = iPtr->resultSpace; iPtr->resultSpace[0] = 0; result = TCL_OK; /* * Initialize the area in which command copies will be assembled. */ pv.buffer = copyStorage; pv.end = copyStorage + NUM_CHARS - 1; pv.expandProc = TclExpandParseValue; pv.clientData = (ClientData) NULL; src = cmd; flags = iPtr->evalFlags; iPtr->evalFlags = 0; if (flags & TCL_BRACKET_TERM) { termChar = ']'; } else { termChar = 0; } termPtr = src; cmdStart = src; /* * Check depth of nested calls to Tcl_Eval: if this gets too large, * it's probably because of an infinite loop somewhere. */ iPtr->numLevels++; if (iPtr->numLevels > iPtr->maxNestingDepth) { iPtr->numLevels--; iPtr->result = "too many nested calls to Tcl_Eval (infinite loop?)"; iPtr->termPtr = termPtr; return TCL_ERROR; } /* * There can be many sub-commands (separated by semi-colons or * newlines) in one command string. This outer loop iterates over * individual commands. */ while (*src != termChar) { iPtr->flags &= ~(ERR_IN_PROGRESS | ERROR_CODE_SET); /* * Skim off leading white space and semi-colons, and skip * comments. */ while (1) { register char c = *src; if ((CHAR_TYPE(c) != TCL_SPACE) && (c != ';') && (c != '\n')) { break; } src += 1; } if (*src == '#') { for (src++; *src != 0; src++) { if ((*src == '\n') && (src[-1] != '\\')) { src++; break; } } continue; } cmdStart = src; /* * Parse the words of the command, generating the argc and * argv for the command procedure. May have to call * TclParseWords several times, expanding the argv array * between calls. */ pv.next = oldBuffer = pv.buffer; argc = 0; while (1) { int newArgs, maxArgs; char **newArgv; int i; /* * Note: the "- 2" below guarantees that we won't use the * last two argv slots here. One is for a NULL pointer to * mark the end of the list, and the other is to leave room * for inserting the command name "unknown" as the first * argument (see below). */ maxArgs = argSize - argc - 2; result = TclParseWords((Tcl_Interp *) iPtr, src, flags, maxArgs, &termPtr, &newArgs, &argv[argc], &pv); src = termPtr; if (result != TCL_OK) { ellipsis = "..."; goto done; } /* * Careful! Buffer space may have gotten reallocated while * parsing words. If this happened, be sure to update all * of the older argv pointers to refer to the new space. */ if (oldBuffer != pv.buffer) { int i; for (i = 0; i < argc; i++) { argv[i] = pv.buffer + (argv[i] - oldBuffer); } oldBuffer = pv.buffer; } argc += newArgs; if (newArgs < maxArgs) { argv[argc] = (char *) NULL; break; } /* * Args didn't all fit in the current array. Make it bigger. */ argSize *= 2; newArgv = (char **) ckalloc((unsigned) argSize * sizeof(char *)); for (i = 0; i < argc; i++) { newArgv[i] = argv[i]; } if (argv != argStorage) { ckfree((char *) argv); } argv = newArgv; } /* * If this is an empty command (or if we're just parsing * commands without evaluating them), then just skip to the * next command. */ if ((argc == 0) || iPtr->noEval) { continue; } argv[argc] = NULL; /* * Save information for the history module, if needed. */ if (flags & TCL_RECORD_BOUNDS) { iPtr->evalFirst = cmdStart; iPtr->evalLast = src-1; } /* * Find the procedure to execute this command. If there isn't * one, then see if there is a command "unknown". If so, * invoke it instead, passing it the words of the original * command as arguments. */ hPtr = Tcl_FindHashEntry(&iPtr->commandTable, argv[0]); if (hPtr == NULL) { int i; hPtr = Tcl_FindHashEntry(&iPtr->commandTable, "unknown"); if (hPtr == NULL) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "invalid command name \"", argv[0], "\"", (char *) NULL); result = TCL_ERROR; goto done; } for (i = argc; i >= 0; i--) { argv[i+1] = argv[i]; } argv[0] = "unknown"; argc++; } cmdPtr = (Command *) Tcl_GetHashValue(hPtr); /* * Call trace procedures, if any. */ for (tracePtr = iPtr->tracePtr; tracePtr != NULL; tracePtr = tracePtr->nextPtr) { char saved; if (tracePtr->level < iPtr->numLevels) { continue; } saved = *src; *src = 0; (*tracePtr->proc)(tracePtr->clientData, interp, iPtr->numLevels, cmdStart, cmdPtr->proc, cmdPtr->clientData, argc, argv); *src = saved; } /* * At long last, invoke the command procedure. Reset the * result to its default empty value first (it could have * gotten changed by earlier commands in the same command * string). */ iPtr->cmdCount++; Tcl_FreeResult(iPtr); iPtr->result = iPtr->resultSpace; iPtr->resultSpace[0] = 0; result = (*cmdPtr->proc)(cmdPtr->clientData, interp, argc, argv); if (tcl_AsyncReady) { result = Tcl_AsyncInvoke(interp, result); } if (result != TCL_OK) { break; } } done: /* * If no commands at all were executed, check for asynchronous * handlers so that they at least get one change to execute. * This is needed to handle event loops written in Tcl with * empty bodies (I'm not sure that loops like this are a good * idea, * but...). */ if ((oldCount == iPtr->cmdCount) && (tcl_AsyncReady)) { result = Tcl_AsyncInvoke(interp, result); } /* * Free up any extra resources that were allocated. */ if (pv.buffer != copyStorage) { ckfree((char *) pv.buffer); } if (argv != argStorage) { ckfree((char *) argv); } iPtr->numLevels--; if (iPtr->numLevels == 0) { if (result == TCL_RETURN) { result = TclUpdateReturnInfo(iPtr); } if ((result != TCL_OK) && (result != TCL_ERROR) && !(flags & TCL_ALLOW_EXCEPTIONS)) { Tcl_ResetResult(interp); if (result == TCL_BREAK) { iPtr->result = "invoked \"break\" outside of a loop"; } else if (result == TCL_CONTINUE) { iPtr->result = "invoked \"continue\" outside of a loop"; } else { iPtr->result = iPtr->resultSpace; sprintf(iPtr->resultSpace, "command returned bad code: %d", result); } result = TCL_ERROR; } if (iPtr->flags & DELETED) { /* * Someone tried to delete the interpreter, but it couldn't * actually be deleted because commands were in the middle of * being evaluated. Delete the interpreter now. Also, return * immediately: we can't execute the remaining code in the * procedure because it accesses fields of the dead interpreter. */ Tcl_DeleteInterp(interp); return result; } } /* * If an error occurred, record information about what was being * executed when the error occurred. */ if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { int numChars; register char *p; /* * Compute the line number where the error occurred. */ iPtr->errorLine = 1; for (p = cmd; p != cmdStart; p++) { if (*p == '\n') { iPtr->errorLine++; } } for ( ; isspace(UCHAR(*p)) || (*p == ';'); p++) { if (*p == '\n') { iPtr->errorLine++; } } /* * Figure out how much of the command to print in the error * message (up to a certain number of characters, or up to * the first new-line). */ numChars = src - cmdStart; if (numChars > (NUM_CHARS-50)) { numChars = NUM_CHARS-50; ellipsis = " ..."; } if (!(iPtr->flags & ERR_IN_PROGRESS)) { sprintf(copyStorage, "\n while executing\n\"%.*s%s\"", numChars, cmdStart, ellipsis); } else { sprintf(copyStorage, "\n invoked from within\n\"%.*s%s\"", numChars, cmdStart, ellipsis); } Tcl_AddErrorInfo(interp, copyStorage); iPtr->flags &= ~ERR_ALREADY_LOGGED; } else { iPtr->flags &= ~ERR_ALREADY_LOGGED; } iPtr->termPtr = termPtr; return result; } /* *---------------------------------------------------------------------- * * Tcl_CreateTrace -- * * Arrange for a procedure to be called to trace command execution. * * Results: * The return value is a token for the trace, which may be passed * to Tcl_DeleteTrace to eliminate the trace. * * Side effects: * From now on, proc will be called just before a command procedure * is called to execute a Tcl command. Calls to proc will have the * following form: * * void * proc(clientData, interp, level, command, cmdProc, cmdClientData, * argc, argv) * ClientData clientData; * Tcl_Interp *interp; * int level; * char *command; * int (*cmdProc)(); * ClientData cmdClientData; * int argc; * char **argv; * { * } * * The clientData and interp arguments to proc will be the same * as the corresponding arguments to this procedure. Level gives * the nesting level of command interpretation for this interpreter * (0 corresponds to top level). Command gives the ASCII text of * the raw command, cmdProc and cmdClientData give the procedure that * will be called to process the command and the ClientData value it * will receive, and argc and argv give the arguments to the * command, after any argument parsing and substitution. Proc * does not return a value. * *---------------------------------------------------------------------- */ Tcl_Trace Tcl_CreateTrace(interp, level, proc, clientData) Tcl_Interp *interp; /* Interpreter in which to create the trace. */ int level; /* Only call proc for commands at nesting level * <= level (1 => top level). */ Tcl_CmdTraceProc *proc; /* Procedure to call before executing each * command. */ ClientData clientData; /* Arbitrary one-word value to pass to proc. */ { register Trace *tracePtr; register Interp *iPtr = (Interp *) interp; tracePtr = (Trace *) ckalloc(sizeof(Trace)); tracePtr->level = level; tracePtr->proc = proc; tracePtr->clientData = clientData; tracePtr->nextPtr = iPtr->tracePtr; iPtr->tracePtr = tracePtr; return (Tcl_Trace) tracePtr; } /* *---------------------------------------------------------------------- * * Tcl_DeleteTrace -- * * Remove a trace. * * Results: * None. * * Side effects: * From now on there will be no more calls to the procedure given * in trace. * *---------------------------------------------------------------------- */ void Tcl_DeleteTrace(interp, trace) Tcl_Interp *interp; /* Interpreter that contains trace. */ Tcl_Trace trace; /* Token for trace (returned previously by * Tcl_CreateTrace). */ { register Interp *iPtr = (Interp *) interp; register Trace *tracePtr = (Trace *) trace; register Trace *tracePtr2; if (iPtr->tracePtr == tracePtr) { iPtr->tracePtr = tracePtr->nextPtr; ckfree((char *) tracePtr); } else { for (tracePtr2 = iPtr->tracePtr; tracePtr2 != NULL; tracePtr2 = tracePtr2->nextPtr) { if (tracePtr2->nextPtr == tracePtr) { tracePtr2->nextPtr = tracePtr->nextPtr; ckfree((char *) tracePtr); return; } } } } /* *---------------------------------------------------------------------- * * Tcl_AddErrorInfo -- * * Add information to a message being accumulated that describes * the current error. * * Results: * None. * * Side effects: * The contents of message are added to the "errorInfo" variable. * If Tcl_Eval has been called since the current value of errorInfo * was set, errorInfo is cleared before adding the new message. * *---------------------------------------------------------------------- */ void Tcl_AddErrorInfo(interp, message) Tcl_Interp *interp; /* Interpreter to which error information * pertains. */ char *message; /* Message to record. */ { register Interp *iPtr = (Interp *) interp; /* * If an error is already being logged, then the new errorInfo * is the concatenation of the old info and the new message. * If this is the first piece of info for the error, then the * new errorInfo is the concatenation of the message in * interp->result and the new message. */ if (!(iPtr->flags & ERR_IN_PROGRESS)) { Tcl_SetVar2(interp, "errorInfo", (char *) NULL, interp->result, TCL_GLOBAL_ONLY); iPtr->flags |= ERR_IN_PROGRESS; /* * If the errorCode variable wasn't set by the code that generated * the error, set it to "NONE". */ if (!(iPtr->flags & ERROR_CODE_SET)) { (void) Tcl_SetVar2(interp, "errorCode", (char *) NULL, "NONE", TCL_GLOBAL_ONLY); } } Tcl_SetVar2(interp, "errorInfo", (char *) NULL, message, TCL_GLOBAL_ONLY|TCL_APPEND_VALUE); } /* *---------------------------------------------------------------------- * * Tcl_VarEval -- * * Given a variable number of string arguments, concatenate them * all together and execute the result as a Tcl command. * * Results: * A standard Tcl return result. An error message or other * result may be left in interp->result. * * Side effects: * Depends on what was done by the command. * *---------------------------------------------------------------------- */ /* VARARGS2 */ /* ARGSUSED */ int #ifndef lint Tcl_VarEval(va_alist) #else Tcl_VarEval(iPtr, p, va_alist) Tcl_Interp *iPtr; /* Interpreter in which to execute command. */ char *p; /* One or more strings to concatenate, * terminated with a NULL string. */ #endif va_dcl { va_list argList; #define FIXED_SIZE 200 char fixedSpace[FIXED_SIZE+1]; int spaceAvl, spaceUsed, length; char *string, *cmd; Tcl_Interp *interp; int result; /* * Copy the strings one after the other into a single larger * string. Use stack-allocated space for small commands, but if * the command gets too large than call ckalloc to create the * space. */ va_start(argList); interp = va_arg(argList, Tcl_Interp *); spaceAvl = FIXED_SIZE; spaceUsed = 0; cmd = fixedSpace; while (1) { string = va_arg(argList, char *); if (string == NULL) { break; } length = strlen(string); if ((spaceUsed + length) > spaceAvl) { char *new; spaceAvl = spaceUsed + length; spaceAvl += spaceAvl/2; new = ckalloc((unsigned) spaceAvl); memcpy((VOID *) new, (VOID *) cmd, (size_t) spaceUsed); if (cmd != fixedSpace) { ckfree(cmd); } cmd = new; } strcpy(cmd + spaceUsed, string); spaceUsed += length; } va_end(argList); cmd[spaceUsed] = '\0'; result = Tcl_Eval(interp, cmd); if (cmd != fixedSpace) { ckfree(cmd); } return result; } /* *---------------------------------------------------------------------- * * Tcl_GlobalEval -- * * Evaluate a command at global level in an interpreter. * * Results: * A standard Tcl result is returned, and interp->result is * modified accordingly. * * Side effects: * The command string is executed in interp, and the execution * is carried out in the variable context of global level (no * procedures active), just as if an "uplevel #0" command were * being executed. * *---------------------------------------------------------------------- */ int Tcl_GlobalEval(interp, command) Tcl_Interp *interp; /* Interpreter in which to evaluate command. */ char *command; /* Command to evaluate. */ { register Interp *iPtr = (Interp *) interp; int result; CallFrame *savedVarFramePtr; savedVarFramePtr = iPtr->varFramePtr; iPtr->varFramePtr = NULL; result = Tcl_Eval(interp, command); iPtr->varFramePtr = savedVarFramePtr; return result; } /* *---------------------------------------------------------------------- * * Tcl_SetRecursionLimit -- * * Set the maximum number of recursive calls that may be active * for an interpreter at once. * * Results: * The return value is the old limit on nesting for interp. * * Side effects: * None. * *---------------------------------------------------------------------- */ int Tcl_SetRecursionLimit(interp, depth) Tcl_Interp *interp; /* Interpreter whose nesting limit * is to be set. */ int depth; /* New value for maximimum depth. */ { Interp *iPtr = (Interp *) interp; int old; old = iPtr->maxNestingDepth; if (depth > 0) { iPtr->maxNestingDepth = depth; } return old; } /* *---------------------------------------------------------------------- * * Tcl_AllowExceptions -- * * Sets a flag in an interpreter so that exceptions can occur * in the next call to Tcl_Eval without them being turned into * errors. * * Results: * None. * * Side effects: * The TCL_ALLOW_EXCEPTIONS flag gets set in the interpreter's * evalFlags structure. See the reference documentation for * more details. * *---------------------------------------------------------------------- */ void Tcl_AllowExceptions(interp) Tcl_Interp *interp; /* Interpreter in which to set flag. */ { Interp *iPtr = (Interp *) interp; iPtr->evalFlags |= TCL_ALLOW_EXCEPTIONS; } when the error occurred. */ if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { int numChars; register char *p; /* * Compute the line number where the error occurred. */ iPtr->errorLine = 1; for (p = cmd; p != cmdStart; p++) { if (*p == '\n') { iPtr->errorLine++; } } for ( ; isspace(UCHAR(*p)) || (*p == ';'); p++) { if (*p == '\n') { iPtr->errorLine++; } }tcl7.4b4/tclCkalloc.c010044400630510000012000000450030575747370300152640ustar00ousterstaff00002300000001/* * tclCkalloc.c -- * * Interface to malloc and free that provides support for debugging problems * involving overwritten, double freeing memory and loss of memory. * * Copyright (c) 1991-1994 The Regents of the University of California. * Copyright (c) 1994-1995 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * This code contributed by Karl Lehenbauer and Mark Diekhans * */ static char sccsid[] = "@(#) tclCkalloc.c 1.8 95/05/20 16:14:11"; #include "tclInt.h" #define FALSE 0 #define TRUE 1 #ifdef TCL_MEM_DEBUG #ifndef TCL_GENERIC_ONLY #include "tclPort.h" #endif /* * One of the following structures is allocated each time the * "memory tag" command is invoked, to hold the current tag. */ typedef struct MemTag { int refCount; /* Number of mem_headers referencing * this tag. */ char string[4]; /* Actual size of string will be as * large as needed for actual tag. This * must be the last field in the structure. */ } MemTag; #define TAG_SIZE(bytesInString) ((unsigned) sizeof(MemTag) + bytesInString - 3) static MemTag *curTagPtr = NULL;/* Tag to use in all future mem_headers * (set by "memory tag" command). */ /* * One of the following structures is allocated just before each * dynamically allocated chunk of memory, both to record information * about the chunk and to help detect chunk under-runs. */ #define LOW_GUARD_SIZE (8 + (32 - (sizeof(long) + sizeof(int)))%8) struct mem_header { struct mem_header *flink; struct mem_header *blink; MemTag *tagPtr; /* Tag from "memory tag" command; may be * NULL. */ char *file; long length; int line; unsigned char low_guard[LOW_GUARD_SIZE]; /* Aligns body on 8-byte boundary, plus * provides at least 8 additional guard bytes * to detect underruns. */ char body[1]; /* First byte of client's space. Actual * size of this field will be larger than * one. */ }; static struct mem_header *allocHead = NULL; /* List of allocated structures */ #define GUARD_VALUE 0141 /* * The following macro determines the amount of guard space *above* each * chunk of memory. */ #define HIGH_GUARD_SIZE 8 /* * The following macro computes the offset of the "body" field within * mem_header. It is used to get back to the header pointer from the * body pointer that's used by clients. */ #ifdef offsetof #define BODY_OFFSET ((unsigned long) offsetof(mem_header, body)) #else #define BODY_OFFSET \ ((unsigned long) ((char *) &((struct mem_header *) 0)->body)) #endif static int total_mallocs = 0; static int total_frees = 0; static int current_bytes_malloced = 0; static int maximum_bytes_malloced = 0; static int current_malloc_packets = 0; static int maximum_malloc_packets = 0; static int break_on_malloc = 0; static int trace_on_at_malloc = 0; static int alloc_tracing = FALSE; static int init_malloced_bodies = TRUE; #ifdef MEM_VALIDATE static int validate_memory = TRUE; #else static int validate_memory = FALSE; #endif /* * Prototypes for procedures defined in this file: */ static int MemoryCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); /* *---------------------------------------------------------------------- * * dump_memory_info -- * Display the global memory management statistics. * *---------------------------------------------------------------------- */ static void dump_memory_info(outFile) FILE *outFile; { fprintf(outFile,"total mallocs %10d\n", total_mallocs); fprintf(outFile,"total frees %10d\n", total_frees); fprintf(outFile,"current packets allocated %10d\n", current_malloc_packets); fprintf(outFile,"current bytes allocated %10d\n", current_bytes_malloced); fprintf(outFile,"maximum packets allocated %10d\n", maximum_malloc_packets); fprintf(outFile,"maximum bytes allocated %10d\n", maximum_bytes_malloced); } /* *---------------------------------------------------------------------- * * ValidateMemory -- * Procedure to validate allocted memory guard zones. * *---------------------------------------------------------------------- */ static void ValidateMemory (memHeaderP, file, line, nukeGuards) struct mem_header *memHeaderP; char *file; int line; int nukeGuards; { unsigned char *hiPtr; int idx; int guard_failed = FALSE; int byte; for (idx = 0; idx < LOW_GUARD_SIZE; idx++) { byte = *(memHeaderP->low_guard + idx); if (byte != GUARD_VALUE) { guard_failed = TRUE; fflush (stdout); byte &= 0xff; fprintf(stderr, "low guard byte %d is 0x%x \t%c\n", idx, byte, (isprint(UCHAR(byte)) ? byte : ' ')); } } if (guard_failed) { dump_memory_info (stderr); fprintf (stderr, "low guard failed at %lx, %s %d\n", (long unsigned int) memHeaderP->body, file, line); fflush (stderr); /* In case name pointer is bad. */ fprintf (stderr, "%ld bytes allocated at (%s %d)\n", memHeaderP->length, memHeaderP->file, memHeaderP->line); panic ("Memory validation failure"); } hiPtr = (unsigned char *)memHeaderP->body + memHeaderP->length; for (idx = 0; idx < HIGH_GUARD_SIZE; idx++) { byte = *(hiPtr + idx); if (byte != GUARD_VALUE) { guard_failed = TRUE; fflush (stdout); byte &= 0xff; fprintf(stderr, "hi guard byte %d is 0x%x \t%c\n", idx, byte, (isprint(UCHAR(byte)) ? byte : ' ')); } } if (guard_failed) { dump_memory_info (stderr); fprintf (stderr, "high guard failed at %lx, %s %d\n", (long unsigned int) memHeaderP->body, file, line); fflush (stderr); /* In case name pointer is bad. */ fprintf (stderr, "%ld bytes allocated at (%s %d)\n", memHeaderP->length, memHeaderP->file, memHeaderP->line); panic ("Memory validation failure"); } if (nukeGuards) { memset ((char *) memHeaderP->low_guard, 0, LOW_GUARD_SIZE); memset ((char *) hiPtr, 0, HIGH_GUARD_SIZE); } } /* *---------------------------------------------------------------------- * * Tcl_ValidateAllMemory -- * Validates guard regions for all allocated memory. * *---------------------------------------------------------------------- */ void Tcl_ValidateAllMemory (file, line) char *file; int line; { struct mem_header *memScanP; for (memScanP = allocHead; memScanP != NULL; memScanP = memScanP->flink) ValidateMemory (memScanP, file, line, FALSE); } /* *---------------------------------------------------------------------- * * Tcl_DumpActiveMemory -- * Displays all allocated memory to stderr. * * Results: * Return TCL_ERROR if an error accessing the file occures, `errno' * will have the file error number left in it. *---------------------------------------------------------------------- */ int Tcl_DumpActiveMemory (fileName) char *fileName; { FILE *fileP; struct mem_header *memScanP; char *address; fileP = fopen (fileName, "w"); if (fileP == NULL) return TCL_ERROR; for (memScanP = allocHead; memScanP != NULL; memScanP = memScanP->flink) { address = &memScanP->body [0]; fprintf (fileP, "%8lx - %8lx %7ld @ %s %d %s", (long unsigned int) address, (long unsigned int) address + memScanP->length - 1, memScanP->length, memScanP->file, memScanP->line, (memScanP->tagPtr == NULL) ? "" : memScanP->tagPtr->string); (void) fputc('\n', fileP); } fclose (fileP); return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_DbCkalloc - debugging ckalloc * * Allocate the requested amount of space plus some extra for * guard bands at both ends of the request, plus a size, panicing * if there isn't enough space, then write in the guard bands * and return the address of the space in the middle that the * user asked for. * * The second and third arguments are file and line, these contain * the filename and line number corresponding to the caller. * These are sent by the ckalloc macro; it uses the preprocessor * autodefines __FILE__ and __LINE__. * *---------------------------------------------------------------------- */ char * Tcl_DbCkalloc(size, file, line) unsigned int size; char *file; int line; { struct mem_header *result; if (validate_memory) Tcl_ValidateAllMemory (file, line); result = (struct mem_header *)malloc((unsigned)size + sizeof(struct mem_header) + HIGH_GUARD_SIZE); if (result == NULL) { fflush(stdout); dump_memory_info(stderr); panic("unable to alloc %d bytes, %s line %d", size, file, line); } /* * Fill in guard zones and size. Also initialize the contents of * the block with bogus bytes to detect uses of initialized data. * Link into allocated list. */ if (init_malloced_bodies) { memset ((VOID *) result, GUARD_VALUE, size + sizeof(struct mem_header) + HIGH_GUARD_SIZE); } else { memset ((char *) result->low_guard, GUARD_VALUE, LOW_GUARD_SIZE); memset (result->body + size, GUARD_VALUE, HIGH_GUARD_SIZE); } result->length = size; result->tagPtr = curTagPtr; if (curTagPtr != NULL) { curTagPtr->refCount++; } result->file = file; result->line = line; result->flink = allocHead; result->blink = NULL; if (allocHead != NULL) allocHead->blink = result; allocHead = result; total_mallocs++; if (trace_on_at_malloc && (total_mallocs >= trace_on_at_malloc)) { (void) fflush(stdout); fprintf(stderr, "reached malloc trace enable point (%d)\n", total_mallocs); fflush(stderr); alloc_tracing = TRUE; trace_on_at_malloc = 0; } if (alloc_tracing) fprintf(stderr,"ckalloc %lx %d %s %d\n", (long unsigned int) result->body, size, file, line); if (break_on_malloc && (total_mallocs >= break_on_malloc)) { break_on_malloc = 0; (void) fflush(stdout); fprintf(stderr,"reached malloc break limit (%d)\n", total_mallocs); fprintf(stderr, "program will now enter C debugger\n"); (void) fflush(stderr); abort(); } current_malloc_packets++; if (current_malloc_packets > maximum_malloc_packets) maximum_malloc_packets = current_malloc_packets; current_bytes_malloced += size; if (current_bytes_malloced > maximum_bytes_malloced) maximum_bytes_malloced = current_bytes_malloced; return result->body; } /* *---------------------------------------------------------------------- * * Tcl_DbCkfree - debugging ckfree * * Verify that the low and high guards are intact, and if so * then free the buffer else panic. * * The guards are erased after being checked to catch duplicate * frees. * * The second and third arguments are file and line, these contain * the filename and line number corresponding to the caller. * These are sent by the ckfree macro; it uses the preprocessor * autodefines __FILE__ and __LINE__. * *---------------------------------------------------------------------- */ int Tcl_DbCkfree(ptr, file, line) char * ptr; char *file; int line; { struct mem_header *memp = (struct mem_header *)(ptr - BODY_OFFSET); if (alloc_tracing) fprintf(stderr, "ckfree %lx %ld %s %d\n", (long unsigned int) memp->body, memp->length, file, line); if (validate_memory) Tcl_ValidateAllMemory (file, line); ValidateMemory (memp, file, line, TRUE); if (init_malloced_bodies) { memset((VOID *) ptr, GUARD_VALUE, (size_t) memp->length); } total_frees++; current_malloc_packets--; current_bytes_malloced -= memp->length; if (memp->tagPtr != NULL) { memp->tagPtr->refCount--; if ((memp->tagPtr->refCount == 0) && (curTagPtr != memp->tagPtr)) { free((char *) memp->tagPtr); } } /* * Delink from allocated list */ if (memp->flink != NULL) memp->flink->blink = memp->blink; if (memp->blink != NULL) memp->blink->flink = memp->flink; if (allocHead == memp) allocHead = memp->flink; free((char *) memp); return 0; } /* *-------------------------------------------------------------------- * * Tcl_DbCkrealloc - debugging ckrealloc * * Reallocate a chunk of memory by allocating a new one of the * right size, copying the old data to the new location, and then * freeing the old memory space, using all the memory checking * features of this package. * *-------------------------------------------------------------------- */ char * Tcl_DbCkrealloc(ptr, size, file, line) char *ptr; unsigned int size; char *file; int line; { char *new; unsigned int copySize; struct mem_header *memp = (struct mem_header *)(ptr - BODY_OFFSET); copySize = size; if (copySize > memp->length) { copySize = memp->length; } new = Tcl_DbCkalloc(size, file, line); memcpy((VOID *) new, (VOID *) ptr, (size_t) copySize); Tcl_DbCkfree(ptr, file, line); return(new); } /* *---------------------------------------------------------------------- * * MemoryCmd -- * Implements the TCL memory command: * memory info * memory display * break_on_malloc count * trace_on_at_malloc count * trace on|off * validate on|off * * Results: * Standard TCL results. * *---------------------------------------------------------------------- */ /* ARGSUSED */ static int MemoryCmd (clientData, interp, argc, argv) ClientData clientData; Tcl_Interp *interp; int argc; char **argv; { char *fileName; Tcl_DString buffer; int result; if (argc < 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " option [args..]\"", (char *) NULL); return TCL_ERROR; } if (strcmp(argv[1],"active") == 0) { if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " active file\"", (char *) NULL); return TCL_ERROR; } fileName = Tcl_TildeSubst(interp, argv[2], &buffer); if (fileName == NULL) { return TCL_ERROR; } result = Tcl_DumpActiveMemory (fileName); Tcl_DStringFree(&buffer); if (result != TCL_OK) { Tcl_AppendResult(interp, "error accessing ", argv[2], (char *) NULL); return TCL_ERROR; } return TCL_OK; } if (strcmp(argv[1],"break_on_malloc") == 0) { if (argc != 3) goto argError; if (Tcl_GetInt(interp, argv[2], &break_on_malloc) != TCL_OK) return TCL_ERROR; return TCL_OK; } if (strcmp(argv[1],"info") == 0) { dump_memory_info(stdout); return TCL_OK; } if (strcmp(argv[1],"init") == 0) { if (argc != 3) goto bad_suboption; init_malloced_bodies = (strcmp(argv[2],"on") == 0); return TCL_OK; } if (strcmp(argv[1],"tag") == 0) { if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " tag string\"", (char *) NULL); return TCL_ERROR; } if ((curTagPtr != NULL) && (curTagPtr->refCount == 0)) { free((char *) curTagPtr); } curTagPtr = (MemTag *) malloc(TAG_SIZE(strlen(argv[2]))); curTagPtr->refCount = 0; strcpy(curTagPtr->string, argv[2]); return TCL_OK; } if (strcmp(argv[1],"trace") == 0) { if (argc != 3) goto bad_suboption; alloc_tracing = (strcmp(argv[2],"on") == 0); return TCL_OK; } if (strcmp(argv[1],"trace_on_at_malloc") == 0) { if (argc != 3) goto argError; if (Tcl_GetInt(interp, argv[2], &trace_on_at_malloc) != TCL_OK) return TCL_ERROR; return TCL_OK; } if (strcmp(argv[1],"validate") == 0) { if (argc != 3) goto bad_suboption; validate_memory = (strcmp(argv[2],"on") == 0); return TCL_OK; } Tcl_AppendResult(interp, "bad option \"", argv[1], "\": should be active, break_on_malloc, info, init, ", "tag, trace, trace_on_at_malloc, or validate", (char *) NULL); return TCL_ERROR; argError: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " ", argv[1], " count\"", (char *) NULL); return TCL_ERROR; bad_suboption: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " ", argv[1], " on|off\"", (char *) NULL); return TCL_ERROR; } /* *---------------------------------------------------------------------- * * Tcl_InitMemory -- * Initialize the memory command. * *---------------------------------------------------------------------- */ void Tcl_InitMemory(interp) Tcl_Interp *interp; { Tcl_CreateCommand (interp, "memory", MemoryCmd, (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL); } #else /* *---------------------------------------------------------------------- * * Tcl_Ckalloc -- * Interface to malloc when TCL_MEM_DEBUG is disabled. It does check * that memory was actually allocated. * *---------------------------------------------------------------------- */ VOID * Tcl_Ckalloc (size) unsigned int size; { char *result; result = malloc(size); if (result == NULL) panic("unable to alloc %d bytes", size); return result; } /* *---------------------------------------------------------------------- * * TckCkfree -- * Interface to free when TCL_MEM_DEBUG is disabled. Done here rather * in the macro to keep some modules from being compiled with * TCL_MEM_DEBUG enabled and some with it disabled. * *---------------------------------------------------------------------- */ void Tcl_Ckfree (ptr) VOID *ptr; { free (ptr); } /* *---------------------------------------------------------------------- * * Tcl_InitMemory -- * Dummy initialization for memory command, which is only available * if TCL_MEM_DEBUG is on. * *---------------------------------------------------------------------- */ /* ARGSUSED */ void Tcl_InitMemory(interp) Tcl_Interp *interp; { } #endif es __FILE__ and __LINE__. * *---------------------------------------------------------------------- */ char * Tcl_DbCkalloc(size, file, line) unsigned int size; char *file; int line; { struct mem_header *result; if (validate_memory) Tcl_ValidateAllMemory (file, line); result = (struct mem_header *)malloc((unsigned)size + sizeof(struct mem_header) + HIGH_GUARD_SIZE); if (result == NULL) { fflush(stdout); tcl7.4b4/tclCmdAH.c010044400630510000012000000550370575245117700146340ustar00ousterstaff00002300000001/* * tclCmdAH.c -- * * This file contains the top-level command routines for most of * the Tcl built-in commands whose names begin with the letters * A to H. * * Copyright (c) 1987-1993 The Regents of the University of California. * Copyright (c) 1994-1995 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ static char sccsid[] = "@(#) tclCmdAH.c 1.98 95/05/05 09:29:51"; #include "tclInt.h" #include "tclPort.h" /* *---------------------------------------------------------------------- * * Tcl_BreakCmd -- * * This procedure is invoked to process the "break" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_BreakCmd(dummy, interp, argc, argv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { if (argc != 1) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], "\"", (char *) NULL); return TCL_ERROR; } return TCL_BREAK; } /* *---------------------------------------------------------------------- * * Tcl_CaseCmd -- * * This procedure is invoked to process the "case" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_CaseCmd(dummy, interp, argc, argv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { int i, result; int body; char *string; int caseArgc, splitArgs; char **caseArgv; if (argc < 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " string ?in? patList body ... ?default body?\"", (char *) NULL); return TCL_ERROR; } string = argv[1]; body = -1; if (strcmp(argv[2], "in") == 0) { i = 3; } else { i = 2; } caseArgc = argc - i; caseArgv = argv + i; /* * If all of the pattern/command pairs are lumped into a single * argument, split them out again. */ splitArgs = 0; if (caseArgc == 1) { result = Tcl_SplitList(interp, caseArgv[0], &caseArgc, &caseArgv); if (result != TCL_OK) { return result; } splitArgs = 1; } for (i = 0; i < caseArgc; i += 2) { int patArgc, j; char **patArgv; register char *p; if (i == (caseArgc-1)) { interp->result = "extra case pattern with no body"; result = TCL_ERROR; goto cleanup; } /* * Check for special case of single pattern (no list) with * no backslash sequences. */ for (p = caseArgv[i]; *p != 0; p++) { if (isspace(UCHAR(*p)) || (*p == '\\')) { break; } } if (*p == 0) { if ((*caseArgv[i] == 'd') && (strcmp(caseArgv[i], "default") == 0)) { body = i+1; } if (Tcl_StringMatch(string, caseArgv[i])) { body = i+1; goto match; } continue; } /* * Break up pattern lists, then check each of the patterns * in the list. */ result = Tcl_SplitList(interp, caseArgv[i], &patArgc, &patArgv); if (result != TCL_OK) { goto cleanup; } for (j = 0; j < patArgc; j++) { if (Tcl_StringMatch(string, patArgv[j])) { body = i+1; break; } } ckfree((char *) patArgv); if (j < patArgc) { break; } } match: if (body != -1) { result = Tcl_Eval(interp, caseArgv[body]); if (result == TCL_ERROR) { char msg[100]; sprintf(msg, "\n (\"%.50s\" arm line %d)", caseArgv[body-1], interp->errorLine); Tcl_AddErrorInfo(interp, msg); } goto cleanup; } /* * Nothing matched: return nothing. */ result = TCL_OK; cleanup: if (splitArgs) { ckfree((char *) caseArgv); } return result; } /* *---------------------------------------------------------------------- * * Tcl_CatchCmd -- * * This procedure is invoked to process the "catch" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_CatchCmd(dummy, interp, argc, argv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { int result; if ((argc != 2) && (argc != 3)) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " command ?varName?\"", (char *) NULL); return TCL_ERROR; } result = Tcl_Eval(interp, argv[1]); if (argc == 3) { if (Tcl_SetVar(interp, argv[2], interp->result, 0) == NULL) { Tcl_SetResult(interp, "couldn't save command result in variable", TCL_STATIC); return TCL_ERROR; } } Tcl_ResetResult(interp); sprintf(interp->result, "%d", result); return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_ConcatCmd -- * * This procedure is invoked to process the "concat" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_ConcatCmd(dummy, interp, argc, argv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { if (argc >= 2) { interp->result = Tcl_Concat(argc-1, argv+1); interp->freeProc = (Tcl_FreeProc *) free; } return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_ContinueCmd -- * * This procedure is invoked to process the "continue" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_ContinueCmd(dummy, interp, argc, argv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { if (argc != 1) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], "\"", (char *) NULL); return TCL_ERROR; } return TCL_CONTINUE; } /* *---------------------------------------------------------------------- * * Tcl_ErrorCmd -- * * This procedure is invoked to process the "error" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_ErrorCmd(dummy, interp, argc, argv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { Interp *iPtr = (Interp *) interp; if ((argc < 2) || (argc > 4)) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " message ?errorInfo? ?errorCode?\"", (char *) NULL); return TCL_ERROR; } if ((argc >= 3) && (argv[2][0] != 0)) { Tcl_AddErrorInfo(interp, argv[2]); iPtr->flags |= ERR_ALREADY_LOGGED; } if (argc == 4) { Tcl_SetVar2(interp, "errorCode", (char *) NULL, argv[3], TCL_GLOBAL_ONLY); iPtr->flags |= ERROR_CODE_SET; } Tcl_SetResult(interp, argv[1], TCL_VOLATILE); return TCL_ERROR; } /* *---------------------------------------------------------------------- * * Tcl_EvalCmd -- * * This procedure is invoked to process the "eval" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_EvalCmd(dummy, interp, argc, argv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { int result; char *cmd; if (argc < 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " arg ?arg ...?\"", (char *) NULL); return TCL_ERROR; } if (argc == 2) { result = Tcl_Eval(interp, argv[1]); } else { /* * More than one argument: concatenate them together with spaces * between, then evaluate the result. */ cmd = Tcl_Concat(argc-1, argv+1); result = Tcl_Eval(interp, cmd); ckfree(cmd); } if (result == TCL_ERROR) { char msg[60]; sprintf(msg, "\n (\"eval\" body line %d)", interp->errorLine); Tcl_AddErrorInfo(interp, msg); } return result; } /* *---------------------------------------------------------------------- * * Tcl_ExprCmd -- * * This procedure is invoked to process the "expr" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_ExprCmd(dummy, interp, argc, argv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { Tcl_DString buffer; int i, result; if (argc < 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " arg ?arg ...?\"", (char *) NULL); return TCL_ERROR; } if (argc == 2) { return Tcl_ExprString(interp, argv[1]); } Tcl_DStringInit(&buffer); Tcl_DStringAppend(&buffer, argv[1], -1); for (i = 2; i < argc; i++) { Tcl_DStringAppend(&buffer, " ", 1); Tcl_DStringAppend(&buffer, argv[i], -1); } result = Tcl_ExprString(interp, buffer.string); Tcl_DStringFree(&buffer); return result; } /* *---------------------------------------------------------------------- * * Tcl_ForCmd -- * * This procedure is invoked to process the "for" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_ForCmd(dummy, interp, argc, argv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { int result, value; if (argc != 5) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " start test next command\"", (char *) NULL); return TCL_ERROR; } result = Tcl_Eval(interp, argv[1]); if (result != TCL_OK) { if (result == TCL_ERROR) { Tcl_AddErrorInfo(interp, "\n (\"for\" initial command)"); } return result; } while (1) { result = Tcl_ExprBoolean(interp, argv[2], &value); if (result != TCL_OK) { return result; } if (!value) { break; } result = Tcl_Eval(interp, argv[4]); if ((result != TCL_OK) && (result != TCL_CONTINUE)) { if (result == TCL_ERROR) { char msg[60]; sprintf(msg, "\n (\"for\" body line %d)", interp->errorLine); Tcl_AddErrorInfo(interp, msg); } break; } result = Tcl_Eval(interp, argv[3]); if (result == TCL_BREAK) { break; } else if (result != TCL_OK) { if (result == TCL_ERROR) { Tcl_AddErrorInfo(interp, "\n (\"for\" loop-end command)"); } return result; } } if (result == TCL_BREAK) { result = TCL_OK; } if (result == TCL_OK) { Tcl_ResetResult(interp); } return result; } /* *---------------------------------------------------------------------- * * Tcl_ForeachCmd -- * * This procedure is invoked to process the "foreach" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_ForeachCmd(dummy, interp, argc, argv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { int listArgc, i, result; char **listArgv; if (argc != 4) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " varName list command\"", (char *) NULL); return TCL_ERROR; } /* * Break the list up into elements, and execute the command once * for each value of the element. */ result = Tcl_SplitList(interp, argv[2], &listArgc, &listArgv); if (result != TCL_OK) { return result; } for (i = 0; i < listArgc; i++) { if (Tcl_SetVar(interp, argv[1], listArgv[i], 0) == NULL) { Tcl_SetResult(interp, "couldn't set loop variable", TCL_STATIC); result = TCL_ERROR; break; } result = Tcl_Eval(interp, argv[3]); if (result != TCL_OK) { if (result == TCL_CONTINUE) { result = TCL_OK; } else if (result == TCL_BREAK) { result = TCL_OK; break; } else if (result == TCL_ERROR) { char msg[100]; sprintf(msg, "\n (\"foreach\" body line %d)", interp->errorLine); Tcl_AddErrorInfo(interp, msg); break; } else { break; } } } ckfree((char *) listArgv); if (result == TCL_OK) { Tcl_ResetResult(interp); } return result; } /* *---------------------------------------------------------------------- * * Tcl_FormatCmd -- * * This procedure is invoked to process the "format" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_FormatCmd(dummy, interp, argc, argv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { register char *format; /* Used to read characters from the format * string. */ char newFormat[40]; /* A new format specifier is generated here. */ int width; /* Field width from field specifier, or 0 if * no width given. */ int precision; /* Field precision from field specifier, or 0 * if no precision given. */ int size; /* Number of bytes needed for result of * conversion, based on type of conversion * ("e", "s", etc.), width, and precision. */ int intValue; /* Used to hold value to pass to sprintf, if * it's a one-word integer or char value */ char *ptrValue = NULL; /* Used to hold value to pass to sprintf, if * it's a one-word value. */ double doubleValue; /* Used to hold value to pass to sprintf if * it's a double value. */ int whichValue; /* Indicates which of intValue, ptrValue, * or doubleValue has the value to pass to * sprintf, according to the following * definitions: */ # define INT_VALUE 0 # define PTR_VALUE 1 # define DOUBLE_VALUE 2 char *dst = interp->result; /* Where result is stored. Starts off at * interp->resultSpace, but may get dynamically * re-allocated if this isn't enough. */ int dstSize = 0; /* Number of non-null characters currently * stored at dst. */ int dstSpace = TCL_RESULT_SIZE; /* Total amount of storage space available * in dst (not including null terminator. */ int noPercent; /* Special case for speed: indicates there's * no field specifier, just a string to copy. */ int argIndex; /* Index of argument to substitute next. */ int gotXpg = 0; /* Non-zero means that an XPG3 %n$-style * specifier has been seen. */ int gotSequential = 0; /* Non-zero means that a regular sequential * (non-XPG3) conversion specifier has been * seen. */ int useShort; /* Value to be printed is short (half word). */ char *end; /* Used to locate end of numerical fields. */ /* * This procedure is a bit nasty. The goal is to use sprintf to * do most of the dirty work. There are several problems: * 1. this procedure can't trust its arguments. * 2. we must be able to provide a large enough result area to hold * whatever's generated. This is hard to estimate. * 2. there's no way to move the arguments from argv to the call * to sprintf in a reasonable way. This is particularly nasty * because some of the arguments may be two-word values (doubles). * So, what happens here is to scan the format string one % group * at a time, making many individual calls to sprintf. */ if (argc < 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " formatString ?arg arg ...?\"", (char *) NULL); return TCL_ERROR; } argIndex = 2; for (format = argv[1]; *format != 0; ) { register char *newPtr = newFormat; width = precision = noPercent = useShort = 0; whichValue = PTR_VALUE; /* * Get rid of any characters before the next field specifier. */ if (*format != '%') { register char *p; ptrValue = p = format; while ((*format != '%') && (*format != 0)) { *p = *format; p++; format++; } size = p - ptrValue; noPercent = 1; goto doField; } if (format[1] == '%') { ptrValue = format; size = 1; noPercent = 1; format += 2; goto doField; } /* * Parse off a field specifier, compute how many characters * will be needed to store the result, and substitute for * "*" size specifiers. */ *newPtr = '%'; newPtr++; format++; if (isdigit(UCHAR(*format))) { int tmp; /* * Check for an XPG3-style %n$ specification. Note: there * must not be a mixture of XPG3 specs and non-XPG3 specs * in the same format string. */ tmp = strtoul(format, &end, 10); if (*end != '$') { goto notXpg; } format = end+1; gotXpg = 1; if (gotSequential) { goto mixedXPG; } argIndex = tmp+1; if ((argIndex < 2) || (argIndex >= argc)) { goto badIndex; } goto xpgCheckDone; } notXpg: gotSequential = 1; if (gotXpg) { goto mixedXPG; } xpgCheckDone: while ((*format == '-') || (*format == '#') || (*format == '0') || (*format == ' ') || (*format == '+')) { *newPtr = *format; newPtr++; format++; } if (isdigit(UCHAR(*format))) { width = strtoul(format, &end, 10); format = end; } else if (*format == '*') { if (argIndex >= argc) { goto badIndex; } if (Tcl_GetInt(interp, argv[argIndex], &width) != TCL_OK) { goto fmtError; } argIndex++; format++; } if (width != 0) { sprintf(newPtr, "%d", width); while (*newPtr != 0) { newPtr++; } } if (*format == '.') { *newPtr = '.'; newPtr++; format++; } if (isdigit(UCHAR(*format))) { precision = strtoul(format, &end, 10); format = end; } else if (*format == '*') { if (argIndex >= argc) { goto badIndex; } if (Tcl_GetInt(interp, argv[argIndex], &precision) != TCL_OK) { goto fmtError; } argIndex++; format++; } if (precision != 0) { sprintf(newPtr, "%d", precision); while (*newPtr != 0) { newPtr++; } } if (*format == 'l') { format++; } else if (*format == 'h') { useShort = 1; *newPtr = 'h'; newPtr++; format++; } *newPtr = *format; newPtr++; *newPtr = 0; if (argIndex >= argc) { goto badIndex; } switch (*format) { case 'i': newPtr[-1] = 'd'; case 'd': case 'o': case 'u': case 'x': case 'X': if (Tcl_GetInt(interp, argv[argIndex], (int *) &intValue) != TCL_OK) { goto fmtError; } whichValue = INT_VALUE; size = 40 + precision; break; case 's': ptrValue = argv[argIndex]; size = strlen(argv[argIndex]); break; case 'c': if (Tcl_GetInt(interp, argv[argIndex], (int *) &intValue) != TCL_OK) { goto fmtError; } whichValue = INT_VALUE; size = 1; break; case 'e': case 'E': case 'f': case 'g': case 'G': if (Tcl_GetDouble(interp, argv[argIndex], &doubleValue) != TCL_OK) { goto fmtError; } whichValue = DOUBLE_VALUE; size = 320; if (precision > 10) { size += precision; } break; case 0: interp->result = "format string ended in middle of field specifier"; goto fmtError; default: sprintf(interp->result, "bad field specifier \"%c\"", *format); goto fmtError; } argIndex++; format++; /* * Make sure that there's enough space to hold the formatted * result, then format it. */ doField: if (width > size) { size = width; } if ((dstSize + size) > dstSpace) { char *newDst; int newSpace; newSpace = 2*(dstSize + size); newDst = (char *) ckalloc((unsigned) newSpace+1); if (dstSize != 0) { memcpy((VOID *) newDst, (VOID *) dst, (size_t) dstSize); } if (dstSpace != TCL_RESULT_SIZE) { ckfree(dst); } dst = newDst; dstSpace = newSpace; } if (noPercent) { memcpy((VOID *) (dst+dstSize), (VOID *) ptrValue, (size_t) size); dstSize += size; dst[dstSize] = 0; } else { if (whichValue == DOUBLE_VALUE) { sprintf(dst+dstSize, newFormat, doubleValue); } else if (whichValue == INT_VALUE) { if (useShort) { sprintf(dst+dstSize, newFormat, (short) intValue); } else { sprintf(dst+dstSize, newFormat, intValue); } } else { sprintf(dst+dstSize, newFormat, ptrValue); } dstSize += strlen(dst+dstSize); } } interp->result = dst; if (dstSpace != TCL_RESULT_SIZE) { interp->freeProc = (Tcl_FreeProc *) free; } else { interp->freeProc = 0; } return TCL_OK; mixedXPG: interp->result = "cannot mix \"%\" and \"%n$\" conversion specifiers"; goto fmtError; badIndex: if (gotXpg) { interp->result = "\"%n$\" argument index out of range"; } else { interp->result = "not enough arguments for all format specifiers"; } fmtError: if (dstSpace != TCL_RESULT_SIZE) { ckfree(dst); } return TCL_ERROR; } /* ARGSUSED */ int Tcl_ForeachCmd(dummy, interp, argc, argv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { int listArgc, i, result; char **listArgv; if (argc != 4) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " varName list command\"", (char *) NULL); return TCL_ERROR; } /* * Break the listcl7.4b4/tclCmdIL.c010044400630510000012000001113150576471521700146410ustar00ousterstaff00002300000001/* * tclCmdIL.c -- * * This file contains the top-level command routines for most of * the Tcl built-in commands whose names begin with the letters * I through L. It contains only commands in the generic core * (i.e. those that don't depend much upon UNIX facilities). * * Copyright (c) 1987-1993 The Regents of the University of California. * Copyright (c) 1994-1995 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #ifndef lint static char sccsid[] = "@(#) tclCmdIL.c 1.110 95/06/05 17:00:14"; #endif #include "tclInt.h" #include "tclPort.h" #include "patchlevel.h" /* * The variables below are used to implement the "lsort" command. * Unfortunately, this use of static variables prevents "lsort" * from being thread-safe, but there's no alternative given the * current implementation of qsort. In a threaded environment * these variables should be made thread-local if possible, or else * "lsort" needs internal mutual exclusion. */ static Tcl_Interp *sortInterp = NULL; /* Interpreter for "lsort" command. * NULL means no lsort is active. */ static enum {ASCII, INTEGER, REAL, COMMAND} sortMode; /* Mode for sorting: compare as strings, * compare as numbers, or call * user-defined command for * comparison. */ static Tcl_DString sortCmd; /* Holds command if mode is COMMAND. * pre-initialized to hold base of * command. */ static int sortIncreasing; /* 0 means sort in decreasing order, * 1 means increasing order. */ static int sortCode; /* Anything other than TCL_OK means a * problem occurred while sorting; this * executing a comparison command, so * the sort was aborted. */ /* * Forward declarations for procedures defined in this file: */ static int SortCompareProc _ANSI_ARGS_((CONST VOID *first, CONST VOID *second)); /* *---------------------------------------------------------------------- * * Tcl_IfCmd -- * * This procedure is invoked to process the "if" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_IfCmd(dummy, interp, argc, argv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { int i, result, value; i = 1; while (1) { /* * At this point in the loop, argv and argc refer to an expression * to test, either for the main expression or an expression * following an "elseif". The arguments after the expression must * be "then" (optional) and a script to execute if the expression is * true. */ if (i >= argc) { Tcl_AppendResult(interp, "wrong # args: no expression after \"", argv[i-1], "\" argument", (char *) NULL); return TCL_ERROR; } result = Tcl_ExprBoolean(interp, argv[i], &value); if (result != TCL_OK) { return result; } i++; if ((i < argc) && (strcmp(argv[i], "then") == 0)) { i++; } if (i >= argc) { Tcl_AppendResult(interp, "wrong # args: no script following \"", argv[i-1], "\" argument", (char *) NULL); return TCL_ERROR; } if (value) { return Tcl_Eval(interp, argv[i]); } /* * The expression evaluated to false. Skip the command, then * see if there is an "else" or "elseif" clause. */ i++; if (i >= argc) { return TCL_OK; } if ((argv[i][0] == 'e') && (strcmp(argv[i], "elseif") == 0)) { i++; continue; } break; } /* * Couldn't find a "then" or "elseif" clause to execute. Check now * for an "else" clause. We know that there's at least one more * argument when we get here. */ if (strcmp(argv[i], "else") == 0) { i++; if (i >= argc) { Tcl_AppendResult(interp, "wrong # args: no script following \"else\" argument", (char *) NULL); return TCL_ERROR; } } return Tcl_Eval(interp, argv[i]); } /* *---------------------------------------------------------------------- * * Tcl_IncrCmd -- * * This procedure is invoked to process the "incr" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_IncrCmd(dummy, interp, argc, argv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { int value; char *oldString, *result; char newString[30]; if ((argc != 2) && (argc != 3)) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " varName ?increment?\"", (char *) NULL); return TCL_ERROR; } oldString = Tcl_GetVar(interp, argv[1], TCL_LEAVE_ERR_MSG); if (oldString == NULL) { return TCL_ERROR; } if (Tcl_GetInt(interp, oldString, &value) != TCL_OK) { Tcl_AddErrorInfo(interp, "\n (reading value of variable to increment)"); return TCL_ERROR; } if (argc == 2) { value += 1; } else { int increment; if (Tcl_GetInt(interp, argv[2], &increment) != TCL_OK) { Tcl_AddErrorInfo(interp, "\n (reading increment)"); return TCL_ERROR; } value += increment; } sprintf(newString, "%d", value); result = Tcl_SetVar(interp, argv[1], newString, TCL_LEAVE_ERR_MSG); if (result == NULL) { return TCL_ERROR; } interp->result = result; return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_InfoCmd -- * * This procedure is invoked to process the "info" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_InfoCmd(dummy, interp, argc, argv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { register Interp *iPtr = (Interp *) interp; size_t length; int c; Arg *argPtr; Proc *procPtr; Var *varPtr; Command *cmdPtr; Tcl_HashEntry *hPtr; Tcl_HashSearch search; if (argc < 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " option ?arg arg ...?\"", (char *) NULL); return TCL_ERROR; } c = argv[1][0]; length = strlen(argv[1]); if ((c == 'a') && (strncmp(argv[1], "args", length)) == 0) { if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " args procname\"", (char *) NULL); return TCL_ERROR; } procPtr = TclFindProc(iPtr, argv[2]); if (procPtr == NULL) { infoNoSuchProc: Tcl_AppendResult(interp, "\"", argv[2], "\" isn't a procedure", (char *) NULL); return TCL_ERROR; } for (argPtr = procPtr->argPtr; argPtr != NULL; argPtr = argPtr->nextPtr) { Tcl_AppendElement(interp, argPtr->name); } return TCL_OK; } else if ((c == 'b') && (strncmp(argv[1], "body", length)) == 0) { if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " body procname\"", (char *) NULL); return TCL_ERROR; } procPtr = TclFindProc(iPtr, argv[2]); if (procPtr == NULL) { goto infoNoSuchProc; } iPtr->result = procPtr->command; return TCL_OK; } else if ((c == 'c') && (strncmp(argv[1], "cmdcount", length) == 0) && (length >= 2)) { if (argc != 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " cmdcount\"", (char *) NULL); return TCL_ERROR; } sprintf(iPtr->result, "%d", iPtr->cmdCount); return TCL_OK; } else if ((c == 'c') && (strncmp(argv[1], "commands", length) == 0) && (length >= 4)) { if (argc > 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " commands [pattern]\"", (char *) NULL); return TCL_ERROR; } for (hPtr = Tcl_FirstHashEntry(&iPtr->commandTable, &search); hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { char *name = Tcl_GetHashKey(&iPtr->commandTable, hPtr); if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) { continue; } Tcl_AppendElement(interp, name); } return TCL_OK; } else if ((c == 'c') && (strncmp(argv[1], "complete", length) == 0) && (length >= 4)) { if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " complete command\"", (char *) NULL); return TCL_ERROR; } if (Tcl_CommandComplete(argv[2])) { interp->result = "1"; } else { interp->result = "0"; } return TCL_OK; } else if ((c == 'd') && (strncmp(argv[1], "default", length)) == 0) { if (argc != 5) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " default procname arg varname\"", (char *) NULL); return TCL_ERROR; } procPtr = TclFindProc(iPtr, argv[2]); if (procPtr == NULL) { goto infoNoSuchProc; } for (argPtr = procPtr->argPtr; ; argPtr = argPtr->nextPtr) { if (argPtr == NULL) { Tcl_AppendResult(interp, "procedure \"", argv[2], "\" doesn't have an argument \"", argv[3], "\"", (char *) NULL); return TCL_ERROR; } if (strcmp(argv[3], argPtr->name) == 0) { if (argPtr->defValue != NULL) { if (Tcl_SetVar((Tcl_Interp *) iPtr, argv[4], argPtr->defValue, 0) == NULL) { defStoreError: Tcl_AppendResult(interp, "couldn't store default value in variable \"", argv[4], "\"", (char *) NULL); return TCL_ERROR; } iPtr->result = "1"; } else { if (Tcl_SetVar((Tcl_Interp *) iPtr, argv[4], "", 0) == NULL) { goto defStoreError; } iPtr->result = "0"; } return TCL_OK; } } } else if ((c == 'e') && (strncmp(argv[1], "exists", length) == 0)) { char *p; if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " exists varName\"", (char *) NULL); return TCL_ERROR; } p = Tcl_GetVar((Tcl_Interp *) iPtr, argv[2], 0); /* * The code below handles the special case where the name is for * an array: Tcl_GetVar will reject this since you can't read * an array variable without an index. */ if (p == NULL) { Tcl_HashEntry *hPtr; Var *varPtr; if (strchr(argv[2], '(') != NULL) { noVar: iPtr->result = "0"; return TCL_OK; } if (iPtr->varFramePtr == NULL) { hPtr = Tcl_FindHashEntry(&iPtr->globalTable, argv[2]); } else { hPtr = Tcl_FindHashEntry(&iPtr->varFramePtr->varTable, argv[2]); } if (hPtr == NULL) { goto noVar; } varPtr = (Var *) Tcl_GetHashValue(hPtr); if (varPtr->flags & VAR_UPVAR) { varPtr = varPtr->value.upvarPtr; } if (!(varPtr->flags & VAR_ARRAY)) { goto noVar; } } iPtr->result = "1"; return TCL_OK; } else if ((c == 'g') && (strncmp(argv[1], "globals", length) == 0)) { char *name; if (argc > 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " globals [pattern]\"", (char *) NULL); return TCL_ERROR; } for (hPtr = Tcl_FirstHashEntry(&iPtr->globalTable, &search); hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { varPtr = (Var *) Tcl_GetHashValue(hPtr); if (varPtr->flags & VAR_UNDEFINED) { continue; } name = Tcl_GetHashKey(&iPtr->globalTable, hPtr); if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) { continue; } Tcl_AppendElement(interp, name); } return TCL_OK; } else if ((c == 'l') && (strncmp(argv[1], "level", length) == 0) && (length >= 2)) { if (argc == 2) { if (iPtr->varFramePtr == NULL) { iPtr->result = "0"; } else { sprintf(iPtr->result, "%d", iPtr->varFramePtr->level); } return TCL_OK; } else if (argc == 3) { int level; CallFrame *framePtr; if (Tcl_GetInt(interp, argv[2], &level) != TCL_OK) { return TCL_ERROR; } if (level <= 0) { if (iPtr->varFramePtr == NULL) { levelError: Tcl_AppendResult(interp, "bad level \"", argv[2], "\"", (char *) NULL); return TCL_ERROR; } level += iPtr->varFramePtr->level; } for (framePtr = iPtr->varFramePtr; framePtr != NULL; framePtr = framePtr->callerVarPtr) { if (framePtr->level == level) { break; } } if (framePtr == NULL) { goto levelError; } iPtr->result = Tcl_Merge(framePtr->argc, framePtr->argv); iPtr->freeProc = (Tcl_FreeProc *) free; return TCL_OK; } Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " level [number]\"", (char *) NULL); return TCL_ERROR; } else if ((c == 'l') && (strncmp(argv[1], "library", length) == 0) && (length >= 2)) { if (argc != 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " library\"", (char *) NULL); return TCL_ERROR; } interp->result = Tcl_GetVar(interp, "tcl_library", TCL_GLOBAL_ONLY); if (interp->result == NULL) { interp->result = "no library has been specified for Tcl"; return TCL_ERROR; } return TCL_OK; } else if ((c == 'l') && (strncmp(argv[1], "locals", length) == 0) && (length >= 2)) { char *name; if (argc > 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " locals [pattern]\"", (char *) NULL); return TCL_ERROR; } if (iPtr->varFramePtr == NULL) { return TCL_OK; } for (hPtr = Tcl_FirstHashEntry(&iPtr->varFramePtr->varTable, &search); hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { varPtr = (Var *) Tcl_GetHashValue(hPtr); if (varPtr->flags & (VAR_UNDEFINED|VAR_UPVAR)) { continue; } name = Tcl_GetHashKey(&iPtr->varFramePtr->varTable, hPtr); if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) { continue; } Tcl_AppendElement(interp, name); } return TCL_OK; } else if ((c == 'p') && (strncmp(argv[1], "patchlevel", length) == 0) && (length >= 2)) { if (argc != 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " patchlevel\"", (char *) NULL); return TCL_ERROR; } interp->result = TCL_PATCH_LEVEL; return TCL_OK; } else if ((c == 'p') && (strncmp(argv[1], "procs", length) == 0) && (length >= 2)) { if (argc > 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " procs [pattern]\"", (char *) NULL); return TCL_ERROR; } for (hPtr = Tcl_FirstHashEntry(&iPtr->commandTable, &search); hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { char *name = Tcl_GetHashKey(&iPtr->commandTable, hPtr); cmdPtr = (Command *) Tcl_GetHashValue(hPtr); if (!TclIsProc(cmdPtr)) { continue; } if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) { continue; } Tcl_AppendElement(interp, name); } return TCL_OK; } else if ((c == 's') && (strncmp(argv[1], "script", length) == 0)) { if (argc != 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " script\"", (char *) NULL); return TCL_ERROR; } if (iPtr->scriptFile != NULL) { /* * Can't depend on iPtr->scriptFile to be non-volatile: * if this command is returned as the result of the script, * then iPtr->scriptFile will go away. */ Tcl_SetResult(interp, iPtr->scriptFile, TCL_VOLATILE); } return TCL_OK; } else if ((c == 't') && (strncmp(argv[1], "tclversion", length) == 0)) { if (argc != 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " tclversion\"", (char *) NULL); return TCL_ERROR; } /* * Note: TCL_VERSION below is expected to be set with a "-D" * switch in the Makefile. */ strcpy(iPtr->result, TCL_VERSION); return TCL_OK; } else if ((c == 'v') && (strncmp(argv[1], "vars", length)) == 0) { Tcl_HashTable *tablePtr; char *name; if (argc > 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " vars [pattern]\"", (char *) NULL); return TCL_ERROR; } if (iPtr->varFramePtr == NULL) { tablePtr = &iPtr->globalTable; } else { tablePtr = &iPtr->varFramePtr->varTable; } for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { varPtr = (Var *) Tcl_GetHashValue(hPtr); if (varPtr->flags & VAR_UNDEFINED) { continue; } name = Tcl_GetHashKey(tablePtr, hPtr); if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) { continue; } Tcl_AppendElement(interp, name); } return TCL_OK; } else { Tcl_AppendResult(interp, "bad option \"", argv[1], "\": should be args, body, cmdcount, commands, ", "complete, default, ", "exists, globals, level, library, locals, ", "patchlevel, procs, script, tclversion, or vars", (char *) NULL); return TCL_ERROR; } } /* *---------------------------------------------------------------------- * * Tcl_JoinCmd -- * * This procedure is invoked to process the "join" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_JoinCmd(dummy, interp, argc, argv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { char *joinString; char **listArgv; int listArgc, i; if (argc == 2) { joinString = " "; } else if (argc == 3) { joinString = argv[2]; } else { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " list ?joinString?\"", (char *) NULL); return TCL_ERROR; } if (Tcl_SplitList(interp, argv[1], &listArgc, &listArgv) != TCL_OK) { return TCL_ERROR; } for (i = 0; i < listArgc; i++) { if (i == 0) { Tcl_AppendResult(interp, listArgv[0], (char *) NULL); } else { Tcl_AppendResult(interp, joinString, listArgv[i], (char *) NULL); } } ckfree((char *) listArgv); return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_LindexCmd -- * * This procedure is invoked to process the "lindex" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_LindexCmd(dummy, interp, argc, argv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { char *p, *element, *next; int index, size, parenthesized, result, returnLast; if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " list index\"", (char *) NULL); return TCL_ERROR; } if ((*argv[2] == 'e') && (strncmp(argv[2], "end", strlen(argv[2])) == 0)) { returnLast = 1; index = INT_MAX; } else { returnLast = 0; if (Tcl_GetInt(interp, argv[2], &index) != TCL_OK) { return TCL_ERROR; } } if (index < 0) { return TCL_OK; } for (p = argv[1] ; index >= 0; index--) { result = TclFindElement(interp, p, &element, &next, &size, &parenthesized); if (result != TCL_OK) { return result; } if ((*next == 0) && returnLast) { break; } p = next; } if (size == 0) { return TCL_OK; } if (size >= TCL_RESULT_SIZE) { interp->result = (char *) ckalloc((unsigned) size+1); interp->freeProc = (Tcl_FreeProc *) free; } if (parenthesized) { memcpy((VOID *) interp->result, (VOID *) element, (size_t) size); interp->result[size] = 0; } else { TclCopyAndCollapse(size, element, interp->result); } return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_LinsertCmd -- * * This procedure is invoked to process the "linsert" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_LinsertCmd(dummy, interp, argc, argv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { char *p, *element, savedChar; int i, index, count, result, size; if (argc < 4) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " list index element ?element ...?\"", (char *) NULL); return TCL_ERROR; } if ((*argv[2] == 'e') && (strncmp(argv[2], "end", strlen(argv[2])) == 0)) { index = INT_MAX; } else if (Tcl_GetInt(interp, argv[2], &index) != TCL_OK) { return TCL_ERROR; } /* * Skip over the first "index" elements of the list, then add * all of those elements to the result. */ size = 0; element = argv[1]; for (count = 0, p = argv[1]; (count < index) && (*p != 0); count++) { result = TclFindElement(interp, p, &element, &p, &size, (int *) NULL); if (result != TCL_OK) { return result; } } if (*p == 0) { Tcl_AppendResult(interp, argv[1], (char *) NULL); } else { char *end; end = element+size; if (element != argv[1]) { while ((*end != 0) && !isspace(UCHAR(*end))) { end++; } } savedChar = *end; *end = 0; Tcl_AppendResult(interp, argv[1], (char *) NULL); *end = savedChar; } /* * Add the new list elements. */ for (i = 3; i < argc; i++) { Tcl_AppendElement(interp, argv[i]); } /* * Append the remainder of the original list. */ if (*p != 0) { Tcl_AppendResult(interp, " ", p, (char *) NULL); } return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_ListCmd -- * * This procedure is invoked to process the "list" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_ListCmd(dummy, interp, argc, argv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { if (argc >= 2) { interp->result = Tcl_Merge(argc-1, argv+1); interp->freeProc = (Tcl_FreeProc *) free; } return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_LlengthCmd -- * * This procedure is invoked to process the "llength" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_LlengthCmd(dummy, interp, argc, argv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { int count, result; char *element, *p; if (argc != 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " list\"", (char *) NULL); return TCL_ERROR; } for (count = 0, p = argv[1]; *p != 0 ; count++) { result = TclFindElement(interp, p, &element, &p, (int *) NULL, (int *) NULL); if (result != TCL_OK) { return result; } if (*element == 0) { break; } } sprintf(interp->result, "%d", count); return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_LrangeCmd -- * * This procedure is invoked to process the "lrange" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_LrangeCmd(notUsed, interp, argc, argv) ClientData notUsed; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { int first, last, result; char *begin, *end, c, *dummy, *next; int count, firstIsEnd; if (argc != 4) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " list first last\"", (char *) NULL); return TCL_ERROR; } if ((*argv[2] == 'e') && (strncmp(argv[2], "end", strlen(argv[2])) == 0)) { firstIsEnd = 1; first = INT_MAX; } else { firstIsEnd = 0; if (Tcl_GetInt(interp, argv[2], &first) != TCL_OK) { return TCL_ERROR; } } if (first < 0) { first = 0; } if ((*argv[3] == 'e') && (strncmp(argv[3], "end", strlen(argv[3])) == 0)) { last = INT_MAX; } else { if (Tcl_GetInt(interp, argv[3], &last) != TCL_OK) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "expected integer or \"end\" but got \"", argv[3], "\"", (char *) NULL); return TCL_ERROR; } } if ((first > last) && !firstIsEnd) { return TCL_OK; } /* * Extract a range of fields. */ for (count = 0, begin = argv[1]; count < first; begin = next, count++) { result = TclFindElement(interp, begin, &dummy, &next, (int *) NULL, (int *) NULL); if (result != TCL_OK) { return result; } if (*next == 0) { if (firstIsEnd) { first = count; } else { begin = next; } break; } } for (count = first, end = begin; (count <= last) && (*end != 0); count++) { result = TclFindElement(interp, end, &dummy, &end, (int *) NULL, (int *) NULL); if (result != TCL_OK) { return result; } } if (end == begin) { return TCL_OK; } /* * Chop off trailing spaces. */ while (isspace(UCHAR(end[-1]))) { end--; } c = *end; *end = 0; Tcl_SetResult(interp, begin, TCL_VOLATILE); *end = c; return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_LreplaceCmd -- * * This procedure is invoked to process the "lreplace" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_LreplaceCmd(notUsed, interp, argc, argv) ClientData notUsed; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { char *p1, *p2, *element, savedChar, *dummy, *next; int i, first, last, count, result, size, firstIsEnd; if (argc < 4) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " list first last ?element element ...?\"", (char *) NULL); return TCL_ERROR; } if ((*argv[2] == 'e') && (strncmp(argv[2], "end", strlen(argv[2])) == 0)) { firstIsEnd = 1; first = INT_MAX; } else { firstIsEnd = 0; if (Tcl_GetInt(interp, argv[2], &first) != TCL_OK) { return TCL_ERROR; } } if ((*argv[3] == 'e') && (strncmp(argv[3], "end", strlen(argv[3])) == 0)) { last = INT_MAX; } else { if (TclGetListIndex(interp, argv[3], &last) != TCL_OK) { return TCL_ERROR; } } if (first < 0) { first = 0; } if (last < 0) { last = 0; } /* * Skip over the elements of the list before "first". */ size = 0; element = argv[1]; for (count = 0, p1 = argv[1]; (count < first) && (*p1 != 0); count++) { result = TclFindElement(interp, p1, &element, &next, &size, (int *) NULL); if (result != TCL_OK) { return result; } if ((*next == 0) && firstIsEnd) { break; } p1 = next; } if (*p1 == 0) { Tcl_AppendResult(interp, "list doesn't contain element ", argv[2], (char *) NULL); return TCL_ERROR; } if (count > last) { Tcl_AppendResult(interp, "first index must not be greater than second", (char *) NULL); return TCL_ERROR; } /* * Skip over the elements of the list up through "last". */ for (p2 = p1 ; (count <= last) && (*p2 != 0); count++) { result = TclFindElement(interp, p2, &dummy, &p2, (int *) NULL, (int *) NULL); if (result != TCL_OK) { return result; } } /* * Add the elements before "first" to the result. Drop any terminating * white space, since a separator will be added below, if needed. */ while ((p1 != argv[1]) && (isspace(UCHAR(p1[-1])))) { p1--; } savedChar = *p1; *p1 = 0; Tcl_AppendResult(interp, argv[1], (char *) NULL); *p1 = savedChar; /* * Add the new list elements. */ for (i = 4; i < argc; i++) { Tcl_AppendElement(interp, argv[i]); } /* * Append the remainder of the original list. */ if (*p2 != 0) { if (*interp->result == 0) { Tcl_SetResult(interp, p2, TCL_VOLATILE); } else { Tcl_AppendResult(interp, " ", p2, (char *) NULL); } } return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_LsearchCmd -- * * This procedure is invoked to process the "lsearch" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_LsearchCmd(notUsed, interp, argc, argv) ClientData notUsed; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { #define EXACT 0 #define GLOB 1 #define REGEXP 2 int listArgc; char **listArgv; int i, match, mode, index; mode = GLOB; if (argc == 4) { if (strcmp(argv[1], "-exact") == 0) { mode = EXACT; } else if (strcmp(argv[1], "-glob") == 0) { mode = GLOB; } else if (strcmp(argv[1], "-regexp") == 0) { mode = REGEXP; } else { Tcl_AppendResult(interp, "bad search mode \"", argv[1], "\": must be -exact, -glob, or -regexp", (char *) NULL); return TCL_ERROR; } } else if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " ?mode? list pattern\"", (char *) NULL); return TCL_ERROR; } if (Tcl_SplitList(interp, argv[argc-2], &listArgc, &listArgv) != TCL_OK) { return TCL_ERROR; } index = -1; for (i = 0; i < listArgc; i++) { match = 0; switch (mode) { case EXACT: match = (strcmp(listArgv[i], argv[argc-1]) == 0); break; case GLOB: match = Tcl_StringMatch(listArgv[i], argv[argc-1]); break; case REGEXP: match = Tcl_RegExpMatch(interp, listArgv[i], argv[argc-1]); if (match < 0) { ckfree((char *) listArgv); return TCL_ERROR; } break; } if (match) { index = i; break; } } sprintf(interp->result, "%d", index); ckfree((char *) listArgv); return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_LsortCmd -- * * This procedure is invoked to process the "lsort" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_LsortCmd(notUsed, interp, argc, argv) ClientData notUsed; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { int listArgc, i, c; size_t length; char **listArgv; char *command = NULL; /* Initialization needed only to * prevent compiler warning. */ if (argc < 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " ?-ascii? ?-integer? ?-real? ?-increasing? ?-decreasing?", " ?-command string? list\"", (char *) NULL); return TCL_ERROR; } if (sortInterp != NULL) { interp->result = "can't invoke \"lsort\" recursively"; return TCL_ERROR; } /* * Parse arguments to set up the mode for the sort. */ sortInterp = interp; sortMode = ASCII; sortIncreasing = 1; sortCode = TCL_OK; for (i = 1; i < argc-1; i++) { length = strlen(argv[i]); if (length < 2) { badSwitch: Tcl_AppendResult(interp, "bad switch \"", argv[i], "\": must be -ascii, -integer, -real, -increasing", " -decreasing, or -command", (char *) NULL); sortCode = TCL_ERROR; goto done; } c = argv[i][1]; if ((c == 'a') && (strncmp(argv[i], "-ascii", length) == 0)) { sortMode = ASCII; } else if ((c == 'c') && (strncmp(argv[i], "-command", length) == 0)) { if (i == argc-2) { Tcl_AppendResult(interp, "\"-command\" must be", " followed by comparison command", (char *) NULL); sortCode = TCL_ERROR; goto done; } sortMode = COMMAND; command = argv[i+1]; i++; } else if ((c == 'd') && (strncmp(argv[i], "-decreasing", length) == 0)) { sortIncreasing = 0; } else if ((c == 'i') && (length >= 4) && (strncmp(argv[i], "-increasing", length) == 0)) { sortIncreasing = 1; } else if ((c == 'i') && (length >= 4) && (strncmp(argv[i], "-integer", length) == 0)) { sortMode = INTEGER; } else if ((c == 'r') && (strncmp(argv[i], "-real", length) == 0)) { sortMode = REAL; } else { goto badSwitch; } } if (sortMode == COMMAND) { Tcl_DStringInit(&sortCmd); Tcl_DStringAppend(&sortCmd, command, -1); } if (Tcl_SplitList(interp, argv[argc-1], &listArgc, &listArgv) != TCL_OK) { sortCode = TCL_ERROR; goto done; } qsort((VOID *) listArgv, (size_t) listArgc, sizeof (char *), SortCompareProc); if (sortCode == TCL_OK) { Tcl_ResetResult(interp); interp->result = Tcl_Merge(listArgc, listArgv); interp->freeProc = (Tcl_FreeProc *) free; } if (sortMode == COMMAND) { Tcl_DStringFree(&sortCmd); } ckfree((char *) listArgv); done: sortInterp = NULL; return sortCode; } /* *---------------------------------------------------------------------- * * SortCompareProc -- * * This procedure is invoked by qsort to determine the proper * ordering between two elements. * * Results: * < 0 means first is "smaller" than "second", > 0 means "first" * is larger than "second", and 0 means they should be treated * as equal. * * Side effects: * None, unless a user-defined comparison command does something * weird. * *---------------------------------------------------------------------- */ static int SortCompareProc(first, second) CONST VOID *first, *second; /* Elements to be compared. */ { int order; char *firstString = *((char **) first); char *secondString = *((char **) second); order = 0; if (sortCode != TCL_OK) { /* * Once an error has occurred, skip any future comparisons * so as to preserve the error message in sortInterp->result. */ return order; } if (sortMode == ASCII) { order = strcmp(firstString, secondString); } else if (sortMode == INTEGER) { int a, b; if ((Tcl_GetInt(sortInterp, firstString, &a) != TCL_OK) || (Tcl_GetInt(sortInterp, secondString, &b) != TCL_OK)) { Tcl_AddErrorInfo(sortInterp, "\n (converting list element from string to integer)"); sortCode = TCL_ERROR; return order; } if (a > b) { order = 1; } else if (b > a) { order = -1; } } else if (sortMode == REAL) { double a, b; if ((Tcl_GetDouble(sortInterp, firstString, &a) != TCL_OK) || (Tcl_GetDouble(sortInterp, secondString, &b) != TCL_OK)) { Tcl_AddErrorInfo(sortInterp, "\n (converting list element from string to real)"); sortCode = TCL_ERROR; return order; } if (a > b) { order = 1; } else if (b > a) { order = -1; } } else { int oldLength; char *end; /* * Generate and evaluate a command to determine which string comes * first. */ oldLength = Tcl_DStringLength(&sortCmd); Tcl_DStringAppendElement(&sortCmd, firstString); Tcl_DStringAppendElement(&sortCmd, secondString); sortCode = Tcl_Eval(sortInterp, Tcl_DStringValue(&sortCmd)); Tcl_DStringTrunc(&sortCmd, oldLength); if (sortCode != TCL_OK) { Tcl_AddErrorInfo(sortInterp, "\n (user-defined comparison command)"); return order; } /* * Parse the result of the command. */ order = strtol(sortInterp->result, &end, 0); if ((end == sortInterp->result) || (*end != 0)) { Tcl_ResetResult(sortInterp); Tcl_AppendResult(sortInterp, "comparison command returned non-numeric result", (char *) NULL); sortCode = TCL_ERROR; return order; } } if (!sortIncreasing) { order = -order; } return order; } avedChar, *dummy, *next; int i, first, last, count, result, size, firstIsEnd; if (argc < 4) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " list first last ?element element ...?\"", (char *) NULL); return TCL_ERROR; } if ((*argv[2] == 'e') && (strncmp(argv[2], "end"tcl7.4b4/tclCmdMZ.c010044400630510000012000001353560575100122400146540ustar00ousterstaff00002300000001/* * tclCmdMZ.c -- * * This file contains the top-level command routines for most of * the Tcl built-in commands whose names begin with the letters * M to Z. It contains only commands in the generic core (i.e. * those that don't depend much upon UNIX facilities). * * Copyright (c) 1987-1993 The Regents of the University of California. * Copyright (c) 1994-1995 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #ifndef lint static char sccsid[] = "@(#) tclCmdMZ.c 1.57 95/04/30 14:35:17"; #endif #include "tclInt.h" #include "tclPort.h" /* * Structure used to hold information about variable traces: */ typedef struct { int flags; /* Operations for which Tcl command is * to be invoked. */ char *errMsg; /* Error message returned from Tcl command, * or NULL. Malloc'ed. */ int length; /* Number of non-NULL chars. in command. */ char command[4]; /* Space for Tcl command to invoke. Actual * size will be as large as necessary to * hold command. This field must be the * last in the structure, so that it can * be larger than 4 bytes. */ } TraceVarInfo; /* * Forward declarations for procedures defined in this file: */ static char * TraceVarProc _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, char *name1, char *name2, int flags)); /* *---------------------------------------------------------------------- * * Tcl_RegexpCmd -- * * This procedure is invoked to process the "regexp" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_RegexpCmd(dummy, interp, argc, argv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { int noCase = 0; int indices = 0; Tcl_RegExp regExpr; char **argPtr, *string, *pattern, *start, *end; int match = 0; /* Initialization needed only to * prevent compiler warning. */ int i; Tcl_DString stringDString, patternDString; if (argc < 3) { wrongNumArgs: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " ?switches? exp string ?matchVar? ?subMatchVar ", "subMatchVar ...?\"", (char *) NULL); return TCL_ERROR; } argPtr = argv+1; argc--; while ((argc > 0) && (argPtr[0][0] == '-')) { if (strcmp(argPtr[0], "-indices") == 0) { indices = 1; } else if (strcmp(argPtr[0], "-nocase") == 0) { noCase = 1; } else if (strcmp(argPtr[0], "--") == 0) { argPtr++; argc--; break; } else { Tcl_AppendResult(interp, "bad switch \"", argPtr[0], "\": must be -indices, -nocase, or --", (char *) NULL); return TCL_ERROR; } argPtr++; argc--; } if (argc < 2) { goto wrongNumArgs; } /* * Convert the string and pattern to lower case, if desired, and * perform the matching operation. */ if (noCase) { register char *p; Tcl_DStringInit(&patternDString); Tcl_DStringAppend(&patternDString, argPtr[0], -1); pattern = Tcl_DStringValue(&patternDString); for (p = pattern; *p != 0; p++) { if (isupper(UCHAR(*p))) { *p = tolower(*p); } } Tcl_DStringInit(&stringDString); Tcl_DStringAppend(&stringDString, argPtr[1], -1); string = Tcl_DStringValue(&stringDString); for (p = string; *p != 0; p++) { if (isupper(UCHAR(*p))) { *p = tolower(*p); } } } else { pattern = argPtr[0]; string = argPtr[1]; } regExpr = Tcl_RegExpCompile(interp, pattern); if (regExpr != NULL) { match = Tcl_RegExpExec(interp, regExpr, string, string); } if (noCase) { Tcl_DStringFree(&stringDString); Tcl_DStringFree(&patternDString); } if (regExpr == NULL) { return TCL_ERROR; } if (match < 0) { return TCL_ERROR; } if (!match) { interp->result = "0"; return TCL_OK; } /* * If additional variable names have been specified, return * index information in those variables. */ argc -= 2; for (i = 0; i < argc; i++) { char *result, info[50]; Tcl_RegExpRange(regExpr, i, &start, &end); if (start == NULL) { if (indices) { result = Tcl_SetVar(interp, argPtr[i+2], "-1 -1", 0); } else { result = Tcl_SetVar(interp, argPtr[i+2], "", 0); } } else { if (indices) { sprintf(info, "%d %d", start - string, end - string - 1); result = Tcl_SetVar(interp, argPtr[i+2], info, 0); } else { char savedChar, *first, *last; first = argPtr[1] + (start - string); last = argPtr[1] + (end - string); savedChar = *last; *last = 0; result = Tcl_SetVar(interp, argPtr[i+2], first, 0); *last = savedChar; } } if (result == NULL) { Tcl_AppendResult(interp, "couldn't set variable \"", argPtr[i+2], "\"", (char *) NULL); return TCL_ERROR; } } interp->result = "1"; return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_RegsubCmd -- * * This procedure is invoked to process the "regsub" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_RegsubCmd(dummy, interp, argc, argv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { int noCase = 0, all = 0; Tcl_RegExp regExpr; char *string, *pattern, *p, *firstChar, *newValue, **argPtr; int match, flags, code, numMatches; char *start, *end, *subStart, *subEnd; register char *src, c; Tcl_DString stringDString, patternDString; if (argc < 5) { wrongNumArgs: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " ?switches? exp string subSpec varName\"", (char *) NULL); return TCL_ERROR; } argPtr = argv+1; argc--; while (argPtr[0][0] == '-') { if (strcmp(argPtr[0], "-nocase") == 0) { noCase = 1; } else if (strcmp(argPtr[0], "-all") == 0) { all = 1; } else if (strcmp(argPtr[0], "--") == 0) { argPtr++; argc--; break; } else { Tcl_AppendResult(interp, "bad switch \"", argPtr[0], "\": must be -all, -nocase, or --", (char *) NULL); return TCL_ERROR; } argPtr++; argc--; } if (argc != 4) { goto wrongNumArgs; } /* * Convert the string and pattern to lower case, if desired. */ if (noCase) { Tcl_DStringInit(&patternDString); Tcl_DStringAppend(&patternDString, argPtr[0], -1); pattern = Tcl_DStringValue(&patternDString); for (p = pattern; *p != 0; p++) { if (isupper(UCHAR(*p))) { *p = tolower(*p); } } Tcl_DStringInit(&stringDString); Tcl_DStringAppend(&stringDString, argPtr[1], -1); string = Tcl_DStringValue(&stringDString); for (p = string; *p != 0; p++) { if (isupper(UCHAR(*p))) { *p = tolower(*p); } } } else { pattern = argPtr[0]; string = argPtr[1]; } regExpr = Tcl_RegExpCompile(interp, pattern); if (regExpr == NULL) { code = TCL_ERROR; goto done; } /* * The following loop is to handle multiple matches within the * same source string; each iteration handles one match and its * corresponding substitution. If "-all" hasn't been specified * then the loop body only gets executed once. */ flags = 0; numMatches = 0; for (p = string; *p != 0; ) { match = Tcl_RegExpExec(interp, regExpr, p, string); if (match < 0) { code = TCL_ERROR; goto done; } if (!match) { break; } numMatches += 1; /* * Copy the portion of the source string before the match to the * result variable. */ Tcl_RegExpRange(regExpr, 0, &start, &end); src = argPtr[1] + (start - string); c = *src; *src = 0; newValue = Tcl_SetVar(interp, argPtr[3], argPtr[1] + (p - string), flags); *src = c; flags = TCL_APPEND_VALUE; if (newValue == NULL) { cantSet: Tcl_AppendResult(interp, "couldn't set variable \"", argPtr[3], "\"", (char *) NULL); code = TCL_ERROR; goto done; } /* * Append the subSpec argument to the variable, making appropriate * substitutions. This code is a bit hairy because of the backslash * conventions and because the code saves up ranges of characters in * subSpec to reduce the number of calls to Tcl_SetVar. */ for (src = firstChar = argPtr[2], c = *src; c != 0; src++, c = *src) { int index; if (c == '&') { index = 0; } else if (c == '\\') { c = src[1]; if ((c >= '0') && (c <= '9')) { index = c - '0'; } else if ((c == '\\') || (c == '&')) { *src = c; src[1] = 0; newValue = Tcl_SetVar(interp, argPtr[3], firstChar, TCL_APPEND_VALUE); *src = '\\'; src[1] = c; if (newValue == NULL) { goto cantSet; } firstChar = src+2; src++; continue; } else { continue; } } else { continue; } if (firstChar != src) { c = *src; *src = 0; newValue = Tcl_SetVar(interp, argPtr[3], firstChar, TCL_APPEND_VALUE); *src = c; if (newValue == NULL) { goto cantSet; } } Tcl_RegExpRange(regExpr, index, &subStart, &subEnd); if ((subStart != NULL) && (subEnd != NULL)) { char *first, *last, saved; first = argPtr[1] + (subStart - string); last = argPtr[1] + (subEnd - string); saved = *last; *last = 0; newValue = Tcl_SetVar(interp, argPtr[3], first, TCL_APPEND_VALUE); *last = saved; if (newValue == NULL) { goto cantSet; } } if (*src == '\\') { src++; } firstChar = src+1; } if (firstChar != src) { if (Tcl_SetVar(interp, argPtr[3], firstChar, TCL_APPEND_VALUE) == NULL) { goto cantSet; } } if (end == p) { char tmp[2]; /* * Always consume at least one character of the input string * in order to prevent infinite loops. */ tmp[0] = argPtr[1][p - string]; tmp[1] = 0; newValue = Tcl_SetVar(interp, argPtr[3], tmp, flags); if (newValue == NULL) { goto cantSet; } p = end + 1; } else { p = end; } if (!all) { break; } } /* * Copy the portion of the source string after the last match to the * result variable. */ if ((*p != 0) || (numMatches == 0)) { if (Tcl_SetVar(interp, argPtr[3], argPtr[1] + (p - string), flags) == NULL) { goto cantSet; } } sprintf(interp->result, "%d", numMatches); code = TCL_OK; done: if (noCase) { Tcl_DStringFree(&stringDString); Tcl_DStringFree(&patternDString); } return code; } /* *---------------------------------------------------------------------- * * Tcl_RenameCmd -- * * This procedure is invoked to process the "rename" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_RenameCmd(dummy, interp, argc, argv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { register Command *cmdPtr; Interp *iPtr = (Interp *) interp; Tcl_HashEntry *hPtr; int new; if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " oldName newName\"", (char *) NULL); return TCL_ERROR; } if (argv[2][0] == '\0') { if (Tcl_DeleteCommand(interp, argv[1]) != 0) { Tcl_AppendResult(interp, "can't delete \"", argv[1], "\": command doesn't exist", (char *) NULL); return TCL_ERROR; } return TCL_OK; } hPtr = Tcl_FindHashEntry(&iPtr->commandTable, argv[2]); if (hPtr != NULL) { Tcl_AppendResult(interp, "can't rename to \"", argv[2], "\": command already exists", (char *) NULL); return TCL_ERROR; } hPtr = Tcl_FindHashEntry(&iPtr->commandTable, argv[1]); if (hPtr == NULL) { Tcl_AppendResult(interp, "can't rename \"", argv[1], "\": command doesn't exist", (char *) NULL); return TCL_ERROR; } cmdPtr = (Command *) Tcl_GetHashValue(hPtr); Tcl_DeleteHashEntry(hPtr); hPtr = Tcl_CreateHashEntry(&iPtr->commandTable, argv[2], &new); Tcl_SetHashValue(hPtr, cmdPtr); cmdPtr->hPtr = hPtr; return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_ReturnCmd -- * * This procedure is invoked to process the "return" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_ReturnCmd(dummy, interp, argc, argv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { Interp *iPtr = (Interp *) interp; int c, code; if (iPtr->errorInfo != NULL) { ckfree(iPtr->errorInfo); iPtr->errorInfo = NULL; } if (iPtr->errorCode != NULL) { ckfree(iPtr->errorCode); iPtr->errorCode = NULL; } code = TCL_OK; for (argv++, argc--; argc > 1; argv += 2, argc -= 2) { if (strcmp(argv[0], "-code") == 0) { c = argv[1][0]; if ((c == 'o') && (strcmp(argv[1], "ok") == 0)) { code = TCL_OK; } else if ((c == 'e') && (strcmp(argv[1], "error") == 0)) { code = TCL_ERROR; } else if ((c == 'r') && (strcmp(argv[1], "return") == 0)) { code = TCL_RETURN; } else if ((c == 'b') && (strcmp(argv[1], "break") == 0)) { code = TCL_BREAK; } else if ((c == 'c') && (strcmp(argv[1], "continue") == 0)) { code = TCL_CONTINUE; } else if (Tcl_GetInt(interp, argv[1], &code) != TCL_OK) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "bad completion code \"", argv[1], "\": must be ok, error, return, break, ", "continue, or an integer", (char *) NULL); return TCL_ERROR; } } else if (strcmp(argv[0], "-errorinfo") == 0) { iPtr->errorInfo = ckalloc((unsigned) (strlen(argv[1]) + 1)); strcpy(iPtr->errorInfo, argv[1]); } else if (strcmp(argv[0], "-errorcode") == 0) { iPtr->errorCode = ckalloc((unsigned) (strlen(argv[1]) + 1)); strcpy(iPtr->errorCode, argv[1]); } else { Tcl_AppendResult(interp, "bad option \"", argv[0], ": must be -code, -errorcode, or -errorinfo", (char *) NULL); return TCL_ERROR; } } if (argc == 1) { Tcl_SetResult(interp, argv[0], TCL_VOLATILE); } iPtr->returnCode = code; return TCL_RETURN; } /* *---------------------------------------------------------------------- * * Tcl_ScanCmd -- * * This procedure is invoked to process the "scan" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_ScanCmd(dummy, interp, argc, argv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { # define MAX_FIELDS 20 typedef struct { char fmt; /* Format for field. */ int size; /* How many bytes to allow for * field. */ char *location; /* Where field will be stored. */ } Field; Field fields[MAX_FIELDS]; /* Info about all the fields in the * format string. */ register Field *curField; int numFields = 0; /* Number of fields actually * specified. */ int suppress; /* Current field is assignment- * suppressed. */ int totalSize = 0; /* Number of bytes needed to store * all results combined. */ char *results; /* Where scanned output goes. * Malloced; NULL means not allocated * yet. */ int numScanned; /* sscanf's result. */ register char *fmt; int i, widthSpecified, length, code; /* * The variables below are used to hold a copy of the format * string, so that we can replace format specifiers like "%f" * and "%F" with specifiers like "%lf" */ # define STATIC_SIZE 5 char copyBuf[STATIC_SIZE], *fmtCopy; register char *dst; if (argc < 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " string format ?varName varName ...?\"", (char *) NULL); return TCL_ERROR; } /* * This procedure operates in four stages: * 1. Scan the format string, collecting information about each field. * 2. Allocate an array to hold all of the scanned fields. * 3. Call sscanf to do all the dirty work, and have it store the * parsed fields in the array. * 4. Pick off the fields from the array and assign them to variables. */ code = TCL_OK; results = NULL; length = strlen(argv[2]) * 2 + 1; if (length < STATIC_SIZE) { fmtCopy = copyBuf; } else { fmtCopy = ckalloc((unsigned) length); } dst = fmtCopy; for (fmt = argv[2]; *fmt != 0; fmt++) { *dst = *fmt; dst++; if (*fmt != '%') { continue; } fmt++; if (*fmt == '%') { *dst = *fmt; dst++; continue; } if (*fmt == '*') { suppress = 1; *dst = *fmt; dst++; fmt++; } else { suppress = 0; } widthSpecified = 0; while (isdigit(UCHAR(*fmt))) { widthSpecified = 1; *dst = *fmt; dst++; fmt++; } if ((*fmt == 'l') || (*fmt == 'h') || (*fmt == 'L')) { fmt++; } *dst = *fmt; dst++; if (suppress) { continue; } if (numFields == MAX_FIELDS) { interp->result = "too many fields to scan"; code = TCL_ERROR; goto done; } curField = &fields[numFields]; numFields++; switch (*fmt) { case 'd': case 'i': case 'o': case 'x': curField->fmt = 'd'; curField->size = sizeof(int); break; case 'u': curField->fmt = 'u'; curField->size = sizeof(int); break; case 's': curField->fmt = 's'; curField->size = strlen(argv[1]) + 1; break; case 'c': if (widthSpecified) { interp->result = "field width may not be specified in %c conversion"; code = TCL_ERROR; goto done; } curField->fmt = 'c'; curField->size = sizeof(int); break; case 'e': case 'f': case 'g': dst[-1] = 'l'; dst[0] = 'f'; dst++; curField->fmt = 'f'; curField->size = sizeof(double); break; case '[': curField->fmt = 's'; curField->size = strlen(argv[1]) + 1; do { fmt++; if (*fmt == 0) { interp->result = "unmatched [ in format string"; code = TCL_ERROR; goto done; } *dst = *fmt; dst++; } while (*fmt != ']'); break; default: sprintf(interp->result, "bad scan conversion character \"%c\"", *fmt); code = TCL_ERROR; goto done; } curField->size = TCL_ALIGN(curField->size); totalSize += curField->size; } *dst = 0; if (numFields != (argc-3)) { interp->result = "different numbers of variable names and field specifiers"; code = TCL_ERROR; goto done; } /* * Step 2: */ results = (char *) ckalloc((unsigned) totalSize); for (i = 0, totalSize = 0, curField = fields; i < numFields; i++, curField++) { curField->location = results + totalSize; totalSize += curField->size; } /* * Fill in the remaining fields with NULL; the only purpose of * this is to keep some memory analyzers, like Purify, from * complaining. */ for ( ; i < MAX_FIELDS; i++, curField++) { curField->location = NULL; } /* * Step 3: */ numScanned = sscanf(argv[1], fmtCopy, fields[0].location, fields[1].location, fields[2].location, fields[3].location, fields[4].location, fields[5].location, fields[6].location, fields[7].location, fields[8].location, fields[9].location, fields[10].location, fields[11].location, fields[12].location, fields[13].location, fields[14].location, fields[15].location, fields[16].location, fields[17].location, fields[18].location, fields[19].location); /* * Step 4: */ if (numScanned < numFields) { numFields = numScanned; } for (i = 0, curField = fields; i < numFields; i++, curField++) { switch (curField->fmt) { char string[TCL_DOUBLE_SPACE]; case 'd': sprintf(string, "%d", *((int *) curField->location)); if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) { storeError: Tcl_AppendResult(interp, "couldn't set variable \"", argv[i+3], "\"", (char *) NULL); code = TCL_ERROR; goto done; } break; case 'u': sprintf(string, "%u", *((int *) curField->location)); if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) { goto storeError; } break; case 'c': sprintf(string, "%d", *((char *) curField->location) & 0xff); if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) { goto storeError; } break; case 's': if (Tcl_SetVar(interp, argv[i+3], curField->location, 0) == NULL) { goto storeError; } break; case 'f': Tcl_PrintDouble(interp, *((double *) curField->location), string); if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) { goto storeError; } break; } } sprintf(interp->result, "%d", numScanned); done: if (results != NULL) { ckfree(results); } if (fmtCopy != copyBuf) { ckfree(fmtCopy); } return code; } /* *---------------------------------------------------------------------- * * Tcl_SplitCmd -- * * This procedure is invoked to process the "split" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_SplitCmd(dummy, interp, argc, argv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { char *splitChars; register char *p, *p2; char *elementStart; if (argc == 2) { splitChars = " \n\t\r"; } else if (argc == 3) { splitChars = argv[2]; } else { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " string ?splitChars?\"", (char *) NULL); return TCL_ERROR; } /* * Handle the special case of splitting on every character. */ if (*splitChars == 0) { char string[2]; string[1] = 0; for (p = argv[1]; *p != 0; p++) { string[0] = *p; Tcl_AppendElement(interp, string); } return TCL_OK; } /* * Normal case: split on any of a given set of characters. * Discard instances of the split characters. */ for (p = elementStart = argv[1]; *p != 0; p++) { char c = *p; for (p2 = splitChars; *p2 != 0; p2++) { if (*p2 == c) { *p = 0; Tcl_AppendElement(interp, elementStart); *p = c; elementStart = p+1; break; } } } if (p != argv[1]) { Tcl_AppendElement(interp, elementStart); } return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_StringCmd -- * * This procedure is invoked to process the "string" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_StringCmd(dummy, interp, argc, argv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { size_t length; register char *p; int match, c, first; int left = 0, right = 0; if (argc < 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " option arg ?arg ...?\"", (char *) NULL); return TCL_ERROR; } c = argv[1][0]; length = strlen(argv[1]); if ((c == 'c') && (strncmp(argv[1], "compare", length) == 0)) { if (argc != 4) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " compare string1 string2\"", (char *) NULL); return TCL_ERROR; } match = strcmp(argv[2], argv[3]); if (match > 0) { interp->result = "1"; } else if (match < 0) { interp->result = "-1"; } else { interp->result = "0"; } return TCL_OK; } else if ((c == 'f') && (strncmp(argv[1], "first", length) == 0)) { if (argc != 4) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " first string1 string2\"", (char *) NULL); return TCL_ERROR; } first = 1; firstLast: match = -1; c = *argv[2]; length = strlen(argv[2]); for (p = argv[3]; *p != 0; p++) { if (*p != c) { continue; } if (strncmp(argv[2], p, length) == 0) { match = p-argv[3]; if (first) { break; } } } sprintf(interp->result, "%d", match); return TCL_OK; } else if ((c == 'i') && (strncmp(argv[1], "index", length) == 0)) { int index; if (argc != 4) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " index string charIndex\"", (char *) NULL); return TCL_ERROR; } if (Tcl_GetInt(interp, argv[3], &index) != TCL_OK) { return TCL_ERROR; } if ((index >= 0) && (index < (int) strlen(argv[2]))) { interp->result[0] = argv[2][index]; interp->result[1] = 0; } return TCL_OK; } else if ((c == 'l') && (strncmp(argv[1], "last", length) == 0) && (length >= 2)) { if (argc != 4) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " last string1 string2\"", (char *) NULL); return TCL_ERROR; } first = 0; goto firstLast; } else if ((c == 'l') && (strncmp(argv[1], "length", length) == 0) && (length >= 2)) { if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " length string\"", (char *) NULL); return TCL_ERROR; } sprintf(interp->result, "%d", strlen(argv[2])); return TCL_OK; } else if ((c == 'm') && (strncmp(argv[1], "match", length) == 0)) { if (argc != 4) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " match pattern string\"", (char *) NULL); return TCL_ERROR; } if (Tcl_StringMatch(argv[3], argv[2]) != 0) { interp->result = "1"; } else { interp->result = "0"; } return TCL_OK; } else if ((c == 'r') && (strncmp(argv[1], "range", length) == 0)) { int first, last, stringLength; if (argc != 5) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " range string first last\"", (char *) NULL); return TCL_ERROR; } stringLength = strlen(argv[2]); if (Tcl_GetInt(interp, argv[3], &first) != TCL_OK) { return TCL_ERROR; } if ((*argv[4] == 'e') && (strncmp(argv[4], "end", strlen(argv[4])) == 0)) { last = stringLength-1; } else { if (Tcl_GetInt(interp, argv[4], &last) != TCL_OK) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "expected integer or \"end\" but got \"", argv[4], "\"", (char *) NULL); return TCL_ERROR; } } if (first < 0) { first = 0; } if (last >= stringLength) { last = stringLength-1; } if (last >= first) { char saved, *p; p = argv[2] + last + 1; saved = *p; *p = 0; Tcl_SetResult(interp, argv[2] + first, TCL_VOLATILE); *p = saved; } return TCL_OK; } else if ((c == 't') && (strncmp(argv[1], "tolower", length) == 0) && (length >= 3)) { register char *p; if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " tolower string\"", (char *) NULL); return TCL_ERROR; } Tcl_SetResult(interp, argv[2], TCL_VOLATILE); for (p = interp->result; *p != 0; p++) { if (isupper(UCHAR(*p))) { *p = tolower(*p); } } return TCL_OK; } else if ((c == 't') && (strncmp(argv[1], "toupper", length) == 0) && (length >= 3)) { register char *p; if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " toupper string\"", (char *) NULL); return TCL_ERROR; } Tcl_SetResult(interp, argv[2], TCL_VOLATILE); for (p = interp->result; *p != 0; p++) { if (islower(UCHAR(*p))) { *p = toupper(*p); } } return TCL_OK; } else if ((c == 't') && (strncmp(argv[1], "trim", length) == 0) && (length == 4)) { char *trimChars; register char *p, *checkPtr; left = right = 1; trim: if (argc == 4) { trimChars = argv[3]; } else if (argc == 3) { trimChars = " \t\n\r"; } else { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " ", argv[1], " string ?chars?\"", (char *) NULL); return TCL_ERROR; } p = argv[2]; if (left) { for (c = *p; c != 0; p++, c = *p) { for (checkPtr = trimChars; *checkPtr != c; checkPtr++) { if (*checkPtr == 0) { goto doneLeft; } } } } doneLeft: Tcl_SetResult(interp, p, TCL_VOLATILE); if (right) { char *donePtr; p = interp->result + strlen(interp->result) - 1; donePtr = &interp->result[-1]; for (c = *p; p != donePtr; p--, c = *p) { for (checkPtr = trimChars; *checkPtr != c; checkPtr++) { if (*checkPtr == 0) { goto doneRight; } } } doneRight: p[1] = 0; } return TCL_OK; } else if ((c == 't') && (strncmp(argv[1], "trimleft", length) == 0) && (length > 4)) { left = 1; argv[1] = "trimleft"; goto trim; } else if ((c == 't') && (strncmp(argv[1], "trimright", length) == 0) && (length > 4)) { right = 1; argv[1] = "trimright"; goto trim; } else if ((c == 'w') && (strncmp(argv[1], "wordend", length) == 0) && (length > 4)) { int length, index, cur; char *string; if (argc != 4) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " ", argv[1], " string index\"", (char *) NULL); return TCL_ERROR; } string = argv[2]; if (Tcl_GetInt(interp, argv[3], &index) != TCL_OK) { return TCL_ERROR; } length = strlen(argv[2]); if (index < 0) { index = 0; } if (index >= length) { cur = length; goto wordendDone; } for (cur = index ; cur < length; cur++) { c = UCHAR(string[cur]); if (!isalnum(c) && (c != '_')) { break; } } if (cur == index) { cur = index+1; } wordendDone: sprintf(interp->result, "%d", cur); return TCL_OK; } else if ((c == 'w') && (strncmp(argv[1], "wordstart", length) == 0) && (length > 4)) { int length, index, cur; char *string; if (argc != 4) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " ", argv[1], " string index\"", (char *) NULL); return TCL_ERROR; } string = argv[2]; if (Tcl_GetInt(interp, argv[3], &index) != TCL_OK) { return TCL_ERROR; } length = strlen(argv[2]); if (index >= length) { index = length-1; } if (index <= 0) { cur = 0; goto wordstartDone; } for (cur = index ; cur >= 0; cur--) { c = UCHAR(string[cur]); if (!isalnum(c) && (c != '_')) { break; } } if (cur != index) { cur += 1; } wordstartDone: sprintf(interp->result, "%d", cur); return TCL_OK; } else { Tcl_AppendResult(interp, "bad option \"", argv[1], "\": should be compare, first, index, last, length, match, ", "range, tolower, toupper, trim, trimleft, trimright, ", "wordend, or wordstart", (char *) NULL); return TCL_ERROR; } } /* *---------------------------------------------------------------------- * * Tcl_SubstCmd -- * * This procedure is invoked to process the "subst" Tcl command. * See the user documentation for details on what it does. This * command is an almost direct copy of an implementation by * Andrew Payne. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_SubstCmd(dummy, interp, argc, argv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { Interp *iPtr = (Interp *) interp; Tcl_DString result; char *p, *old, *value; int code, count, doVars, doCmds, doBackslashes, i; size_t length; char c; /* * Parse command-line options. */ doVars = doCmds = doBackslashes = 1; for (i = 1; i < (argc-1); i++) { p = argv[i]; if (*p != '-') { break; } length = strlen(p); if (length < 4) { badSwitch: Tcl_AppendResult(interp, "bad switch \"", p, "\": must be -nobackslashes, -nocommands, ", "or -novariables", (char *) NULL); return TCL_ERROR; } if ((p[3] == 'b') && (strncmp(p, "-nobackslashes", length) == 0)) { doBackslashes = 0; } else if ((p[3] == 'c') && (strncmp(p, "-nocommands", length) == 0)) { doCmds = 0; } else if ((p[3] == 'v') && (strncmp(p, "-novariables", length) == 0)) { doVars = 0; } else { goto badSwitch; } } if (i != (argc-1)) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " ?-nobackslashes? ?-nocommands? ?-novariables? string\"", (char *) NULL); return TCL_ERROR; } /* * Scan through the string one character at a time, performing * command, variable, and backslash substitutions. */ Tcl_DStringInit(&result); old = p = argv[i]; while (*p != 0) { switch (*p) { case '\\': if (doBackslashes) { if (p != old) { Tcl_DStringAppend(&result, old, p-old); } c = Tcl_Backslash(p, &count); Tcl_DStringAppend(&result, &c, 1); p += count; old = p; } else { p++; } break; case '$': if (doVars) { if (p != old) { Tcl_DStringAppend(&result, old, p-old); } value = Tcl_ParseVar(interp, p, &p); if (value == NULL) { Tcl_DStringFree(&result); return TCL_ERROR; } Tcl_DStringAppend(&result, value, -1); old = p; } else { p++; } break; case '[': if (doCmds) { if (p != old) { Tcl_DStringAppend(&result, old, p-old); } iPtr->evalFlags = TCL_BRACKET_TERM; code = Tcl_Eval(interp, p+1); if (code == TCL_ERROR) { Tcl_DStringFree(&result); return code; } old = p = iPtr->termPtr+1; Tcl_DStringAppend(&result, iPtr->result, -1); Tcl_ResetResult(interp); } else { p++; } break; default: p++; break; } } if (p != old) { Tcl_DStringAppend(&result, old, p-old); } Tcl_DStringResult(interp, &result); return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_SwitchCmd -- * * This procedure is invoked to process the "switch" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_SwitchCmd(dummy, interp, argc, argv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { #define EXACT 0 #define GLOB 1 #define REGEXP 2 int i, code, mode, matched; int body; char *string; int switchArgc, splitArgs; char **switchArgv; switchArgc = argc-1; switchArgv = argv+1; mode = EXACT; while ((switchArgc > 0) && (*switchArgv[0] == '-')) { if (strcmp(*switchArgv, "-exact") == 0) { mode = EXACT; } else if (strcmp(*switchArgv, "-glob") == 0) { mode = GLOB; } else if (strcmp(*switchArgv, "-regexp") == 0) { mode = REGEXP; } else if (strcmp(*switchArgv, "--") == 0) { switchArgc--; switchArgv++; break; } else { Tcl_AppendResult(interp, "bad option \"", switchArgv[0], "\": should be -exact, -glob, -regexp, or --", (char *) NULL); return TCL_ERROR; } switchArgc--; switchArgv++; } if (switchArgc < 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " ?switches? string pattern body ... ?default body?\"", (char *) NULL); return TCL_ERROR; } string = *switchArgv; switchArgc--; switchArgv++; /* * If all of the pattern/command pairs are lumped into a single * argument, split them out again. */ splitArgs = 0; if (switchArgc == 1) { code = Tcl_SplitList(interp, switchArgv[0], &switchArgc, &switchArgv); if (code != TCL_OK) { return code; } splitArgs = 1; } for (i = 0; i < switchArgc; i += 2) { if (i == (switchArgc-1)) { interp->result = "extra switch pattern with no body"; code = TCL_ERROR; goto cleanup; } /* * See if the pattern matches the string. */ matched = 0; if ((*switchArgv[i] == 'd') && (i == switchArgc-2) && (strcmp(switchArgv[i], "default") == 0)) { matched = 1; } else { switch (mode) { case EXACT: matched = (strcmp(string, switchArgv[i]) == 0); break; case GLOB: matched = Tcl_StringMatch(string, switchArgv[i]); break; case REGEXP: matched = Tcl_RegExpMatch(interp, string, switchArgv[i]); if (matched < 0) { code = TCL_ERROR; goto cleanup; } break; } } if (!matched) { continue; } /* * We've got a match. Find a body to execute, skipping bodies * that are "-". */ for (body = i+1; ; body += 2) { if (body >= switchArgc) { Tcl_AppendResult(interp, "no body specified for pattern \"", switchArgv[i], "\"", (char *) NULL); code = TCL_ERROR; goto cleanup; } if ((switchArgv[body][0] != '-') || (switchArgv[body][1] != 0)) { break; } } code = Tcl_Eval(interp, switchArgv[body]); if (code == TCL_ERROR) { char msg[100]; sprintf(msg, "\n (\"%.50s\" arm line %d)", switchArgv[i], interp->errorLine); Tcl_AddErrorInfo(interp, msg); } goto cleanup; } /* * Nothing matched: return nothing. */ code = TCL_OK; cleanup: if (splitArgs) { ckfree((char *) switchArgv); } return code; } /* *---------------------------------------------------------------------- * * Tcl_TraceCmd -- * * This procedure is invoked to process the "trace" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_TraceCmd(dummy, interp, argc, argv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { int c; size_t length; if (argc < 2) { Tcl_AppendResult(interp, "too few args: should be \"", argv[0], " option [arg arg ...]\"", (char *) NULL); return TCL_ERROR; } c = argv[1][1]; length = strlen(argv[1]); if ((c == 'a') && (strncmp(argv[1], "variable", length) == 0) && (length >= 2)) { char *p; int flags, length; TraceVarInfo *tvarPtr; if (argc != 5) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " variable name ops command\"", (char *) NULL); return TCL_ERROR; } flags = 0; for (p = argv[3] ; *p != 0; p++) { if (*p == 'r') { flags |= TCL_TRACE_READS; } else if (*p == 'w') { flags |= TCL_TRACE_WRITES; } else if (*p == 'u') { flags |= TCL_TRACE_UNSETS; } else { goto badOps; } } if (flags == 0) { goto badOps; } length = strlen(argv[4]); tvarPtr = (TraceVarInfo *) ckalloc((unsigned) (sizeof(TraceVarInfo) - sizeof(tvarPtr->command) + length + 1)); tvarPtr->flags = flags; tvarPtr->errMsg = NULL; tvarPtr->length = length; flags |= TCL_TRACE_UNSETS; strcpy(tvarPtr->command, argv[4]); if (Tcl_TraceVar(interp, argv[2], flags, TraceVarProc, (ClientData) tvarPtr) != TCL_OK) { ckfree((char *) tvarPtr); return TCL_ERROR; } } else if ((c == 'd') && (strncmp(argv[1], "vdelete", length) && (length >= 2)) == 0) { char *p; int flags, length; TraceVarInfo *tvarPtr; ClientData clientData; if (argc != 5) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " vdelete name ops command\"", (char *) NULL); return TCL_ERROR; } flags = 0; for (p = argv[3] ; *p != 0; p++) { if (*p == 'r') { flags |= TCL_TRACE_READS; } else if (*p == 'w') { flags |= TCL_TRACE_WRITES; } else if (*p == 'u') { flags |= TCL_TRACE_UNSETS; } else { goto badOps; } } if (flags == 0) { goto badOps; } /* * Search through all of our traces on this variable to * see if there's one with the given command. If so, then * delete the first one that matches. */ length = strlen(argv[4]); clientData = 0; while ((clientData = Tcl_VarTraceInfo(interp, argv[2], 0, TraceVarProc, clientData)) != 0) { tvarPtr = (TraceVarInfo *) clientData; if ((tvarPtr->length == length) && (tvarPtr->flags == flags) && (strncmp(argv[4], tvarPtr->command, (size_t) length) == 0)) { Tcl_UntraceVar(interp, argv[2], flags | TCL_TRACE_UNSETS, TraceVarProc, clientData); if (tvarPtr->errMsg != NULL) { ckfree(tvarPtr->errMsg); } ckfree((char *) tvarPtr); break; } } } else if ((c == 'i') && (strncmp(argv[1], "vinfo", length) == 0) && (length >= 2)) { ClientData clientData; char ops[4], *p; char *prefix = "{"; if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " vinfo name\"", (char *) NULL); return TCL_ERROR; } clientData = 0; while ((clientData = Tcl_VarTraceInfo(interp, argv[2], 0, TraceVarProc, clientData)) != 0) { TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData; p = ops; if (tvarPtr->flags & TCL_TRACE_READS) { *p = 'r'; p++; } if (tvarPtr->flags & TCL_TRACE_WRITES) { *p = 'w'; p++; } if (tvarPtr->flags & TCL_TRACE_UNSETS) { *p = 'u'; p++; } *p = '\0'; Tcl_AppendResult(interp, prefix, (char *) NULL); Tcl_AppendElement(interp, ops); Tcl_AppendElement(interp, tvarPtr->command); Tcl_AppendResult(interp, "}", (char *) NULL); prefix = " {"; } } else { Tcl_AppendResult(interp, "bad option \"", argv[1], "\": should be variable, vdelete, or vinfo", (char *) NULL); return TCL_ERROR; } return TCL_OK; badOps: Tcl_AppendResult(interp, "bad operations \"", argv[3], "\": should be one or more of rwu", (char *) NULL); return TCL_ERROR; } /* *---------------------------------------------------------------------- * * TraceVarProc -- * * This procedure is called to handle variable accesses that have * been traced using the "trace" command. * * Results: * Normally returns NULL. If the trace command returns an error, * then this procedure returns an error string. * * Side effects: * Depends on the command associated with the trace. * *---------------------------------------------------------------------- */ /* ARGSUSED */ static char * TraceVarProc(clientData, interp, name1, name2, flags) ClientData clientData; /* Information about the variable trace. */ Tcl_Interp *interp; /* Interpreter containing variable. */ char *name1; /* Name of variable or array. */ char *name2; /* Name of element within array; NULL means * scalar variable is being referenced. */ int flags; /* OR-ed bits giving operation and other * information. */ { TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData; char *result; int code; Interp dummy; Tcl_DString cmd; result = NULL; if (tvarPtr->errMsg != NULL) { ckfree(tvarPtr->errMsg); tvarPtr->errMsg = NULL; } if ((tvarPtr->flags & flags) && !(flags & TCL_INTERP_DESTROYED)) { /* * Generate a command to execute by appending list elements * for the two variable names and the operation. The five * extra characters are for three space, the opcode character, * and the terminating null. */ if (name2 == NULL) { name2 = ""; } Tcl_DStringInit(&cmd); Tcl_DStringAppend(&cmd, tvarPtr->command, tvarPtr->length); Tcl_DStringAppendElement(&cmd, name1); Tcl_DStringAppendElement(&cmd, name2); if (flags & TCL_TRACE_READS) { Tcl_DStringAppend(&cmd, " r", 2); } else if (flags & TCL_TRACE_WRITES) { Tcl_DStringAppend(&cmd, " w", 2); } else if (flags & TCL_TRACE_UNSETS) { Tcl_DStringAppend(&cmd, " u", 2); } /* * Execute the command. Be careful to save and restore the * result from the interpreter used for the command. */ if (interp->freeProc == 0) { dummy.freeProc = (Tcl_FreeProc *) 0; dummy.result = ""; Tcl_SetResult((Tcl_Interp *) &dummy, interp->result, TCL_VOLATILE); } else { dummy.freeProc = interp->freeProc; dummy.result = interp->result; interp->freeProc = (Tcl_FreeProc *) 0; } code = Tcl_Eval(interp, Tcl_DStringValue(&cmd)); Tcl_DStringFree(&cmd); if (code != TCL_OK) { tvarPtr->errMsg = ckalloc((unsigned) (strlen(interp->result) + 1)); strcpy(tvarPtr->errMsg, interp->result); result = tvarPtr->errMsg; Tcl_ResetResult(interp); /* Must clear error state. */ } Tcl_SetResult(interp, dummy.result, (dummy.freeProc == 0) ? TCL_VOLATILE : dummy.freeProc); } if (flags & TCL_TRACE_DESTROYED) { result = NULL; if (tvarPtr->errMsg != NULL) { ckfree(tvarPtr->errMsg); } ckfree((char *) tvarPtr); } return result; } /* *---------------------------------------------------------------------- * * Tcl_WhileCmd -- * * This procedure is invoked to process the "while" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_WhileCmd(dummy, interp, argc, argv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { int result, value; if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " test command\"", (char *) NULL); return TCL_ERROR; } while (1) { result = Tcl_ExprBoolean(interp, argv[1], &value); if (result != TCL_OK) { return result; } if (!value) { break; } result = Tcl_Eval(interp, argv[2]); if ((result != TCL_OK) && (result != TCL_CONTINUE)) { if (result == TCL_ERROR) { char msg[60]; sprintf(msg, "\n (\"while\" body line %d)", interp->errorLine); Tcl_AddErrorInfo(interp, msg); } break; } } if (result == TCL_BREAK) { result = TCL_OK; } if (result == TCL_OK) { Tcl_ResetResult(interp); } return result; } leanup; } /* * See if the pattern matches the string. */ matched = 0; if ((*switchArgv[i] == 'd') && (i == switchArgc-2) && (strcmp(switchArgv[i], "default") == 0)) { matched = 1; } else { switch (mode) { case EXACT: matched = (strcmp(string, tcl7.4b4/tclExpr.c010044400630510000012000001545560575301346000146320ustar00ousterstaff00002300000001/* * tclExpr.c -- * * This file contains the code to evaluate expressions for * Tcl. * * This implementation of floating-point support was modelled * after an initial implementation by Bill Carpenter. * * Copyright (c) 1987-1994 The Regents of the University of California. * Copyright (c) 1994 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ static char sccsid[] = "@(#) tclExpr.c 1.83 95/05/06 17:41:17"; #include "tclInt.h" #ifdef NO_FLOAT_H # include "compat/float.h" #else # include #endif #ifndef TCL_NO_MATH #include #endif /* * The stuff below is a bit of a hack so that this file can be used * in environments that include no UNIX, i.e. no errno. Just define * errno here. */ #ifndef TCL_GENERIC_ONLY #include "tclPort.h" extern int errno; #else #define NO_ERRNO_H #endif #ifdef NO_ERRNO_H int errno; #define EDOM 33 #define ERANGE 34 #endif /* * The data structure below is used to describe an expression value, * which can be either an integer (the usual case), a double-precision * floating-point value, or a string. A given number has only one * value at a time. */ #define STATIC_STRING_SPACE 150 typedef struct { long intValue; /* Integer value, if any. */ double doubleValue; /* Floating-point value, if any. */ ParseValue pv; /* Used to hold a string value, if any. */ char staticSpace[STATIC_STRING_SPACE]; /* Storage for small strings; large ones * are malloc-ed. */ int type; /* Type of value: TYPE_INT, TYPE_DOUBLE, * or TYPE_STRING. */ } Value; /* * Valid values for type: */ #define TYPE_INT 0 #define TYPE_DOUBLE 1 #define TYPE_STRING 2 /* * The data structure below describes the state of parsing an expression. * It's passed among the routines in this module. */ typedef struct { char *originalExpr; /* The entire expression, as originally * passed to Tcl_ExprString et al. */ char *expr; /* Position to the next character to be * scanned from the expression string. */ int token; /* Type of the last token to be parsed from * expr. See below for definitions. * Corresponds to the characters just * before expr. */ } ExprInfo; /* * The token types are defined below. In addition, there is a table * associating a precedence with each operator. The order of types * is important. Consult the code before changing it. */ #define VALUE 0 #define OPEN_PAREN 1 #define CLOSE_PAREN 2 #define COMMA 3 #define END 4 #define UNKNOWN 5 /* * Binary operators: */ #define MULT 8 #define DIVIDE 9 #define MOD 10 #define PLUS 11 #define MINUS 12 #define LEFT_SHIFT 13 #define RIGHT_SHIFT 14 #define LESS 15 #define GREATER 16 #define LEQ 17 #define GEQ 18 #define EQUAL 19 #define NEQ 20 #define BIT_AND 21 #define BIT_XOR 22 #define BIT_OR 23 #define AND 24 #define OR 25 #define QUESTY 26 #define COLON 27 /* * Unary operators: */ #define UNARY_MINUS 28 #define UNARY_PLUS 29 #define NOT 30 #define BIT_NOT 31 /* * Precedence table. The values for non-operator token types are ignored. */ static int precTable[] = { 0, 0, 0, 0, 0, 0, 0, 0, 12, 12, 12, /* MULT, DIVIDE, MOD */ 11, 11, /* PLUS, MINUS */ 10, 10, /* LEFT_SHIFT, RIGHT_SHIFT */ 9, 9, 9, 9, /* LESS, GREATER, LEQ, GEQ */ 8, 8, /* EQUAL, NEQ */ 7, /* BIT_AND */ 6, /* BIT_XOR */ 5, /* BIT_OR */ 4, /* AND */ 3, /* OR */ 2, /* QUESTY */ 1, /* COLON */ 13, 13, 13, 13 /* UNARY_MINUS, UNARY_PLUS, NOT, * BIT_NOT */ }; /* * Mapping from operator numbers to strings; used for error messages. */ static char *operatorStrings[] = { "VALUE", "(", ")", ",", "END", "UNKNOWN", "6", "7", "*", "/", "%", "+", "-", "<<", ">>", "<", ">", "<=", ">=", "==", "!=", "&", "^", "|", "&&", "||", "?", ":", "-", "+", "!", "~" }; /* * The following slight modification to DBL_MAX is needed because of * a compiler bug on Sprite (4/15/93). */ #ifdef sprite #undef DBL_MAX #define DBL_MAX 1.797693134862316e+307 #endif /* * Macros for testing floating-point values for certain special * cases. Test for not-a-number by comparing a value against * itself; test for infinity by comparing against the largest * floating-point value. */ #define IS_NAN(v) ((v) != (v)) #ifdef DBL_MAX # define IS_INF(v) (((v) > DBL_MAX) || ((v) < -DBL_MAX)) #else # define IS_INF(v) 0 #endif /* * The following global variable is use to signal matherr that Tcl * is responsible for the arithmetic, so errors can be handled in a * fashion appropriate for Tcl. Zero means no Tcl math is in * progress; non-zero means Tcl is doing math. */ int tcl_MathInProgress = 0; /* * The variable below serves no useful purpose except to generate * a reference to matherr, so that the Tcl version of matherr is * linked in rather than the system version. Without this reference * the need for matherr won't be discovered during linking until after * libtcl.a has been processed, so Tcl's version won't be used. */ #ifdef NEED_MATHERR extern int matherr(); int (*tclMatherrPtr)() = matherr; #endif /* * Declarations for local procedures to this file: */ static int ExprAbsFunc _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, Tcl_Value *args, Tcl_Value *resultPtr)); static int ExprBinaryFunc _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, Tcl_Value *args, Tcl_Value *resultPtr)); static int ExprDoubleFunc _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, Tcl_Value *args, Tcl_Value *resultPtr)); static int ExprGetValue _ANSI_ARGS_((Tcl_Interp *interp, ExprInfo *infoPtr, int prec, Value *valuePtr)); static int ExprIntFunc _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, Tcl_Value *args, Tcl_Value *resultPtr)); static int ExprLex _ANSI_ARGS_((Tcl_Interp *interp, ExprInfo *infoPtr, Value *valuePtr)); static int ExprLooksLikeInt _ANSI_ARGS_((char *p)); static void ExprMakeString _ANSI_ARGS_((Tcl_Interp *interp, Value *valuePtr)); static int ExprMathFunc _ANSI_ARGS_((Tcl_Interp *interp, ExprInfo *infoPtr, Value *valuePtr)); static int ExprParseString _ANSI_ARGS_((Tcl_Interp *interp, char *string, Value *valuePtr)); static int ExprRoundFunc _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, Tcl_Value *args, Tcl_Value *resultPtr)); static int ExprTopLevel _ANSI_ARGS_((Tcl_Interp *interp, char *string, Value *valuePtr)); static int ExprUnaryFunc _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, Tcl_Value *args, Tcl_Value *resultPtr)); /* * Built-in math functions: */ typedef struct { char *name; /* Name of function. */ int numArgs; /* Number of arguments for function. */ Tcl_ValueType argTypes[MAX_MATH_ARGS]; /* Acceptable types for each argument. */ Tcl_MathProc *proc; /* Procedure that implements this function. */ ClientData clientData; /* Additional argument to pass to the function * when invoking it. */ } BuiltinFunc; static BuiltinFunc funcTable[] = { #ifndef TCL_NO_MATH {"acos", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) acos}, {"asin", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) asin}, {"atan", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) atan}, {"atan2", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) atan2}, {"ceil", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) ceil}, {"cos", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) cos}, {"cosh", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) cosh}, {"exp", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) exp}, {"floor", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) floor}, {"fmod", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) fmod}, {"hypot", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) hypot}, {"log", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) log}, {"log10", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) log10}, {"pow", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) pow}, {"sin", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) sin}, {"sinh", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) sinh}, {"sqrt", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) sqrt}, {"tan", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) tan}, {"tanh", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) tanh}, #endif {"abs", 1, {TCL_EITHER}, ExprAbsFunc, 0}, {"double", 1, {TCL_EITHER}, ExprDoubleFunc, 0}, {"int", 1, {TCL_EITHER}, ExprIntFunc, 0}, {"round", 1, {TCL_EITHER}, ExprRoundFunc, 0}, {0}, }; /* *-------------------------------------------------------------- * * ExprParseString -- * * Given a string (such as one coming from command or variable * substitution), make a Value based on the string. The value * will be a floating-point or integer, if possible, or else it * will just be a copy of the string. * * Results: * TCL_OK is returned under normal circumstances, and TCL_ERROR * is returned if a floating-point overflow or underflow occurred * while reading in a number. The value at *valuePtr is modified * to hold a number, if possible. * * Side effects: * None. * *-------------------------------------------------------------- */ static int ExprParseString(interp, string, valuePtr) Tcl_Interp *interp; /* Where to store error message. */ char *string; /* String to turn into value. */ Value *valuePtr; /* Where to store value information. * Caller must have initialized pv field. */ { char *term, *p, *start; if (*string != 0) { if (ExprLooksLikeInt(string)) { valuePtr->type = TYPE_INT; errno = 0; /* * Note: use strtoul instead of strtol for integer conversions * to allow full-size unsigned numbers, but don't depend on * strtoul to handle sign characters; it won't in some * implementations. */ for (p = string; isspace(UCHAR(*p)); p++) { /* Empty loop body. */ } if (*p == '-') { start = p+1; valuePtr->intValue = -strtoul(start, &term, 0); } else if (*p == '+') { start = p+1; valuePtr->intValue = strtoul(start, &term, 0); } else { start = p; valuePtr->intValue = strtoul(start, &term, 0); } if (*term == 0) { if (errno == ERANGE) { /* * This procedure is sometimes called with string in * interp->result, so we have to clear the result before * logging an error message. */ Tcl_ResetResult(interp); interp->result = "integer value too large to represent"; Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", interp->result, (char *) NULL); return TCL_ERROR; } else { return TCL_OK; } } } else { errno = 0; valuePtr->doubleValue = strtod(string, &term); if ((term != string) && (*term == 0)) { if (errno != 0) { Tcl_ResetResult(interp); TclExprFloatError(interp, valuePtr->doubleValue); return TCL_ERROR; } valuePtr->type = TYPE_DOUBLE; return TCL_OK; } } } /* * Not a valid number. Save a string value (but don't do anything * if it's already the value). */ valuePtr->type = TYPE_STRING; if (string != valuePtr->pv.buffer) { int length, shortfall; length = strlen(string); valuePtr->pv.next = valuePtr->pv.buffer; shortfall = length - (valuePtr->pv.end - valuePtr->pv.buffer); if (shortfall > 0) { (*valuePtr->pv.expandProc)(&valuePtr->pv, shortfall); } strcpy(valuePtr->pv.buffer, string); } return TCL_OK; } /* *---------------------------------------------------------------------- * * ExprLex -- * * Lexical analyzer for expression parser: parses a single value, * operator, or other syntactic element from an expression string. * * Results: * TCL_OK is returned unless an error occurred while doing lexical * analysis or executing an embedded command. In that case a * standard Tcl error is returned, using interp->result to hold * an error message. In the event of a successful return, the token * and field in infoPtr is updated to refer to the next symbol in * the expression string, and the expr field is advanced past that * token; if the token is a value, then the value is stored at * valuePtr. * * Side effects: * None. * *---------------------------------------------------------------------- */ static int ExprLex(interp, infoPtr, valuePtr) Tcl_Interp *interp; /* Interpreter to use for error * reporting. */ register ExprInfo *infoPtr; /* Describes the state of the parse. */ register Value *valuePtr; /* Where to store value, if that is * what's parsed from string. Caller * must have initialized pv field * correctly. */ { register char *p; char *var, *term; int result; p = infoPtr->expr; while (isspace(UCHAR(*p))) { p++; } if (*p == 0) { infoPtr->token = END; infoPtr->expr = p; return TCL_OK; } /* * First try to parse the token as an integer or floating-point number. * Don't want to check for a number if the first character is "+" * or "-". If we do, we might treat a binary operator as unary by * mistake, which will eventually cause a syntax error. */ if ((*p != '+') && (*p != '-')) { if (ExprLooksLikeInt(p)) { errno = 0; valuePtr->intValue = strtoul(p, &term, 0); if (errno == ERANGE) { interp->result = "integer value too large to represent"; Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", interp->result, (char *) NULL); return TCL_ERROR; } infoPtr->token = VALUE; infoPtr->expr = term; valuePtr->type = TYPE_INT; return TCL_OK; } else { errno = 0; valuePtr->doubleValue = strtod(p, &term); if (term != p) { if (errno != 0) { TclExprFloatError(interp, valuePtr->doubleValue); return TCL_ERROR; } infoPtr->token = VALUE; infoPtr->expr = term; valuePtr->type = TYPE_DOUBLE; return TCL_OK; } } } infoPtr->expr = p+1; switch (*p) { case '$': /* * Variable. Fetch its value, then see if it makes sense * as an integer or floating-point number. */ infoPtr->token = VALUE; var = Tcl_ParseVar(interp, p, &infoPtr->expr); if (var == NULL) { return TCL_ERROR; } Tcl_ResetResult(interp); if (((Interp *) interp)->noEval) { valuePtr->type = TYPE_INT; valuePtr->intValue = 0; return TCL_OK; } return ExprParseString(interp, var, valuePtr); case '[': infoPtr->token = VALUE; ((Interp *) interp)->evalFlags = TCL_BRACKET_TERM; result = Tcl_Eval(interp, p+1); infoPtr->expr = ((Interp *) interp)->termPtr; if (result != TCL_OK) { return result; } infoPtr->expr++; if (((Interp *) interp)->noEval) { valuePtr->type = TYPE_INT; valuePtr->intValue = 0; Tcl_ResetResult(interp); return TCL_OK; } result = ExprParseString(interp, interp->result, valuePtr); if (result != TCL_OK) { return result; } Tcl_ResetResult(interp); return TCL_OK; case '"': infoPtr->token = VALUE; result = TclParseQuotes(interp, infoPtr->expr, '"', 0, &infoPtr->expr, &valuePtr->pv); if (result != TCL_OK) { return result; } Tcl_ResetResult(interp); return ExprParseString(interp, valuePtr->pv.buffer, valuePtr); case '{': infoPtr->token = VALUE; result = TclParseBraces(interp, infoPtr->expr, &infoPtr->expr, &valuePtr->pv); if (result != TCL_OK) { return result; } Tcl_ResetResult(interp); return ExprParseString(interp, valuePtr->pv.buffer, valuePtr); case '(': infoPtr->token = OPEN_PAREN; return TCL_OK; case ')': infoPtr->token = CLOSE_PAREN; return TCL_OK; case ',': infoPtr->token = COMMA; return TCL_OK; case '*': infoPtr->token = MULT; return TCL_OK; case '/': infoPtr->token = DIVIDE; return TCL_OK; case '%': infoPtr->token = MOD; return TCL_OK; case '+': infoPtr->token = PLUS; return TCL_OK; case '-': infoPtr->token = MINUS; return TCL_OK; case '?': infoPtr->token = QUESTY; return TCL_OK; case ':': infoPtr->token = COLON; return TCL_OK; case '<': switch (p[1]) { case '<': infoPtr->expr = p+2; infoPtr->token = LEFT_SHIFT; break; case '=': infoPtr->expr = p+2; infoPtr->token = LEQ; break; default: infoPtr->token = LESS; break; } return TCL_OK; case '>': switch (p[1]) { case '>': infoPtr->expr = p+2; infoPtr->token = RIGHT_SHIFT; break; case '=': infoPtr->expr = p+2; infoPtr->token = GEQ; break; default: infoPtr->token = GREATER; break; } return TCL_OK; case '=': if (p[1] == '=') { infoPtr->expr = p+2; infoPtr->token = EQUAL; } else { infoPtr->token = UNKNOWN; } return TCL_OK; case '!': if (p[1] == '=') { infoPtr->expr = p+2; infoPtr->token = NEQ; } else { infoPtr->token = NOT; } return TCL_OK; case '&': if (p[1] == '&') { infoPtr->expr = p+2; infoPtr->token = AND; } else { infoPtr->token = BIT_AND; } return TCL_OK; case '^': infoPtr->token = BIT_XOR; return TCL_OK; case '|': if (p[1] == '|') { infoPtr->expr = p+2; infoPtr->token = OR; } else { infoPtr->token = BIT_OR; } return TCL_OK; case '~': infoPtr->token = BIT_NOT; return TCL_OK; default: if (isalpha(UCHAR(*p))) { infoPtr->expr = p; return ExprMathFunc(interp, infoPtr, valuePtr); } infoPtr->expr = p+1; infoPtr->token = UNKNOWN; return TCL_OK; } } /* *---------------------------------------------------------------------- * * ExprGetValue -- * * Parse a "value" from the remainder of the expression in infoPtr. * * Results: * Normally TCL_OK is returned. The value of the expression is * returned in *valuePtr. If an error occurred, then interp->result * contains an error message and TCL_ERROR is returned. * InfoPtr->token will be left pointing to the token AFTER the * expression, and infoPtr->expr will point to the character just * after the terminating token. * * Side effects: * None. * *---------------------------------------------------------------------- */ static int ExprGetValue(interp, infoPtr, prec, valuePtr) Tcl_Interp *interp; /* Interpreter to use for error * reporting. */ register ExprInfo *infoPtr; /* Describes the state of the parse * just before the value (i.e. ExprLex * will be called to get first token * of value). */ int prec; /* Treat any un-parenthesized operator * with precedence <= this as the end * of the expression. */ Value *valuePtr; /* Where to store the value of the * expression. Caller must have * initialized pv field. */ { Interp *iPtr = (Interp *) interp; Value value2; /* Second operand for current * operator. */ int operator; /* Current operator (either unary * or binary). */ int badType; /* Type of offending argument; used * for error messages. */ int gotOp; /* Non-zero means already lexed the * operator (while picking up value * for unary operator). Don't lex * again. */ int result; /* * There are two phases to this procedure. First, pick off an initial * value. Then, parse (binary operator, value) pairs until done. */ gotOp = 0; value2.pv.buffer = value2.pv.next = value2.staticSpace; value2.pv.end = value2.pv.buffer + STATIC_STRING_SPACE - 1; value2.pv.expandProc = TclExpandParseValue; value2.pv.clientData = (ClientData) NULL; result = ExprLex(interp, infoPtr, valuePtr); if (result != TCL_OK) { goto done; } if (infoPtr->token == OPEN_PAREN) { /* * Parenthesized sub-expression. */ result = ExprGetValue(interp, infoPtr, -1, valuePtr); if (result != TCL_OK) { goto done; } if (infoPtr->token != CLOSE_PAREN) { Tcl_AppendResult(interp, "unmatched parentheses in expression \"", infoPtr->originalExpr, "\"", (char *) NULL); result = TCL_ERROR; goto done; } } else { if (infoPtr->token == MINUS) { infoPtr->token = UNARY_MINUS; } if (infoPtr->token == PLUS) { infoPtr->token = UNARY_PLUS; } if (infoPtr->token >= UNARY_MINUS) { /* * Process unary operators. */ operator = infoPtr->token; result = ExprGetValue(interp, infoPtr, precTable[infoPtr->token], valuePtr); if (result != TCL_OK) { goto done; } if (!iPtr->noEval) { switch (operator) { case UNARY_MINUS: if (valuePtr->type == TYPE_INT) { if (valuePtr->intValue == LONG_MIN) { goto integerOverflow; } valuePtr->intValue = -valuePtr->intValue; } else if (valuePtr->type == TYPE_DOUBLE){ valuePtr->doubleValue = -valuePtr->doubleValue; } else { badType = valuePtr->type; goto illegalType; } break; case UNARY_PLUS: if ((valuePtr->type != TYPE_INT) && (valuePtr->type != TYPE_DOUBLE)) { badType = valuePtr->type; goto illegalType; } break; case NOT: if (valuePtr->type == TYPE_INT) { valuePtr->intValue = !valuePtr->intValue; } else if (valuePtr->type == TYPE_DOUBLE) { /* * Theoretically, should be able to use * "!valuePtr->intValue", but apparently some * compilers can't handle it. */ if (valuePtr->doubleValue == 0.0) { valuePtr->intValue = 1; } else { valuePtr->intValue = 0; } valuePtr->type = TYPE_INT; } else { badType = valuePtr->type; goto illegalType; } break; case BIT_NOT: if (valuePtr->type == TYPE_INT) { valuePtr->intValue = ~valuePtr->intValue; } else { badType = valuePtr->type; goto illegalType; } break; } } gotOp = 1; } else if (infoPtr->token != VALUE) { goto syntaxError; } } /* * Got the first operand. Now fetch (operator, operand) pairs. */ if (!gotOp) { result = ExprLex(interp, infoPtr, &value2); if (result != TCL_OK) { goto done; } } while (1) { operator = infoPtr->token; value2.pv.next = value2.pv.buffer; if ((operator < MULT) || (operator >= UNARY_MINUS)) { if ((operator == END) || (operator == CLOSE_PAREN) || (operator == COMMA)) { result = TCL_OK; goto done; } else { goto syntaxError; } } if (precTable[operator] <= prec) { result = TCL_OK; goto done; } /* * If we're doing an AND or OR and the first operand already * determines the result, don't execute anything in the * second operand: just parse. Same style for ?: pairs. */ if ((operator == AND) || (operator == OR) || (operator == QUESTY)) { if (valuePtr->type == TYPE_DOUBLE) { valuePtr->intValue = valuePtr->doubleValue != 0; valuePtr->type = TYPE_INT; } else if ((valuePtr->type == TYPE_STRING) && !iPtr->noEval) { badType = TYPE_STRING; goto illegalType; } if (((operator == AND) && !valuePtr->intValue) || ((operator == OR) && valuePtr->intValue)) { iPtr->noEval++; result = ExprGetValue(interp, infoPtr, precTable[operator], &value2); iPtr->noEval--; if (operator == OR) { valuePtr->intValue = 1; } continue; } else if (operator == QUESTY) { /* * Special note: ?: operators must associate right to * left. To make this happen, use a precedence one lower * than QUESTY when calling ExprGetValue recursively. */ if (valuePtr->intValue != 0) { valuePtr->pv.next = valuePtr->pv.buffer; result = ExprGetValue(interp, infoPtr, precTable[QUESTY] - 1, valuePtr); if (result != TCL_OK) { goto done; } if (infoPtr->token != COLON) { goto syntaxError; } value2.pv.next = value2.pv.buffer; iPtr->noEval++; result = ExprGetValue(interp, infoPtr, precTable[QUESTY] - 1, &value2); iPtr->noEval--; } else { iPtr->noEval++; result = ExprGetValue(interp, infoPtr, precTable[QUESTY] - 1, &value2); iPtr->noEval--; if (result != TCL_OK) { goto done; } if (infoPtr->token != COLON) { goto syntaxError; } valuePtr->pv.next = valuePtr->pv.buffer; result = ExprGetValue(interp, infoPtr, precTable[QUESTY] - 1, valuePtr); } continue; } else { result = ExprGetValue(interp, infoPtr, precTable[operator], &value2); } } else { result = ExprGetValue(interp, infoPtr, precTable[operator], &value2); } if (result != TCL_OK) { goto done; } if ((infoPtr->token < MULT) && (infoPtr->token != VALUE) && (infoPtr->token != END) && (infoPtr->token != COMMA) && (infoPtr->token != CLOSE_PAREN)) { goto syntaxError; } if (iPtr->noEval) { continue; } /* * At this point we've got two values and an operator. Check * to make sure that the particular data types are appropriate * for the particular operator, and perform type conversion * if necessary. */ switch (operator) { /* * For the operators below, no strings are allowed and * ints get converted to floats if necessary. */ case MULT: case DIVIDE: case PLUS: case MINUS: if ((valuePtr->type == TYPE_STRING) || (value2.type == TYPE_STRING)) { badType = TYPE_STRING; goto illegalType; } if (valuePtr->type == TYPE_DOUBLE) { if (value2.type == TYPE_INT) { value2.doubleValue = value2.intValue; value2.type = TYPE_DOUBLE; } } else if (value2.type == TYPE_DOUBLE) { if (valuePtr->type == TYPE_INT) { valuePtr->doubleValue = valuePtr->intValue; valuePtr->type = TYPE_DOUBLE; } } break; /* * For the operators below, only integers are allowed. */ case MOD: case LEFT_SHIFT: case RIGHT_SHIFT: case BIT_AND: case BIT_XOR: case BIT_OR: if (valuePtr->type != TYPE_INT) { badType = valuePtr->type; goto illegalType; } else if (value2.type != TYPE_INT) { badType = value2.type; goto illegalType; } break; /* * For the operators below, any type is allowed but the * two operands must have the same type. Convert integers * to floats and either to strings, if necessary. */ case LESS: case GREATER: case LEQ: case GEQ: case EQUAL: case NEQ: if (valuePtr->type == TYPE_STRING) { if (value2.type != TYPE_STRING) { ExprMakeString(interp, &value2); } } else if (value2.type == TYPE_STRING) { if (valuePtr->type != TYPE_STRING) { ExprMakeString(interp, valuePtr); } } else if (valuePtr->type == TYPE_DOUBLE) { if (value2.type == TYPE_INT) { value2.doubleValue = value2.intValue; value2.type = TYPE_DOUBLE; } } else if (value2.type == TYPE_DOUBLE) { if (valuePtr->type == TYPE_INT) { valuePtr->doubleValue = valuePtr->intValue; valuePtr->type = TYPE_DOUBLE; } } break; /* * For the operators below, no strings are allowed, but * no int->double conversions are performed. */ case AND: case OR: if (valuePtr->type == TYPE_STRING) { badType = valuePtr->type; goto illegalType; } if (value2.type == TYPE_STRING) { badType = value2.type; goto illegalType; } break; /* * For the operators below, type and conversions are * irrelevant: they're handled elsewhere. */ case QUESTY: case COLON: break; /* * Any other operator is an error. */ default: interp->result = "unknown operator in expression"; result = TCL_ERROR; goto done; } /* * Carry out the function of the specified operator. */ switch (operator) { case MULT: if (valuePtr->type == TYPE_INT) { result = valuePtr->intValue * value2.intValue; /* * Check that no overflow occurred in the multiplication */ if ((valuePtr->intValue != 0) && ((result / valuePtr->intValue) != value2.intValue)) { goto integerOverflow; } valuePtr->intValue = result; } else { valuePtr->doubleValue *= value2.doubleValue; } break; case DIVIDE: case MOD: if (valuePtr->type == TYPE_INT) { long divisor, quot, rem; int negative; if (value2.intValue == 0) { divideByZero: interp->result = "divide by zero"; Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", interp->result, (char *) NULL); result = TCL_ERROR; goto done; } if ((valuePtr->intValue == LONG_MIN) && (value2.intValue == -1) && (operator == DIVIDE)) { goto integerOverflow; } /* * The code below is tricky because C doesn't guarantee * much about the properties of the quotient or * remainder, but Tcl does: the remainder always has * the same sign as the divisor and a smaller absolute * value. */ divisor = value2.intValue; negative = 0; if (divisor < 0) { divisor = -divisor; valuePtr->intValue = -valuePtr->intValue; negative = 1; } quot = valuePtr->intValue / divisor; rem = valuePtr->intValue % divisor; if (rem < 0) { rem += divisor; quot -= 1; } if (negative) { rem = -rem; } valuePtr->intValue = (operator == DIVIDE) ? quot : rem; } else { if (value2.doubleValue == 0.0) { goto divideByZero; } valuePtr->doubleValue /= value2.doubleValue; } break; case PLUS: if (valuePtr->type == TYPE_INT) { result = valuePtr->intValue + value2.intValue; if ((value2.intValue >= 0) ^ (result >= valuePtr->intValue)) { goto integerOverflow; } valuePtr->intValue = result; } else { valuePtr->doubleValue += value2.doubleValue; } break; case MINUS: if (valuePtr->type == TYPE_INT) { result = valuePtr->intValue - value2.intValue; if ((value2.intValue >= 0) ^ (result <= valuePtr->intValue)) { goto integerOverflow; } valuePtr->intValue = result; } else { valuePtr->doubleValue -= value2.doubleValue; } break; case LEFT_SHIFT: valuePtr->intValue <<= value2.intValue; break; case RIGHT_SHIFT: /* * The following code is a bit tricky: it ensures that * right shifts propagate the sign bit even on machines * where ">>" won't do it by default. */ if (valuePtr->intValue < 0) { valuePtr->intValue = ~((~valuePtr->intValue) >> value2.intValue); } else { valuePtr->intValue >>= value2.intValue; } break; case LESS: if (valuePtr->type == TYPE_INT) { valuePtr->intValue = valuePtr->intValue < value2.intValue; } else if (valuePtr->type == TYPE_DOUBLE) { valuePtr->intValue = valuePtr->doubleValue < value2.doubleValue; } else { valuePtr->intValue = strcmp(valuePtr->pv.buffer, value2.pv.buffer) < 0; } valuePtr->type = TYPE_INT; break; case GREATER: if (valuePtr->type == TYPE_INT) { valuePtr->intValue = valuePtr->intValue > value2.intValue; } else if (valuePtr->type == TYPE_DOUBLE) { valuePtr->intValue = valuePtr->doubleValue > value2.doubleValue; } else { valuePtr->intValue = strcmp(valuePtr->pv.buffer, value2.pv.buffer) > 0; } valuePtr->type = TYPE_INT; break; case LEQ: if (valuePtr->type == TYPE_INT) { valuePtr->intValue = valuePtr->intValue <= value2.intValue; } else if (valuePtr->type == TYPE_DOUBLE) { valuePtr->intValue = valuePtr->doubleValue <= value2.doubleValue; } else { valuePtr->intValue = strcmp(valuePtr->pv.buffer, value2.pv.buffer) <= 0; } valuePtr->type = TYPE_INT; break; case GEQ: if (valuePtr->type == TYPE_INT) { valuePtr->intValue = valuePtr->intValue >= value2.intValue; } else if (valuePtr->type == TYPE_DOUBLE) { valuePtr->intValue = valuePtr->doubleValue >= value2.doubleValue; } else { valuePtr->intValue = strcmp(valuePtr->pv.buffer, value2.pv.buffer) >= 0; } valuePtr->type = TYPE_INT; break; case EQUAL: if (valuePtr->type == TYPE_INT) { valuePtr->intValue = valuePtr->intValue == value2.intValue; } else if (valuePtr->type == TYPE_DOUBLE) { valuePtr->intValue = valuePtr->doubleValue == value2.doubleValue; } else { valuePtr->intValue = strcmp(valuePtr->pv.buffer, value2.pv.buffer) == 0; } valuePtr->type = TYPE_INT; break; case NEQ: if (valuePtr->type == TYPE_INT) { valuePtr->intValue = valuePtr->intValue != value2.intValue; } else if (valuePtr->type == TYPE_DOUBLE) { valuePtr->intValue = valuePtr->doubleValue != value2.doubleValue; } else { valuePtr->intValue = strcmp(valuePtr->pv.buffer, value2.pv.buffer) != 0; } valuePtr->type = TYPE_INT; break; case BIT_AND: valuePtr->intValue &= value2.intValue; break; case BIT_XOR: valuePtr->intValue ^= value2.intValue; break; case BIT_OR: valuePtr->intValue |= value2.intValue; break; /* * For AND and OR, we know that the first value has already * been converted to an integer. Thus we need only consider * the possibility of int vs. double for the second value. */ case AND: if (value2.type == TYPE_DOUBLE) { value2.intValue = value2.doubleValue != 0; value2.type = TYPE_INT; } valuePtr->intValue = valuePtr->intValue && value2.intValue; break; case OR: if (value2.type == TYPE_DOUBLE) { value2.intValue = value2.doubleValue != 0; value2.type = TYPE_INT; } valuePtr->intValue = valuePtr->intValue || value2.intValue; break; case COLON: interp->result = "can't have : operator without ? first"; result = TCL_ERROR; goto done; } } done: if (value2.pv.buffer != value2.staticSpace) { ckfree(value2.pv.buffer); } return result; syntaxError: Tcl_AppendResult(interp, "syntax error in expression \"", infoPtr->originalExpr, "\"", (char *) NULL); result = TCL_ERROR; goto done; illegalType: Tcl_AppendResult(interp, "can't use ", (badType == TYPE_DOUBLE) ? "floating-point value" : "non-numeric string", " as operand of \"", operatorStrings[operator], "\"", (char *) NULL); result = TCL_ERROR; goto done; integerOverflow: interp->result = "integer overflow"; Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", interp->result, (char *) NULL); result = TCL_ERROR; goto done; } /* *-------------------------------------------------------------- * * ExprMakeString -- * * Convert a value from int or double representation to * a string. * * Results: * The information at *valuePtr gets converted to string * format, if it wasn't that way already. * * Side effects: * None. * *-------------------------------------------------------------- */ static void ExprMakeString(interp, valuePtr) Tcl_Interp *interp; /* Interpreter to use for precision * information. */ register Value *valuePtr; /* Value to be converted. */ { int shortfall; shortfall = 150 - (valuePtr->pv.end - valuePtr->pv.buffer); if (shortfall > 0) { (*valuePtr->pv.expandProc)(&valuePtr->pv, shortfall); } if (valuePtr->type == TYPE_INT) { sprintf(valuePtr->pv.buffer, "%ld", valuePtr->intValue); } else if (valuePtr->type == TYPE_DOUBLE) { Tcl_PrintDouble(interp, valuePtr->doubleValue, valuePtr->pv.buffer); } valuePtr->type = TYPE_STRING; } /* *-------------------------------------------------------------- * * ExprTopLevel -- * * This procedure provides top-level functionality shared by * procedures like Tcl_ExprInt, Tcl_ExprDouble, etc. * * Results: * The result is a standard Tcl return value. If an error * occurs then an error message is left in interp->result. * The value of the expression is returned in *valuePtr, in * whatever form it ends up in (could be string or integer * or double). Caller may need to convert result. Caller * is also responsible for freeing string memory in *valuePtr, * if any was allocated. * * Side effects: * None. * *-------------------------------------------------------------- */ static int ExprTopLevel(interp, string, valuePtr) Tcl_Interp *interp; /* Context in which to evaluate the * expression. */ char *string; /* Expression to evaluate. */ Value *valuePtr; /* Where to store result. Should * not be initialized by caller. */ { ExprInfo info; int result; /* * Create the math functions the first time an expression is * evaluated. */ if (!(((Interp *) interp)->flags & EXPR_INITIALIZED)) { BuiltinFunc *funcPtr; ((Interp *) interp)->flags |= EXPR_INITIALIZED; for (funcPtr = funcTable; funcPtr->name != NULL; funcPtr++) { Tcl_CreateMathFunc(interp, funcPtr->name, funcPtr->numArgs, funcPtr->argTypes, funcPtr->proc, funcPtr->clientData); } } info.originalExpr = string; info.expr = string; valuePtr->pv.buffer = valuePtr->pv.next = valuePtr->staticSpace; valuePtr->pv.end = valuePtr->pv.buffer + STATIC_STRING_SPACE - 1; valuePtr->pv.expandProc = TclExpandParseValue; valuePtr->pv.clientData = (ClientData) NULL; result = ExprGetValue(interp, &info, -1, valuePtr); if (result != TCL_OK) { return result; } if (info.token != END) { Tcl_AppendResult(interp, "syntax error in expression \"", string, "\"", (char *) NULL); return TCL_ERROR; } if ((valuePtr->type == TYPE_DOUBLE) && (IS_NAN(valuePtr->doubleValue) || IS_INF(valuePtr->doubleValue))) { /* * IEEE floating-point error. */ TclExprFloatError(interp, valuePtr->doubleValue); return TCL_ERROR; } return TCL_OK; } /* *-------------------------------------------------------------- * * Tcl_ExprLong, Tcl_ExprDouble, Tcl_ExprBoolean -- * * Procedures to evaluate an expression and return its value * in a particular form. * * Results: * Each of the procedures below returns a standard Tcl result. * If an error occurs then an error message is left in * interp->result. Otherwise the value of the expression, * in the appropriate form, is stored at *resultPtr. If * the expression had a result that was incompatible with the * desired form then an error is returned. * * Side effects: * None. * *-------------------------------------------------------------- */ int Tcl_ExprLong(interp, string, ptr) Tcl_Interp *interp; /* Context in which to evaluate the * expression. */ char *string; /* Expression to evaluate. */ long *ptr; /* Where to store result. */ { Value value; int result; result = ExprTopLevel(interp, string, &value); if (result == TCL_OK) { if (value.type == TYPE_INT) { *ptr = value.intValue; } else if (value.type == TYPE_DOUBLE) { *ptr = value.doubleValue; } else { interp->result = "expression didn't have numeric value"; result = TCL_ERROR; } } if (value.pv.buffer != value.staticSpace) { ckfree(value.pv.buffer); } return result; } int Tcl_ExprDouble(interp, string, ptr) Tcl_Interp *interp; /* Context in which to evaluate the * expression. */ char *string; /* Expression to evaluate. */ double *ptr; /* Where to store result. */ { Value value; int result; result = ExprTopLevel(interp, string, &value); if (result == TCL_OK) { if (value.type == TYPE_INT) { *ptr = value.intValue; } else if (value.type == TYPE_DOUBLE) { *ptr = value.doubleValue; } else { interp->result = "expression didn't have numeric value"; result = TCL_ERROR; } } if (value.pv.buffer != value.staticSpace) { ckfree(value.pv.buffer); } return result; } int Tcl_ExprBoolean(interp, string, ptr) Tcl_Interp *interp; /* Context in which to evaluate the * expression. */ char *string; /* Expression to evaluate. */ int *ptr; /* Where to store 0/1 result. */ { Value value; int result; result = ExprTopLevel(interp, string, &value); if (result == TCL_OK) { if (value.type == TYPE_INT) { *ptr = value.intValue != 0; } else if (value.type == TYPE_DOUBLE) { *ptr = value.doubleValue != 0.0; } else { result = Tcl_GetBoolean(interp, value.pv.buffer, ptr); } } if (value.pv.buffer != value.staticSpace) { ckfree(value.pv.buffer); } return result; } /* *-------------------------------------------------------------- * * Tcl_ExprString -- * * Evaluate an expression and return its value in string form. * * Results: * A standard Tcl result. If the result is TCL_OK, then the * interpreter's result is set to the string value of the * expression. If the result is TCL_OK, then interp->result * contains an error message. * * Side effects: * None. * *-------------------------------------------------------------- */ int Tcl_ExprString(interp, string) Tcl_Interp *interp; /* Context in which to evaluate the * expression. */ char *string; /* Expression to evaluate. */ { Value value; int result; result = ExprTopLevel(interp, string, &value); if (result == TCL_OK) { if (value.type == TYPE_INT) { sprintf(interp->result, "%ld", value.intValue); } else if (value.type == TYPE_DOUBLE) { Tcl_PrintDouble(interp, value.doubleValue, interp->result); } else { if (value.pv.buffer != value.staticSpace) { interp->result = value.pv.buffer; interp->freeProc = (Tcl_FreeProc *) free; value.pv.buffer = value.staticSpace; } else { Tcl_SetResult(interp, value.pv.buffer, TCL_VOLATILE); } } } if (value.pv.buffer != value.staticSpace) { ckfree(value.pv.buffer); } return result; } /* *---------------------------------------------------------------------- * * Tcl_CreateMathFunc -- * * Creates a new math function for expressions in a given * interpreter. * * Results: * None. * * Side effects: * The function defined by "name" is created; if such a function * already existed then its definition is overriden. * *---------------------------------------------------------------------- */ void Tcl_CreateMathFunc(interp, name, numArgs, argTypes, proc, clientData) Tcl_Interp *interp; /* Interpreter in which function is * to be available. */ char *name; /* Name of function (e.g. "sin"). */ int numArgs; /* Nnumber of arguments required by * function. */ Tcl_ValueType *argTypes; /* Array of types acceptable for * each argument. */ Tcl_MathProc *proc; /* Procedure that implements the * math function. */ ClientData clientData; /* Additional value to pass to the * function. */ { Interp *iPtr = (Interp *) interp; Tcl_HashEntry *hPtr; MathFunc *mathFuncPtr; int new, i; hPtr = Tcl_CreateHashEntry(&iPtr->mathFuncTable, name, &new); if (new) { Tcl_SetHashValue(hPtr, ckalloc(sizeof(MathFunc))); } mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr); if (numArgs > MAX_MATH_ARGS) { numArgs = MAX_MATH_ARGS; } mathFuncPtr->numArgs = numArgs; for (i = 0; i < numArgs; i++) { mathFuncPtr->argTypes[i] = argTypes[i]; } mathFuncPtr->proc = proc; mathFuncPtr->clientData = clientData; } /* *---------------------------------------------------------------------- * * ExprMathFunc -- * * This procedure is invoked to parse a math function from an * expression string, carry out the function, and return the * value computed. * * Results: * TCL_OK is returned if all went well and the function's value * was computed successfully. If an error occurred, TCL_ERROR * is returned and an error message is left in interp->result. * After a successful return infoPtr has been updated to refer * to the character just after the function call, the token is * set to VALUE, and the value is stored in valuePtr. * * Side effects: * Embedded commands could have arbitrary side-effects. * *---------------------------------------------------------------------- */ static int ExprMathFunc(interp, infoPtr, valuePtr) Tcl_Interp *interp; /* Interpreter to use for error * reporting. */ register ExprInfo *infoPtr; /* Describes the state of the parse. * infoPtr->expr must point to the * first character of the function's * name. */ register Value *valuePtr; /* Where to store value, if that is * what's parsed from string. Caller * must have initialized pv field * correctly. */ { Interp *iPtr = (Interp *) interp; MathFunc *mathFuncPtr; /* Info about math function. */ Tcl_Value args[MAX_MATH_ARGS]; /* Arguments for function call. */ Tcl_Value funcResult; /* Result of function call. */ Tcl_HashEntry *hPtr; char *p, *funcName; int i, savedChar, result; /* * Find the end of the math function's name and lookup the MathFunc * record for the function. */ p = funcName = infoPtr->expr; while (isalnum(UCHAR(*p)) || (*p == '_')) { p++; } infoPtr->expr = p; result = ExprLex(interp, infoPtr, valuePtr); if (result != TCL_OK) { return TCL_ERROR; } if (infoPtr->token != OPEN_PAREN) { goto syntaxError; } savedChar = *p; *p = 0; hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, funcName); if (hPtr == NULL) { Tcl_AppendResult(interp, "unknown math function \"", funcName, "\"", (char *) NULL); *p = savedChar; return TCL_ERROR; } *p = savedChar; mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr); /* * Scan off the arguments for the function, if there are any. */ if (mathFuncPtr->numArgs == 0) { result = ExprLex(interp, infoPtr, valuePtr); if ((result != TCL_OK) || (infoPtr->token != CLOSE_PAREN)) { goto syntaxError; } } else { for (i = 0; ; i++) { valuePtr->pv.next = valuePtr->pv.buffer; result = ExprGetValue(interp, infoPtr, -1, valuePtr); if (result != TCL_OK) { return result; } if (valuePtr->type == TYPE_STRING) { interp->result = "argument to math function didn't have numeric value"; return TCL_ERROR; } /* * Copy the value to the argument record, converting it if * necessary. */ if (valuePtr->type == TYPE_INT) { if (mathFuncPtr->argTypes[i] == TCL_DOUBLE) { args[i].type = TCL_DOUBLE; args[i].doubleValue = valuePtr->intValue; } else { args[i].type = TCL_INT; args[i].intValue = valuePtr->intValue; } } else { if (mathFuncPtr->argTypes[i] == TCL_INT) { args[i].type = TCL_INT; args[i].intValue = valuePtr->doubleValue; } else { args[i].type = TCL_DOUBLE; args[i].doubleValue = valuePtr->doubleValue; } } /* * Check for a comma separator between arguments or a close-paren * to end the argument list. */ if (i == (mathFuncPtr->numArgs-1)) { if (infoPtr->token == CLOSE_PAREN) { break; } if (infoPtr->token == COMMA) { interp->result = "too many arguments for math function"; return TCL_ERROR; } else { goto syntaxError; } } if (infoPtr->token != COMMA) { if (infoPtr->token == CLOSE_PAREN) { interp->result = "too few arguments for math function"; return TCL_ERROR; } else { goto syntaxError; } } } } if (iPtr->noEval) { valuePtr->type = TYPE_INT; valuePtr->intValue = 0; infoPtr->token = VALUE; return TCL_OK; } /* * Invoke the function and copy its result back into valuePtr. */ tcl_MathInProgress++; result = (*mathFuncPtr->proc)(mathFuncPtr->clientData, interp, args, &funcResult); tcl_MathInProgress--; if (result != TCL_OK) { return result; } if (funcResult.type == TCL_INT) { valuePtr->type = TYPE_INT; valuePtr->intValue = funcResult.intValue; } else { valuePtr->type = TYPE_DOUBLE; valuePtr->doubleValue = funcResult.doubleValue; } infoPtr->token = VALUE; return TCL_OK; syntaxError: Tcl_AppendResult(interp, "syntax error in expression \"", infoPtr->originalExpr, "\"", (char *) NULL); return TCL_ERROR; } /* *---------------------------------------------------------------------- * * TclExprFloatError -- * * This procedure is called when an error occurs during a * floating-point operation. It reads errno and sets * interp->result accordingly. * * Results: * Interp->result is set to hold an error message. * * Side effects: * None. * *---------------------------------------------------------------------- */ void TclExprFloatError(interp, value) Tcl_Interp *interp; /* Where to store error message. */ double value; /* Value returned after error; used to * distinguish underflows from overflows. */ { char buf[20]; if ((errno == EDOM) || (value != value)) { interp->result = "domain error: argument not in valid range"; Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", interp->result, (char *) NULL); } else if ((errno == ERANGE) || IS_INF(value)) { if (value == 0.0) { interp->result = "floating-point value too small to represent"; Tcl_SetErrorCode(interp, "ARITH", "UNDERFLOW", interp->result, (char *) NULL); } else { interp->result = "floating-point value too large to represent"; Tcl_SetErrorCode(interp, "ARITH", "OVERFLOW", interp->result, (char *) NULL); } } else { sprintf(buf, "%d", errno); Tcl_AppendResult(interp, "unknown floating-point error, ", "errno = ", buf, (char *) NULL); Tcl_SetErrorCode(interp, "ARITH", "UNKNOWN", interp->result, (char *) NULL); } } /* *---------------------------------------------------------------------- * * Math Functions -- * * This page contains the procedures that implement all of the * built-in math functions for expressions. * * Results: * Each procedure returns TCL_OK if it succeeds and places result * information at *resultPtr. If it fails it returns TCL_ERROR * and leaves an error message in interp->result. * * Side effects: * None. * *---------------------------------------------------------------------- */ static int ExprUnaryFunc(clientData, interp, args, resultPtr) ClientData clientData; /* Contains address of procedure that * takes one double argument and * returns a double result. */ Tcl_Interp *interp; Tcl_Value *args; Tcl_Value *resultPtr; { double (*func)() = (double (*)()) clientData; errno = 0; resultPtr->type = TCL_DOUBLE; resultPtr->doubleValue = (*func)(args[0].doubleValue); if (errno != 0) { TclExprFloatError(interp, resultPtr->doubleValue); return TCL_ERROR; } return TCL_OK; } static int ExprBinaryFunc(clientData, interp, args, resultPtr) ClientData clientData; /* Contains address of procedure that * takes two double arguments and * returns a double result. */ Tcl_Interp *interp; Tcl_Value *args; Tcl_Value *resultPtr; { double (*func)() = (double (*)()) clientData; errno = 0; resultPtr->type = TCL_DOUBLE; resultPtr->doubleValue = (*func)(args[0].doubleValue, args[1].doubleValue); if (errno != 0) { TclExprFloatError(interp, resultPtr->doubleValue); return TCL_ERROR; } return TCL_OK; } /* ARGSUSED */ static int ExprAbsFunc(clientData, interp, args, resultPtr) ClientData clientData; Tcl_Interp *interp; Tcl_Value *args; Tcl_Value *resultPtr; { resultPtr->type = TCL_DOUBLE; if (args[0].type == TCL_DOUBLE) { resultPtr->type = TCL_DOUBLE; if (args[0].doubleValue < 0) { resultPtr->doubleValue = -args[0].doubleValue; } else { resultPtr->doubleValue = args[0].doubleValue; } } else { resultPtr->type = TCL_INT; if (args[0].intValue < 0) { resultPtr->intValue = -args[0].intValue; if (resultPtr->intValue < 0) { interp->result = "integer value too large to represent"; Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", interp->result, (char *) NULL); return TCL_ERROR; } } else { resultPtr->intValue = args[0].intValue; } } return TCL_OK; } /* ARGSUSED */ static int ExprDoubleFunc(clientData, interp, args, resultPtr) ClientData clientData; Tcl_Interp *interp; Tcl_Value *args; Tcl_Value *resultPtr; { resultPtr->type = TCL_DOUBLE; if (args[0].type == TCL_DOUBLE) { resultPtr->doubleValue = args[0].doubleValue; } else { resultPtr->doubleValue = args[0].intValue; } return TCL_OK; } /* ARGSUSED */ static int ExprIntFunc(clientData, interp, args, resultPtr) ClientData clientData; Tcl_Interp *interp; Tcl_Value *args; Tcl_Value *resultPtr; { resultPtr->type = TCL_INT; if (args[0].type == TCL_INT) { resultPtr->intValue = args[0].intValue; } else { if (args[0].doubleValue < 0) { if (args[0].doubleValue < (double) (long) LONG_MIN) { tooLarge: interp->result = "integer value too large to represent"; Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", interp->result, (char *) NULL); return TCL_ERROR; } } else { if (args[0].doubleValue > (double) LONG_MAX) { goto tooLarge; } } resultPtr->intValue = args[0].doubleValue; } return TCL_OK; } /* ARGSUSED */ static int ExprRoundFunc(clientData, interp, args, resultPtr) ClientData clientData; Tcl_Interp *interp; Tcl_Value *args; Tcl_Value *resultPtr; { resultPtr->type = TCL_INT; if (args[0].type == TCL_INT) { resultPtr->intValue = args[0].intValue; } else { if (args[0].doubleValue < 0) { if (args[0].doubleValue <= (((double) (long) LONG_MIN) - 0.5)) { tooLarge: interp->result = "integer value too large to represent"; Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", interp->result, (char *) NULL); return TCL_ERROR; } resultPtr->intValue = (args[0].doubleValue - 0.5); } else { if (args[0].doubleValue >= (((double) LONG_MAX + 0.5))) { goto tooLarge; } resultPtr->intValue = (args[0].doubleValue + 0.5); } } return TCL_OK; } /* *---------------------------------------------------------------------- * * ExprLooksLikeInt -- * * This procedure decides whether the leading characters of a * string look like an integer or something else (such as a * floating-point number or string). * * Results: * The return value is 1 if the leading characters of p look * like a valid Tcl integer. If they look like a floating-point * number (e.g. "e01" or "2.4"), or if they don't look like a * number at all, then 0 is returned. * * Side effects: * None. * *---------------------------------------------------------------------- */ static int ExprLooksLikeInt(p) char *p; /* Pointer to string. */ { while (isspace(UCHAR(*p))) { p++; } if ((*p == '+') || (*p == '-')) { p++; } if (!isdigit(UCHAR(*p))) { return 0; } p++; while (isdigit(UCHAR(*p))) { p++; } if ((*p != '.') && (*p != 'e') && (*p != 'E')) { return 1; } return 0; } , savedChar, result; /* * Find the end of the math function's name and lookup the MathFunc * record for the function. */ tcl7.4b4/tclGet.c010044400630510000012000000132250575301074200144160ustar00ousterstaff00002300000001/* * tclGet.c -- * * This file contains procedures to convert strings into * other forms, like integers or floating-point numbers or * booleans, doing syntax checking along the way. * * Copyright (c) 1990-1993 The Regents of the University of California. * Copyright (c) 1994-1995 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ static char sccsid[] = "@(#) tclGet.c 1.20 95/02/14 13:14:34"; #include "tclInt.h" #include "tclPort.h" /* *---------------------------------------------------------------------- * * Tcl_GetInt -- * * Given a string, produce the corresponding integer value. * * Results: * The return value is normally TCL_OK; in this case *intPtr * will be set to the integer value equivalent to string. If * string is improperly formed then TCL_ERROR is returned and * an error message will be left in interp->result. * * Side effects: * None. * *---------------------------------------------------------------------- */ int Tcl_GetInt(interp, string, intPtr) Tcl_Interp *interp; /* Interpreter to use for error reporting. */ char *string; /* String containing a (possibly signed) * integer in a form acceptable to strtol. */ int *intPtr; /* Place to store converted result. */ { char *end, *p; int i; /* * Note: use strtoul instead of strtol for integer conversions * to allow full-size unsigned numbers, but don't depend on strtoul * to handle sign characters; it won't in some implementations. */ errno = 0; for (p = string; isspace(UCHAR(*p)); p++) { /* Empty loop body. */ } if (*p == '-') { p++; i = -strtoul(p, &end, 0); } else if (*p == '+') { p++; i = strtoul(p, &end, 0); } else { i = strtoul(p, &end, 0); } if (end == p) { badInteger: Tcl_AppendResult(interp, "expected integer but got \"", string, "\"", (char *) NULL); return TCL_ERROR; } if (errno == ERANGE) { interp->result = "integer value too large to represent"; Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", interp->result, (char *) NULL); return TCL_ERROR; } while ((*end != '\0') && isspace(UCHAR(*end))) { end++; } if (*end != 0) { goto badInteger; } *intPtr = i; return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_GetDouble -- * * Given a string, produce the corresponding double-precision * floating-point value. * * Results: * The return value is normally TCL_OK; in this case *doublePtr * will be set to the double-precision value equivalent to string. * If string is improperly formed then TCL_ERROR is returned and * an error message will be left in interp->result. * * Side effects: * None. * *---------------------------------------------------------------------- */ int Tcl_GetDouble(interp, string, doublePtr) Tcl_Interp *interp; /* Interpreter to use for error reporting. */ char *string; /* String containing a floating-point number * in a form acceptable to strtod. */ double *doublePtr; /* Place to store converted result. */ { char *end; double d; errno = 0; d = strtod(string, &end); if (end == string) { badDouble: Tcl_AppendResult(interp, "expected floating-point number but got \"", string, "\"", (char *) NULL); return TCL_ERROR; } if (errno != 0) { TclExprFloatError(interp, d); return TCL_ERROR; } while ((*end != 0) && isspace(UCHAR(*end))) { end++; } if (*end != 0) { goto badDouble; } *doublePtr = d; return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_GetBoolean -- * * Given a string, return a 0/1 boolean value corresponding * to the string. * * Results: * The return value is normally TCL_OK; in this case *boolPtr * will be set to the 0/1 value equivalent to string. If * string is improperly formed then TCL_ERROR is returned and * an error message will be left in interp->result. * * Side effects: * None. * *---------------------------------------------------------------------- */ int Tcl_GetBoolean(interp, string, boolPtr) Tcl_Interp *interp; /* Interpreter to use for error reporting. */ char *string; /* String containing a boolean number * specified either as 1/0 or true/false or * yes/no. */ int *boolPtr; /* Place to store converted result, which * will be 0 or 1. */ { int i, c; char lowerCase[10]; size_t length; /* * Convert the input string to all lower-case. */ for (i = 0; i < 9; i++) { c = string[i]; if (c == 0) { break; } if ((c >= 'A') && (c <= 'Z')) { c += 'a' - 'A'; } lowerCase[i] = c; } lowerCase[i] = 0; length = strlen(lowerCase); c = lowerCase[0]; if ((c == '0') && (lowerCase[1] == '\0')) { *boolPtr = 0; } else if ((c == '1') && (lowerCase[1] == '\0')) { *boolPtr = 1; } else if ((c == 'y') && (strncmp(lowerCase, "yes", length) == 0)) { *boolPtr = 1; } else if ((c == 'n') && (strncmp(lowerCase, "no", length) == 0)) { *boolPtr = 0; } else if ((c == 't') && (strncmp(lowerCase, "true", length) == 0)) { *boolPtr = 1; } else if ((c == 'f') && (strncmp(lowerCase, "false", length) == 0)) { *boolPtr = 0; } else if ((c == 'o') && (length >= 2)) { if (strncmp(lowerCase, "on", length) == 0) { *boolPtr = 1; } else if (strncmp(lowerCase, "off", length) == 0) { *boolPtr = 0; } else { goto badBoolean; } } else { badBoolean: Tcl_AppendResult(interp, "expected boolean value but got \"", string, "\"", (char *) NULL); return TCL_ERROR; } return TCL_OK; } , doing syntax checking along the way. * * Copyright (c) 1990-1993 The Regents of the University of California. * Copyright (c) 1994-1995 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ static char sccsid[] = "@(#) tclGet.c 1.20 95/02/14 13:14:tcl7.4b4/tclHash.c010044400630510000012000000602040567467740400146010ustar00ousterstaff00002300000001/* * tclHash.c -- * * Implementation of in-memory hash tables for Tcl and Tcl-based * applications. * * Copyright (c) 1991-1993 The Regents of the University of California. * Copyright (c) 1994 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #ifndef lint static char sccsid[] = "@(#) tclHash.c 1.14 94/12/17 16:14:17"; #endif /* not lint */ #include "tclInt.h" /* * When there are this many entries per bucket, on average, rebuild * the hash table to make it larger. */ #define REBUILD_MULTIPLIER 3 /* * The following macro takes a preliminary integer hash value and * produces an index into a hash tables bucket list. The idea is * to make it so that preliminary values that are arbitrarily similar * will end up in different buckets. The hash function was taken * from a random-number generator. */ #define RANDOM_INDEX(tablePtr, i) \ (((((long) (i))*1103515245) >> (tablePtr)->downShift) & (tablePtr)->mask) /* * Procedure prototypes for static procedures in this file: */ static Tcl_HashEntry * ArrayFind _ANSI_ARGS_((Tcl_HashTable *tablePtr, char *key)); static Tcl_HashEntry * ArrayCreate _ANSI_ARGS_((Tcl_HashTable *tablePtr, char *key, int *newPtr)); static Tcl_HashEntry * BogusFind _ANSI_ARGS_((Tcl_HashTable *tablePtr, char *key)); static Tcl_HashEntry * BogusCreate _ANSI_ARGS_((Tcl_HashTable *tablePtr, char *key, int *newPtr)); static unsigned int HashString _ANSI_ARGS_((char *string)); static void RebuildTable _ANSI_ARGS_((Tcl_HashTable *tablePtr)); static Tcl_HashEntry * StringFind _ANSI_ARGS_((Tcl_HashTable *tablePtr, char *key)); static Tcl_HashEntry * StringCreate _ANSI_ARGS_((Tcl_HashTable *tablePtr, char *key, int *newPtr)); static Tcl_HashEntry * OneWordFind _ANSI_ARGS_((Tcl_HashTable *tablePtr, char *key)); static Tcl_HashEntry * OneWordCreate _ANSI_ARGS_((Tcl_HashTable *tablePtr, char *key, int *newPtr)); /* *---------------------------------------------------------------------- * * Tcl_InitHashTable -- * * Given storage for a hash table, set up the fields to prepare * the hash table for use. * * Results: * None. * * Side effects: * TablePtr is now ready to be passed to Tcl_FindHashEntry and * Tcl_CreateHashEntry. * *---------------------------------------------------------------------- */ void Tcl_InitHashTable(tablePtr, keyType) register Tcl_HashTable *tablePtr; /* Pointer to table record, which * is supplied by the caller. */ int keyType; /* Type of keys to use in table: * TCL_STRING_KEYS, TCL_ONE_WORD_KEYS, * or an integer >= 2. */ { tablePtr->buckets = tablePtr->staticBuckets; tablePtr->staticBuckets[0] = tablePtr->staticBuckets[1] = 0; tablePtr->staticBuckets[2] = tablePtr->staticBuckets[3] = 0; tablePtr->numBuckets = TCL_SMALL_HASH_TABLE; tablePtr->numEntries = 0; tablePtr->rebuildSize = TCL_SMALL_HASH_TABLE*REBUILD_MULTIPLIER; tablePtr->downShift = 28; tablePtr->mask = 3; tablePtr->keyType = keyType; if (keyType == TCL_STRING_KEYS) { tablePtr->findProc = StringFind; tablePtr->createProc = StringCreate; } else if (keyType == TCL_ONE_WORD_KEYS) { tablePtr->findProc = OneWordFind; tablePtr->createProc = OneWordCreate; } else { tablePtr->findProc = ArrayFind; tablePtr->createProc = ArrayCreate; }; } /* *---------------------------------------------------------------------- * * Tcl_DeleteHashEntry -- * * Remove a single entry from a hash table. * * Results: * None. * * Side effects: * The entry given by entryPtr is deleted from its table and * should never again be used by the caller. It is up to the * caller to free the clientData field of the entry, if that * is relevant. * *---------------------------------------------------------------------- */ void Tcl_DeleteHashEntry(entryPtr) Tcl_HashEntry *entryPtr; { register Tcl_HashEntry *prevPtr; if (*entryPtr->bucketPtr == entryPtr) { *entryPtr->bucketPtr = entryPtr->nextPtr; } else { for (prevPtr = *entryPtr->bucketPtr; ; prevPtr = prevPtr->nextPtr) { if (prevPtr == NULL) { panic("malformed bucket chain in Tcl_DeleteHashEntry"); } if (prevPtr->nextPtr == entryPtr) { prevPtr->nextPtr = entryPtr->nextPtr; break; } } } entryPtr->tablePtr->numEntries--; ckfree((char *) entryPtr); } /* *---------------------------------------------------------------------- * * Tcl_DeleteHashTable -- * * Free up everything associated with a hash table except for * the record for the table itself. * * Results: * None. * * Side effects: * The hash table is no longer useable. * *---------------------------------------------------------------------- */ void Tcl_DeleteHashTable(tablePtr) register Tcl_HashTable *tablePtr; /* Table to delete. */ { register Tcl_HashEntry *hPtr, *nextPtr; int i; /* * Free up all the entries in the table. */ for (i = 0; i < tablePtr->numBuckets; i++) { hPtr = tablePtr->buckets[i]; while (hPtr != NULL) { nextPtr = hPtr->nextPtr; ckfree((char *) hPtr); hPtr = nextPtr; } } /* * Free up the bucket array, if it was dynamically allocated. */ if (tablePtr->buckets != tablePtr->staticBuckets) { ckfree((char *) tablePtr->buckets); } /* * Arrange for panics if the table is used again without * re-initialization. */ tablePtr->findProc = BogusFind; tablePtr->createProc = BogusCreate; } /* *---------------------------------------------------------------------- * * Tcl_FirstHashEntry -- * * Locate the first entry in a hash table and set up a record * that can be used to step through all the remaining entries * of the table. * * Results: * The return value is a pointer to the first entry in tablePtr, * or NULL if tablePtr has no entries in it. The memory at * *searchPtr is initialized so that subsequent calls to * Tcl_NextHashEntry will return all of the entries in the table, * one at a time. * * Side effects: * None. * *---------------------------------------------------------------------- */ Tcl_HashEntry * Tcl_FirstHashEntry(tablePtr, searchPtr) Tcl_HashTable *tablePtr; /* Table to search. */ Tcl_HashSearch *searchPtr; /* Place to store information about * progress through the table. */ { searchPtr->tablePtr = tablePtr; searchPtr->nextIndex = 0; searchPtr->nextEntryPtr = NULL; return Tcl_NextHashEntry(searchPtr); } /* *---------------------------------------------------------------------- * * Tcl_NextHashEntry -- * * Once a hash table enumeration has been initiated by calling * Tcl_FirstHashEntry, this procedure may be called to return * successive elements of the table. * * Results: * The return value is the next entry in the hash table being * enumerated, or NULL if the end of the table is reached. * * Side effects: * None. * *---------------------------------------------------------------------- */ Tcl_HashEntry * Tcl_NextHashEntry(searchPtr) register Tcl_HashSearch *searchPtr; /* Place to store information about * progress through the table. Must * have been initialized by calling * Tcl_FirstHashEntry. */ { Tcl_HashEntry *hPtr; while (searchPtr->nextEntryPtr == NULL) { if (searchPtr->nextIndex >= searchPtr->tablePtr->numBuckets) { return NULL; } searchPtr->nextEntryPtr = searchPtr->tablePtr->buckets[searchPtr->nextIndex]; searchPtr->nextIndex++; } hPtr = searchPtr->nextEntryPtr; searchPtr->nextEntryPtr = hPtr->nextPtr; return hPtr; } /* *---------------------------------------------------------------------- * * Tcl_HashStats -- * * Return statistics describing the layout of the hash table * in its hash buckets. * * Results: * The return value is a malloc-ed string containing information * about tablePtr. It is the caller's responsibility to free * this string. * * Side effects: * None. * *---------------------------------------------------------------------- */ char * Tcl_HashStats(tablePtr) Tcl_HashTable *tablePtr; /* Table for which to produce stats. */ { #define NUM_COUNTERS 10 int count[NUM_COUNTERS], overflow, i, j; double average, tmp; register Tcl_HashEntry *hPtr; char *result, *p; /* * Compute a histogram of bucket usage. */ for (i = 0; i < NUM_COUNTERS; i++) { count[i] = 0; } overflow = 0; average = 0.0; for (i = 0; i < tablePtr->numBuckets; i++) { j = 0; for (hPtr = tablePtr->buckets[i]; hPtr != NULL; hPtr = hPtr->nextPtr) { j++; } if (j < NUM_COUNTERS) { count[j]++; } else { overflow++; } tmp = j; average += (tmp+1.0)*(tmp/tablePtr->numEntries)/2.0; } /* * Print out the histogram and a few other pieces of information. */ result = (char *) ckalloc((unsigned) ((NUM_COUNTERS*60) + 300)); sprintf(result, "%d entries in table, %d buckets\n", tablePtr->numEntries, tablePtr->numBuckets); p = result + strlen(result); for (i = 0; i < NUM_COUNTERS; i++) { sprintf(p, "number of buckets with %d entries: %d\n", i, count[i]); p += strlen(p); } sprintf(p, "number of buckets with %d or more entries: %d\n", NUM_COUNTERS, overflow); p += strlen(p); sprintf(p, "average search distance for entry: %.1f", average); return result; } /* *---------------------------------------------------------------------- * * HashString -- * * Compute a one-word summary of a text string, which can be * used to generate a hash index. * * Results: * The return value is a one-word summary of the information in * string. * * Side effects: * None. * *---------------------------------------------------------------------- */ static unsigned int HashString(string) register char *string; /* String from which to compute hash value. */ { register unsigned int result; register int c; /* * I tried a zillion different hash functions and asked many other * people for advice. Many people had their own favorite functions, * all different, but no-one had much idea why they were good ones. * I chose the one below (multiply by 9 and add new character) * because of the following reasons: * * 1. Multiplying by 10 is perfect for keys that are decimal strings, * and multiplying by 9 is just about as good. * 2. Times-9 is (shift-left-3) plus (old). This means that each * character's bits hang around in the low-order bits of the * hash value for ever, plus they spread fairly rapidly up to * the high-order bits to fill out the hash value. This seems * works well both for decimal and non-decimal strings. */ result = 0; while (1) { c = *string; string++; if (c == 0) { break; } result += (result<<3) + c; } return result; } /* *---------------------------------------------------------------------- * * StringFind -- * * Given a hash table with string keys, and a string key, find * the entry with a matching key. * * Results: * The return value is a token for the matching entry in the * hash table, or NULL if there was no matching entry. * * Side effects: * None. * *---------------------------------------------------------------------- */ static Tcl_HashEntry * StringFind(tablePtr, key) Tcl_HashTable *tablePtr; /* Table in which to lookup entry. */ char *key; /* Key to use to find matching entry. */ { register Tcl_HashEntry *hPtr; register char *p1, *p2; int index; index = HashString(key) & tablePtr->mask; /* * Search all of the entries in the appropriate bucket. */ for (hPtr = tablePtr->buckets[index]; hPtr != NULL; hPtr = hPtr->nextPtr) { for (p1 = key, p2 = hPtr->key.string; ; p1++, p2++) { if (*p1 != *p2) { break; } if (*p1 == '\0') { return hPtr; } } } return NULL; } /* *---------------------------------------------------------------------- * * StringCreate -- * * Given a hash table with string keys, and a string key, find * the entry with a matching key. If there is no matching entry, * then create a new entry that does match. * * Results: * The return value is a pointer to the matching entry. If this * is a newly-created entry, then *newPtr will be set to a non-zero * value; otherwise *newPtr will be set to 0. If this is a new * entry the value stored in the entry will initially be 0. * * Side effects: * A new entry may be added to the hash table. * *---------------------------------------------------------------------- */ static Tcl_HashEntry * StringCreate(tablePtr, key, newPtr) Tcl_HashTable *tablePtr; /* Table in which to lookup entry. */ char *key; /* Key to use to find or create matching * entry. */ int *newPtr; /* Store info here telling whether a new * entry was created. */ { register Tcl_HashEntry *hPtr; register char *p1, *p2; int index; index = HashString(key) & tablePtr->mask; /* * Search all of the entries in this bucket. */ for (hPtr = tablePtr->buckets[index]; hPtr != NULL; hPtr = hPtr->nextPtr) { for (p1 = key, p2 = hPtr->key.string; ; p1++, p2++) { if (*p1 != *p2) { break; } if (*p1 == '\0') { *newPtr = 0; return hPtr; } } } /* * Entry not found. Add a new one to the bucket. */ *newPtr = 1; hPtr = (Tcl_HashEntry *) ckalloc((unsigned) (sizeof(Tcl_HashEntry) + strlen(key) - (sizeof(hPtr->key) -1))); hPtr->tablePtr = tablePtr; hPtr->bucketPtr = &(tablePtr->buckets[index]); hPtr->nextPtr = *hPtr->bucketPtr; hPtr->clientData = 0; strcpy(hPtr->key.string, key); *hPtr->bucketPtr = hPtr; tablePtr->numEntries++; /* * If the table has exceeded a decent size, rebuild it with many * more buckets. */ if (tablePtr->numEntries >= tablePtr->rebuildSize) { RebuildTable(tablePtr); } return hPtr; } /* *---------------------------------------------------------------------- * * OneWordFind -- * * Given a hash table with one-word keys, and a one-word key, find * the entry with a matching key. * * Results: * The return value is a token for the matching entry in the * hash table, or NULL if there was no matching entry. * * Side effects: * None. * *---------------------------------------------------------------------- */ static Tcl_HashEntry * OneWordFind(tablePtr, key) Tcl_HashTable *tablePtr; /* Table in which to lookup entry. */ register char *key; /* Key to use to find matching entry. */ { register Tcl_HashEntry *hPtr; int index; index = RANDOM_INDEX(tablePtr, key); /* * Search all of the entries in the appropriate bucket. */ for (hPtr = tablePtr->buckets[index]; hPtr != NULL; hPtr = hPtr->nextPtr) { if (hPtr->key.oneWordValue == key) { return hPtr; } } return NULL; } /* *---------------------------------------------------------------------- * * OneWordCreate -- * * Given a hash table with one-word keys, and a one-word key, find * the entry with a matching key. If there is no matching entry, * then create a new entry that does match. * * Results: * The return value is a pointer to the matching entry. If this * is a newly-created entry, then *newPtr will be set to a non-zero * value; otherwise *newPtr will be set to 0. If this is a new * entry the value stored in the entry will initially be 0. * * Side effects: * A new entry may be added to the hash table. * *---------------------------------------------------------------------- */ static Tcl_HashEntry * OneWordCreate(tablePtr, key, newPtr) Tcl_HashTable *tablePtr; /* Table in which to lookup entry. */ register char *key; /* Key to use to find or create matching * entry. */ int *newPtr; /* Store info here telling whether a new * entry was created. */ { register Tcl_HashEntry *hPtr; int index; index = RANDOM_INDEX(tablePtr, key); /* * Search all of the entries in this bucket. */ for (hPtr = tablePtr->buckets[index]; hPtr != NULL; hPtr = hPtr->nextPtr) { if (hPtr->key.oneWordValue == key) { *newPtr = 0; return hPtr; } } /* * Entry not found. Add a new one to the bucket. */ *newPtr = 1; hPtr = (Tcl_HashEntry *) ckalloc(sizeof(Tcl_HashEntry)); hPtr->tablePtr = tablePtr; hPtr->bucketPtr = &(tablePtr->buckets[index]); hPtr->nextPtr = *hPtr->bucketPtr; hPtr->clientData = 0; hPtr->key.oneWordValue = key; *hPtr->bucketPtr = hPtr; tablePtr->numEntries++; /* * If the table has exceeded a decent size, rebuild it with many * more buckets. */ if (tablePtr->numEntries >= tablePtr->rebuildSize) { RebuildTable(tablePtr); } return hPtr; } /* *---------------------------------------------------------------------- * * ArrayFind -- * * Given a hash table with array-of-int keys, and a key, find * the entry with a matching key. * * Results: * The return value is a token for the matching entry in the * hash table, or NULL if there was no matching entry. * * Side effects: * None. * *---------------------------------------------------------------------- */ static Tcl_HashEntry * ArrayFind(tablePtr, key) Tcl_HashTable *tablePtr; /* Table in which to lookup entry. */ char *key; /* Key to use to find matching entry. */ { register Tcl_HashEntry *hPtr; int *arrayPtr = (int *) key; register int *iPtr1, *iPtr2; int index, count; for (index = 0, count = tablePtr->keyType, iPtr1 = arrayPtr; count > 0; count--, iPtr1++) { index += *iPtr1; } index = RANDOM_INDEX(tablePtr, index); /* * Search all of the entries in the appropriate bucket. */ for (hPtr = tablePtr->buckets[index]; hPtr != NULL; hPtr = hPtr->nextPtr) { for (iPtr1 = arrayPtr, iPtr2 = hPtr->key.words, count = tablePtr->keyType; ; count--, iPtr1++, iPtr2++) { if (count == 0) { return hPtr; } if (*iPtr1 != *iPtr2) { break; } } } return NULL; } /* *---------------------------------------------------------------------- * * ArrayCreate -- * * Given a hash table with one-word keys, and a one-word key, find * the entry with a matching key. If there is no matching entry, * then create a new entry that does match. * * Results: * The return value is a pointer to the matching entry. If this * is a newly-created entry, then *newPtr will be set to a non-zero * value; otherwise *newPtr will be set to 0. If this is a new * entry the value stored in the entry will initially be 0. * * Side effects: * A new entry may be added to the hash table. * *---------------------------------------------------------------------- */ static Tcl_HashEntry * ArrayCreate(tablePtr, key, newPtr) Tcl_HashTable *tablePtr; /* Table in which to lookup entry. */ register char *key; /* Key to use to find or create matching * entry. */ int *newPtr; /* Store info here telling whether a new * entry was created. */ { register Tcl_HashEntry *hPtr; int *arrayPtr = (int *) key; register int *iPtr1, *iPtr2; int index, count; for (index = 0, count = tablePtr->keyType, iPtr1 = arrayPtr; count > 0; count--, iPtr1++) { index += *iPtr1; } index = RANDOM_INDEX(tablePtr, index); /* * Search all of the entries in the appropriate bucket. */ for (hPtr = tablePtr->buckets[index]; hPtr != NULL; hPtr = hPtr->nextPtr) { for (iPtr1 = arrayPtr, iPtr2 = hPtr->key.words, count = tablePtr->keyType; ; count--, iPtr1++, iPtr2++) { if (count == 0) { *newPtr = 0; return hPtr; } if (*iPtr1 != *iPtr2) { break; } } } /* * Entry not found. Add a new one to the bucket. */ *newPtr = 1; hPtr = (Tcl_HashEntry *) ckalloc((unsigned) (sizeof(Tcl_HashEntry) + (tablePtr->keyType*sizeof(int)) - 4)); hPtr->tablePtr = tablePtr; hPtr->bucketPtr = &(tablePtr->buckets[index]); hPtr->nextPtr = *hPtr->bucketPtr; hPtr->clientData = 0; for (iPtr1 = arrayPtr, iPtr2 = hPtr->key.words, count = tablePtr->keyType; count > 0; count--, iPtr1++, iPtr2++) { *iPtr2 = *iPtr1; } *hPtr->bucketPtr = hPtr; tablePtr->numEntries++; /* * If the table has exceeded a decent size, rebuild it with many * more buckets. */ if (tablePtr->numEntries >= tablePtr->rebuildSize) { RebuildTable(tablePtr); } return hPtr; } /* *---------------------------------------------------------------------- * * BogusFind -- * * This procedure is invoked when an Tcl_FindHashEntry is called * on a table that has been deleted. * * Results: * If panic returns (which it shouldn't) this procedure returns * NULL. * * Side effects: * Generates a panic. * *---------------------------------------------------------------------- */ /* ARGSUSED */ static Tcl_HashEntry * BogusFind(tablePtr, key) Tcl_HashTable *tablePtr; /* Table in which to lookup entry. */ char *key; /* Key to use to find matching entry. */ { panic("called Tcl_FindHashEntry on deleted table"); return NULL; } /* *---------------------------------------------------------------------- * * BogusCreate -- * * This procedure is invoked when an Tcl_CreateHashEntry is called * on a table that has been deleted. * * Results: * If panic returns (which it shouldn't) this procedure returns * NULL. * * Side effects: * Generates a panic. * *---------------------------------------------------------------------- */ /* ARGSUSED */ static Tcl_HashEntry * BogusCreate(tablePtr, key, newPtr) Tcl_HashTable *tablePtr; /* Table in which to lookup entry. */ char *key; /* Key to use to find or create matching * entry. */ int *newPtr; /* Store info here telling whether a new * entry was created. */ { panic("called Tcl_CreateHashEntry on deleted table"); return NULL; } /* *---------------------------------------------------------------------- * * RebuildTable -- * * This procedure is invoked when the ratio of entries to hash * buckets becomes too large. It creates a new table with a * larger bucket array and moves all of the entries into the * new table. * * Results: * None. * * Side effects: * Memory gets reallocated and entries get re-hashed to new * buckets. * *---------------------------------------------------------------------- */ static void RebuildTable(tablePtr) register Tcl_HashTable *tablePtr; /* Table to enlarge. */ { int oldSize, count, index; Tcl_HashEntry **oldBuckets; register Tcl_HashEntry **oldChainPtr, **newChainPtr; register Tcl_HashEntry *hPtr; oldSize = tablePtr->numBuckets; oldBuckets = tablePtr->buckets; /* * Allocate and initialize the new bucket array, and set up * hashing constants for new array size. */ tablePtr->numBuckets *= 4; tablePtr->buckets = (Tcl_HashEntry **) ckalloc((unsigned) (tablePtr->numBuckets * sizeof(Tcl_HashEntry *))); for (count = tablePtr->numBuckets, newChainPtr = tablePtr->buckets; count > 0; count--, newChainPtr++) { *newChainPtr = NULL; } tablePtr->rebuildSize *= 4; tablePtr->downShift -= 2; tablePtr->mask = (tablePtr->mask << 2) + 3; /* * Rehash all of the existing entries into the new bucket array. */ for (oldChainPtr = oldBuckets; oldSize > 0; oldSize--, oldChainPtr++) { for (hPtr = *oldChainPtr; hPtr != NULL; hPtr = *oldChainPtr) { *oldChainPtr = hPtr->nextPtr; if (tablePtr->keyType == TCL_STRING_KEYS) { index = HashString(hPtr->key.string) & tablePtr->mask; } else if (tablePtr->keyType == TCL_ONE_WORD_KEYS) { index = RANDOM_INDEX(tablePtr, hPtr->key.oneWordValue); } else { register int *iPtr; int count; for (index = 0, count = tablePtr->keyType, iPtr = hPtr->key.words; count > 0; count--, iPtr++) { index += *iPtr; } index = RANDOM_INDEX(tablePtr, index); } hPtr->bucketPtr = &(tablePtr->buckets[index]); hPtr->nextPtr = *hPtr->bucketPtr; *hPtr->bucketPtr = hPtr; } } /* * Free up the old bucket array, if it was dynamically allocated. */ if (oldBuckets != tablePtr->staticBuckets) { ckfree((char *) oldBuckets); } } alue is a token for the matching entry in the * hash table, or NULL if there was no matching entry. * * Side effects: * None. * *---------------------------------------------------------------------- */ static Tcl_HashEntry * OneWordFind(tablePtr, key) Tcl_HashTable *tablePtr; /* Table in which to lookup entry. */ register char *key; /* Key to use to find matchtcl7.4b4/tclHistory.c010044400630510000012000000733020575222104200153360ustar00ousterstaff00002300000001/* * tclHistory.c -- * * This module implements history as an optional addition to Tcl. * It can be called to record commands ("events") before they are * executed, and it provides a command that may be used to perform * history substitutions. * * Copyright (c) 1990-1993 The Regents of the University of California. * Copyright (c) 1994-1995 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #ifndef lint static char sccsid[] = "@(#) tclHistory.c 1.37 95/05/04 11:51:16"; #endif /* not lint */ #include "tclInt.h" #include "tclPort.h" /* * This history stuff is mostly straightforward, except for one thing * that makes everything very complicated. Suppose that the following * commands get executed: * echo foo * history redo * It's important that the history event recorded for the second command * be "echo foo", not "history redo". Otherwise, if another "history redo" * command is typed, it will result in infinite recursions on the * "history redo" command. Thus, the actual recorded history must be * echo foo * echo foo * To do this, the history command revises recorded history as part of * its execution. In the example above, when "history redo" starts * execution, the current event is "history redo", but the history * command arranges for the current event to be changed to "echo foo". * * There are three additional complications. The first is that history * substitution may only be part of a command, as in the following * command sequence: * echo foo bar * echo [history word 3] * In this case, the second event should be recorded as "echo bar". Only * part of the recorded event is to be modified. Fortunately, Tcl_Eval * helps with this by recording (in the evalFirst and evalLast fields of * the intepreter) the location of the command being executed, so the * history module can replace exactly the range of bytes corresponding * to the history substitution command. * * The second complication is that there are two ways to revise history: * replace a command, and replace the result of a command. Consider the * two examples below: * format {result is %d} $num | format {result is %d} $num * print [history redo] | print [history word 3] * Recorded history for these two cases should be as follows: * format {result is %d} $num | format {result is %d} $num * print [format {result is %d} $num] | print $num * In the left case, the history command was replaced with another command * to be executed (the brackets were retained), but in the case on the * right the result of executing the history command was replaced (i.e. * brackets were replaced too). * * The third complication is that there could potentially be many * history substitutions within a single command, as in: * echo [history word 3] [history word 2] * There could even be nested history substitutions, as in: * history subs abc [history word 2] * If history revisions were made immediately during each "history" command * invocations, it would be very difficult to produce the correct cumulative * effect from several substitutions in the same command. To get around * this problem, the actual history revision isn't made during the execution * of the "history" command. Information about the changes is just recorded, * in xxx records, and the actual changes are made during the next call to * Tcl_RecordHistory (when we know that execution of the previous command * has finished). */ /* * Default space allocation for command strings: */ #define INITIAL_CMD_SIZE 40 /* * Forward declarations for procedures defined later in this file: */ static void DoRevs _ANSI_ARGS_((Interp *iPtr)); static HistoryEvent * GetEvent _ANSI_ARGS_((Interp *iPtr, char *string)); static char * GetWords _ANSI_ARGS_((Interp *iPtr, char *command, char *words)); static void InitHistory _ANSI_ARGS_((Interp *iPtr)); static void InsertRev _ANSI_ARGS_((Interp *iPtr, HistoryRev *revPtr)); static void MakeSpace _ANSI_ARGS_((HistoryEvent *hPtr, int size)); static void RevCommand _ANSI_ARGS_((Interp *iPtr, char *string)); static void RevResult _ANSI_ARGS_((Interp *iPtr, char *string)); static int SubsAndEval _ANSI_ARGS_((Interp *iPtr, char *cmd, char *old, char *new)); /* *---------------------------------------------------------------------- * * InitHistory -- * * Initialize history-related state in an interpreter. * * Results: * None. * * Side effects: * History info is initialized in iPtr. * *---------------------------------------------------------------------- */ static void InitHistory(iPtr) register Interp *iPtr; /* Interpreter to initialize. */ { int i; if (iPtr->numEvents != 0) { return; } iPtr->numEvents = 20; iPtr->events = (HistoryEvent *) ckalloc((unsigned) (iPtr->numEvents * sizeof(HistoryEvent))); for (i = 0; i < iPtr->numEvents; i++) { iPtr->events[i].command = (char *) ckalloc(INITIAL_CMD_SIZE); *iPtr->events[i].command = 0; iPtr->events[i].bytesAvl = INITIAL_CMD_SIZE; } iPtr->curEvent = 0; iPtr->curEventNum = 0; } /* *---------------------------------------------------------------------- * * Tcl_RecordAndEval -- * * This procedure adds its command argument to the current list of * recorded events and then executes the command by calling * Tcl_Eval. * * Results: * The return value is a standard Tcl return value, the result of * executing cmd. * * Side effects: * The command is recorded and executed. In addition, pending history * revisions are carried out, and information is set up to enable * Tcl_Eval to identify history command ranges. This procedure also * initializes history information for the interpreter, if it hasn't * already been initialized. * *---------------------------------------------------------------------- */ int Tcl_RecordAndEval(interp, cmd, flags) Tcl_Interp *interp; /* Token for interpreter in which command * will be executed. */ char *cmd; /* Command to record. */ int flags; /* Additional flags. TCL_NO_EVAL means * only record: don't execute command. * TCL_EVAL_GLOBAL means use Tcl_GlobalEval * instead of Tcl_Eval. */ { register Interp *iPtr = (Interp *) interp; register HistoryEvent *eventPtr; int length, result; if (iPtr->numEvents == 0) { InitHistory(iPtr); } DoRevs(iPtr); /* * Don't record empty commands. */ while (isspace(UCHAR(*cmd))) { cmd++; } if (*cmd == '\0') { Tcl_ResetResult(interp); return TCL_OK; } iPtr->curEventNum++; iPtr->curEvent++; if (iPtr->curEvent >= iPtr->numEvents) { iPtr->curEvent = 0; } eventPtr = &iPtr->events[iPtr->curEvent]; /* * Chop off trailing newlines before recording the command. */ length = strlen(cmd); while (cmd[length-1] == '\n') { length--; } MakeSpace(eventPtr, length + 1); strncpy(eventPtr->command, cmd, (size_t) length); eventPtr->command[length] = 0; /* * Execute the command. Note: history revision isn't possible after * a nested call to this procedure, because the event at the top of * the history list no longer corresponds to what's going on when * a nested call here returns. Thus, must leave history revision * disabled when we return. */ result = TCL_OK; if (!(flags & TCL_NO_EVAL)) { iPtr->historyFirst = cmd; iPtr->revDisables = 0; iPtr->evalFlags = (flags & ~TCL_EVAL_GLOBAL) | TCL_RECORD_BOUNDS; if (flags & TCL_EVAL_GLOBAL) { result = Tcl_GlobalEval(interp, cmd); } else { result = Tcl_Eval(interp, cmd); } } iPtr->revDisables = 1; return result; } /* *---------------------------------------------------------------------- * * Tcl_HistoryCmd -- * * This procedure is invoked to process the "history" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_HistoryCmd(dummy, interp, argc, argv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { register Interp *iPtr = (Interp *) interp; register HistoryEvent *eventPtr; size_t length; int c; if (iPtr->numEvents == 0) { InitHistory(iPtr); } /* * If no arguments, treat the same as "history info". */ if (argc == 1) { goto infoCmd; } c = argv[1][0]; length = strlen(argv[1]); if ((c == 'a') && (strncmp(argv[1], "add", length)) == 0) { if ((argc != 3) && (argc != 4)) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " add event ?exec?\"", (char *) NULL); return TCL_ERROR; } if (argc == 4) { if (strncmp(argv[3], "exec", strlen(argv[3])) != 0) { Tcl_AppendResult(interp, "bad argument \"", argv[3], "\": should be \"exec\"", (char *) NULL); return TCL_ERROR; } return Tcl_RecordAndEval(interp, argv[2], 0); } return Tcl_RecordAndEval(interp, argv[2], TCL_NO_EVAL); } else if ((c == 'c') && (strncmp(argv[1], "change", length)) == 0) { if ((argc != 3) && (argc != 4)) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " change newValue ?event?\"", (char *) NULL); return TCL_ERROR; } if (argc == 3) { eventPtr = &iPtr->events[iPtr->curEvent]; iPtr->revDisables += 1; while (iPtr->revPtr != NULL) { HistoryRev *nextPtr; ckfree(iPtr->revPtr->newBytes); nextPtr = iPtr->revPtr->nextPtr; ckfree((char *) iPtr->revPtr); iPtr->revPtr = nextPtr; } } else { eventPtr = GetEvent(iPtr, argv[3]); if (eventPtr == NULL) { return TCL_ERROR; } } MakeSpace(eventPtr, (int) strlen(argv[2]) + 1); strcpy(eventPtr->command, argv[2]); return TCL_OK; } else if ((c == 'e') && (strncmp(argv[1], "event", length)) == 0) { if (argc > 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " event ?event?\"", (char *) NULL); return TCL_ERROR; } eventPtr = GetEvent(iPtr, argc==2 ? "-1" : argv[2]); if (eventPtr == NULL) { return TCL_ERROR; } RevResult(iPtr, eventPtr->command); Tcl_SetResult(interp, eventPtr->command, TCL_VOLATILE); return TCL_OK; } else if ((c == 'i') && (strncmp(argv[1], "info", length)) == 0) { int count, indx, i; char *newline; if ((argc != 2) && (argc != 3)) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " info ?count?\"", (char *) NULL); return TCL_ERROR; } infoCmd: if (argc == 3) { if (Tcl_GetInt(interp, argv[2], &count) != TCL_OK) { return TCL_ERROR; } if (count > iPtr->numEvents) { count = iPtr->numEvents; } } else { count = iPtr->numEvents; } newline = ""; for (i = 0, indx = iPtr->curEvent + 1 + iPtr->numEvents - count; i < count; i++, indx++) { char *cur, *next, savedChar; char serial[20]; if (indx >= iPtr->numEvents) { indx -= iPtr->numEvents; } cur = iPtr->events[indx].command; if (*cur == '\0') { continue; /* No command recorded here. */ } sprintf(serial, "%6d ", iPtr->curEventNum + 1 - (count - i)); Tcl_AppendResult(interp, newline, serial, (char *) NULL); newline = "\n"; /* * Tricky formatting here: for multi-line commands, indent * the continuation lines. */ while (1) { next = strchr(cur, '\n'); if (next == NULL) { break; } next++; savedChar = *next; *next = 0; Tcl_AppendResult(interp, cur, "\t", (char *) NULL); *next = savedChar; cur = next; } Tcl_AppendResult(interp, cur, (char *) NULL); } return TCL_OK; } else if ((c == 'k') && (strncmp(argv[1], "keep", length)) == 0) { int count, i, src; HistoryEvent *events; if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " keep number\"", (char *) NULL); return TCL_ERROR; } if (Tcl_GetInt(interp, argv[2], &count) != TCL_OK) { return TCL_ERROR; } if ((count <= 0) || (count > 1000)) { Tcl_AppendResult(interp, "illegal keep count \"", argv[2], "\"", (char *) NULL); return TCL_ERROR; } /* * Create a new history array and copy as much existing history * as possible from the old array. */ events = (HistoryEvent *) ckalloc((unsigned) (count * sizeof(HistoryEvent))); if (count < iPtr->numEvents) { src = iPtr->curEvent + 1 - count; if (src < 0) { src += iPtr->numEvents; } } else { src = iPtr->curEvent + 1; } for (i = 0; i < count; i++, src++) { if (src >= iPtr->numEvents) { src = 0; } if (i < iPtr->numEvents) { events[i] = iPtr->events[src]; iPtr->events[src].command = NULL; } else { events[i].command = (char *) ckalloc(INITIAL_CMD_SIZE); events[i].command[0] = 0; events[i].bytesAvl = INITIAL_CMD_SIZE; } } /* * Throw away everything left in the old history array, and * substitute the new one for the old one. */ for (i = 0; i < iPtr->numEvents; i++) { if (iPtr->events[i].command != NULL) { ckfree(iPtr->events[i].command); } } ckfree((char *) iPtr->events); iPtr->events = events; if (count < iPtr->numEvents) { iPtr->curEvent = count-1; } else { iPtr->curEvent = iPtr->numEvents-1; } iPtr->numEvents = count; return TCL_OK; } else if ((c == 'n') && (strncmp(argv[1], "nextid", length)) == 0) { if (argc != 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " nextid\"", (char *) NULL); return TCL_ERROR; } sprintf(iPtr->result, "%d", iPtr->curEventNum+1); return TCL_OK; } else if ((c == 'r') && (strncmp(argv[1], "redo", length)) == 0) { if (argc > 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " redo ?event?\"", (char *) NULL); return TCL_ERROR; } eventPtr = GetEvent(iPtr, argc==2 ? "-1" : argv[2]); if (eventPtr == NULL) { return TCL_ERROR; } RevCommand(iPtr, eventPtr->command); return Tcl_Eval(interp, eventPtr->command); } else if ((c == 's') && (strncmp(argv[1], "substitute", length)) == 0) { if ((argc > 5) || (argc < 4)) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " substitute old new ?event?\"", (char *) NULL); return TCL_ERROR; } eventPtr = GetEvent(iPtr, argc==4 ? "-1" : argv[4]); if (eventPtr == NULL) { return TCL_ERROR; } return SubsAndEval(iPtr, eventPtr->command, argv[2], argv[3]); } else if ((c == 'w') && (strncmp(argv[1], "words", length)) == 0) { char *words; if ((argc != 3) && (argc != 4)) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " words num-num/pat ?event?\"", (char *) NULL); return TCL_ERROR; } eventPtr = GetEvent(iPtr, argc==3 ? "-1" : argv[3]); if (eventPtr == NULL) { return TCL_ERROR; } words = GetWords(iPtr, eventPtr->command, argv[2]); if (words == NULL) { return TCL_ERROR; } RevResult(iPtr, words); iPtr->result = words; iPtr->freeProc = (Tcl_FreeProc *) free; return TCL_OK; } Tcl_AppendResult(interp, "bad option \"", argv[1], "\": must be add, change, event, info, keep, nextid, ", "redo, substitute, or words", (char *) NULL); return TCL_ERROR; } /* *---------------------------------------------------------------------- * * MakeSpace -- * * Given a history event, make sure it has enough space for * a string of a given length (enlarge the string area if * necessary). * * Results: * None. * * Side effects: * More memory may get allocated. * *---------------------------------------------------------------------- */ static void MakeSpace(hPtr, size) HistoryEvent *hPtr; int size; /* # of bytes needed in hPtr. */ { if (hPtr->bytesAvl < size) { ckfree(hPtr->command); hPtr->command = (char *) ckalloc((unsigned) size); hPtr->bytesAvl = size; } } /* *---------------------------------------------------------------------- * * InsertRev -- * * Add a new revision to the list of those pending for iPtr. * Do it in a way that keeps the revision list sorted in * increasing order of firstIndex. Also, eliminate revisions * that are subsets of other revisions. * * Results: * None. * * Side effects: * RevPtr is added to iPtr's revision list. * *---------------------------------------------------------------------- */ static void InsertRev(iPtr, revPtr) Interp *iPtr; /* Interpreter to use. */ register HistoryRev *revPtr; /* Revision to add to iPtr's list. */ { register HistoryRev *curPtr; register HistoryRev *prevPtr; for (curPtr = iPtr->revPtr, prevPtr = NULL; curPtr != NULL; prevPtr = curPtr, curPtr = curPtr->nextPtr) { /* * If this revision includes the new one (or vice versa) then * just eliminate the one that is a subset of the other. */ if ((revPtr->firstIndex <= curPtr->firstIndex) && (revPtr->lastIndex >= curPtr->firstIndex)) { curPtr->firstIndex = revPtr->firstIndex; curPtr->lastIndex = revPtr->lastIndex; curPtr->newSize = revPtr->newSize; ckfree(curPtr->newBytes); curPtr->newBytes = revPtr->newBytes; ckfree((char *) revPtr); return; } if ((revPtr->firstIndex >= curPtr->firstIndex) && (revPtr->lastIndex <= curPtr->lastIndex)) { ckfree(revPtr->newBytes); ckfree((char *) revPtr); return; } if (revPtr->firstIndex < curPtr->firstIndex) { break; } } /* * Insert revPtr just after prevPtr. */ if (prevPtr == NULL) { revPtr->nextPtr = iPtr->revPtr; iPtr->revPtr = revPtr; } else { revPtr->nextPtr = prevPtr->nextPtr; prevPtr->nextPtr = revPtr; } } /* *---------------------------------------------------------------------- * * RevCommand -- * * This procedure is invoked by the "history" command to record * a command revision. See the comments at the beginning of the * file for more information about revisions. * * Results: * None. * * Side effects: * Revision information is recorded. * *---------------------------------------------------------------------- */ static void RevCommand(iPtr, string) register Interp *iPtr; /* Interpreter in which to perform the * substitution. */ char *string; /* String to substitute. */ { register HistoryRev *revPtr; if ((iPtr->evalFirst == NULL) || (iPtr->revDisables > 0)) { return; } revPtr = (HistoryRev *) ckalloc(sizeof(HistoryRev)); revPtr->firstIndex = iPtr->evalFirst - iPtr->historyFirst; revPtr->lastIndex = iPtr->evalLast - iPtr->historyFirst; revPtr->newSize = strlen(string); revPtr->newBytes = (char *) ckalloc((unsigned) (revPtr->newSize+1)); strcpy(revPtr->newBytes, string); InsertRev(iPtr, revPtr); } /* *---------------------------------------------------------------------- * * RevResult -- * * This procedure is invoked by the "history" command to record * a result revision. See the comments at the beginning of the * file for more information about revisions. * * Results: * None. * * Side effects: * Revision information is recorded. * *---------------------------------------------------------------------- */ static void RevResult(iPtr, string) register Interp *iPtr; /* Interpreter in which to perform the * substitution. */ char *string; /* String to substitute. */ { register HistoryRev *revPtr; char *evalFirst, *evalLast; char *argv[2]; if ((iPtr->evalFirst == NULL) || (iPtr->revDisables > 0)) { return; } /* * Expand the replacement range to include the brackets that surround * the command. If there aren't any brackets (i.e. this command was * invoked at top-level) then don't do any revision. Also, if there * are several commands in brackets, of which this is just one, * then don't do any revision. */ evalFirst = iPtr->evalFirst; evalLast = iPtr->evalLast + 1; while (1) { if (evalFirst == iPtr->historyFirst) { return; } evalFirst--; if (*evalFirst == '[') { break; } if (!isspace(UCHAR(*evalFirst))) { return; } } if (*evalLast != ']') { return; } revPtr = (HistoryRev *) ckalloc(sizeof(HistoryRev)); revPtr->firstIndex = evalFirst - iPtr->historyFirst; revPtr->lastIndex = evalLast - iPtr->historyFirst; argv[0] = string; revPtr->newBytes = Tcl_Merge(1, argv); revPtr->newSize = strlen(revPtr->newBytes); InsertRev(iPtr, revPtr); } /* *---------------------------------------------------------------------- * * DoRevs -- * * This procedure is called to apply the history revisions that * have been recorded in iPtr. * * Results: * None. * * Side effects: * The most recent entry in the history for iPtr may be modified. * *---------------------------------------------------------------------- */ static void DoRevs(iPtr) register Interp *iPtr; /* Interpreter whose history is to * be modified. */ { register HistoryRev *revPtr; register HistoryEvent *eventPtr; char *newCommand, *p; unsigned int size; int bytesSeen, count; if (iPtr->revPtr == NULL) { return; } /* * The revision is done in two passes. The first pass computes the * amount of space needed for the revised event, and the second pass * pieces together the new event and frees up the revisions. */ eventPtr = &iPtr->events[iPtr->curEvent]; size = strlen(eventPtr->command) + 1; for (revPtr = iPtr->revPtr; revPtr != NULL; revPtr = revPtr->nextPtr) { size -= revPtr->lastIndex + 1 - revPtr->firstIndex; size += revPtr->newSize; } newCommand = (char *) ckalloc(size); p = newCommand; bytesSeen = 0; for (revPtr = iPtr->revPtr; revPtr != NULL; ) { HistoryRev *nextPtr = revPtr->nextPtr; count = revPtr->firstIndex - bytesSeen; if (count > 0) { strncpy(p, eventPtr->command + bytesSeen, (size_t) count); p += count; } strncpy(p, revPtr->newBytes, (size_t) revPtr->newSize); p += revPtr->newSize; bytesSeen = revPtr->lastIndex+1; ckfree(revPtr->newBytes); ckfree((char *) revPtr); revPtr = nextPtr; } strcpy(p, eventPtr->command + bytesSeen); /* * Replace the command in the event. */ ckfree(eventPtr->command); eventPtr->command = newCommand; eventPtr->bytesAvl = size; iPtr->revPtr = NULL; } /* *---------------------------------------------------------------------- * * GetEvent -- * * Given a textual description of an event (see the manual page * for legal values) find the corresponding event and return its * command string. * * Results: * The return value is a pointer to the event named by "string". * If no such event exists, then NULL is returned and an error * message is left in iPtr. * * Side effects: * None. * *---------------------------------------------------------------------- */ static HistoryEvent * GetEvent(iPtr, string) register Interp *iPtr; /* Interpreter in which to look. */ char *string; /* Description of event. */ { int eventNum, index; register HistoryEvent *eventPtr; int length; /* * First check for a numeric specification of an event. */ if (isdigit(UCHAR(*string)) || (*string == '-')) { if (Tcl_GetInt((Tcl_Interp *) iPtr, string, &eventNum) != TCL_OK) { return NULL; } if (eventNum < 0) { eventNum += iPtr->curEventNum; } if (eventNum > iPtr->curEventNum) { Tcl_AppendResult((Tcl_Interp *) iPtr, "event \"", string, "\" hasn't occurred yet", (char *) NULL); return NULL; } if ((eventNum <= iPtr->curEventNum-iPtr->numEvents) || (eventNum <= 0)) { Tcl_AppendResult((Tcl_Interp *) iPtr, "event \"", string, "\" is too far in the past", (char *) NULL); return NULL; } index = iPtr->curEvent + (eventNum - iPtr->curEventNum); if (index < 0) { index += iPtr->numEvents; } return &iPtr->events[index]; } /* * Next, check for an event that contains the string as a prefix or * that matches the string in the sense of Tcl_StringMatch. */ length = strlen(string); for (index = iPtr->curEvent - 1; ; index--) { if (index < 0) { index += iPtr->numEvents; } if (index == iPtr->curEvent) { break; } eventPtr = &iPtr->events[index]; if ((strncmp(eventPtr->command, string, (size_t) length) == 0) || Tcl_StringMatch(eventPtr->command, string)) { return eventPtr; } } Tcl_AppendResult((Tcl_Interp *) iPtr, "no event matches \"", string, "\"", (char *) NULL); return NULL; } /* *---------------------------------------------------------------------- * * SubsAndEval -- * * Generate a new command by making a textual substitution in * the "cmd" argument. Then execute the new command. * * Results: * The return value is a standard Tcl error. * * Side effects: * History gets revised if the substitution is occurring on * a recorded command line. Also, the re-executed command * may produce side-effects. * *---------------------------------------------------------------------- */ static int SubsAndEval(iPtr, cmd, old, new) register Interp *iPtr; /* Interpreter in which to execute * new command. */ char *cmd; /* Command in which to substitute. */ char *old; /* String to search for in command. */ char *new; /* Replacement string for "old". */ { char *src, *dst, *newCmd; int count, oldLength, newLength, length, result; /* * Figure out how much space it will take to hold the * substituted command (and complain if the old string * doesn't appear in the original command). */ oldLength = strlen(old); newLength = strlen(new); src = cmd; count = 0; while (1) { src = strstr(src, old); if (src == NULL) { break; } src += oldLength; count++; } if (count == 0) { Tcl_AppendResult((Tcl_Interp *) iPtr, "\"", old, "\" doesn't appear in event", (char *) NULL); return TCL_ERROR; } length = strlen(cmd) + count*(newLength - oldLength); /* * Generate a substituted command. */ newCmd = (char *) ckalloc((unsigned) (length + 1)); dst = newCmd; while (1) { src = strstr(cmd, old); if (src == NULL) { strcpy(dst, cmd); break; } strncpy(dst, cmd, (size_t) (src-cmd)); dst += src-cmd; strcpy(dst, new); dst += newLength; cmd = src + oldLength; } RevCommand(iPtr, newCmd); result = Tcl_Eval((Tcl_Interp *) iPtr, newCmd); ckfree(newCmd); return result; } /* *---------------------------------------------------------------------- * * GetWords -- * * Given a command string, return one or more words from the * command string. * * Results: * The return value is a pointer to a dynamically-allocated * string containing the words of command specified by "words". * If the word specifier has improper syntax then an error * message is placed in iPtr->result and NULL is returned. * * Side effects: * Memory is allocated. It is the caller's responsibilty to * free the returned string.. * *---------------------------------------------------------------------- */ static char * GetWords(iPtr, command, words) register Interp *iPtr; /* Tcl interpreter in which to place * an error message if needed. */ char *command; /* Command string. */ char *words; /* Description of which words to extract * from the command. Either num[-num] or * a pattern. */ { char *result; char *start, *end, *dst; register char *next; int first; /* First word desired. -1 means last word * only. */ int last; /* Last word desired. -1 means use everything * up to the end. */ int index; /* Index of current word. */ char *pattern; /* * Figure out whether we're looking for a numerical range or for * a pattern. */ pattern = NULL; first = 0; last = -1; if (*words == '$') { if (words[1] != '\0') { goto error; } first = -1; } else if (isdigit(UCHAR(*words))) { first = strtoul(words, &start, 0); if (*start == 0) { last = first; } else if (*start == '-') { start++; if (*start == '$') { start++; } else if (isdigit(UCHAR(*start))) { last = strtoul(start, &start, 0); } else { goto error; } if (*start != 0) { goto error; } } if ((first > last) && (last != -1)) { goto error; } } else { pattern = words; } /* * Scan through the words one at a time, copying those that are * relevant into the result string. Allocate a result area large * enough to hold all the words if necessary. */ result = (char *) ckalloc((unsigned) (strlen(command) + 1)); dst = result; for (next = command; isspace(UCHAR(*next)); next++) { /* Empty loop body: just find start of first word. */ } for (index = 0; *next != 0; index++) { start = next; end = TclWordEnd(next, 0, (int *) NULL); if (*end != 0) { end++; for (next = end; isspace(UCHAR(*next)); next++) { /* Empty loop body: just find start of next word. */ } } if ((first > index) || ((first == -1) && (*next != 0))) { continue; } if ((last != -1) && (last < index)) { continue; } if (pattern != NULL) { int match; char savedChar = *end; *end = 0; match = Tcl_StringMatch(start, pattern); *end = savedChar; if (!match) { continue; } } if (dst != result) { *dst = ' '; dst++; } strncpy(dst, start, (size_t) (end-start)); dst += end-start; } *dst = 0; /* * Check for an out-of-range argument index. */ if ((last >= index) || (first >= index)) { ckfree(result); Tcl_AppendResult((Tcl_Interp *) iPtr, "word selector \"", words, "\" specified non-existent words", (char *) NULL); return NULL; } return result; error: Tcl_AppendResult((Tcl_Interp *) iPtr, "bad word selector \"", words, "\": should be num-num or pattern", (char *) NULL); return NULL; } * then don't do any revision. */ evalFirst = iPtr->evalFirst; evalLast = iPtr->evalLast + 1; while (1) { if (evalFirst == iPtr->historyFirst) { return; } evalFirst--; if (*evalFirst == '[') { break; } if (!isspace(UCHAR(*evalFirst))) { return; } } if (*evalLast != ']tcl7.4b4/tclLink.c010044400630510000012000000250200567467740500146110ustar00ousterstaff00002300000001/* * tclLink.c -- * * This file implements linked variables (a C variable that is * tied to a Tcl variable). The idea of linked variables was * first suggested by Andreas Stolcke and this implementation is * based heavily on a prototype implementation provided by * him. * * Copyright (c) 1993 The Regents of the University of California. * Copyright (c) 1994 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #ifndef lint static char sccsid[] = "@(#) tclLink.c 1.9 94/12/17 16:14:21"; #endif /* not lint */ #include "tclInt.h" /* * For each linked variable there is a data structure of the following * type, which describes the link and is the clientData for the trace * set on the Tcl variable. */ typedef struct Link { Tcl_Interp *interp; /* Interpreter containing Tcl variable. */ char *varName; /* Name of variable (must be global). This * is needed during trace callbacks, since * the actual variable may be aliased at * that time via upvar. */ char *addr; /* Location of C variable. */ int type; /* Type of link (TCL_LINK_INT, etc.). */ int writable; /* Zero means Tcl variable is read-only. */ union { int i; double d; } lastValue; /* Last known value of C variable; used to * avoid string conversions. */ } Link; /* * Forward references to procedures defined later in this file: */ static char * LinkTraceProc _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, char *name1, char *name2, int flags)); static char * StringValue _ANSI_ARGS_((Link *linkPtr, char *buffer)); /* *---------------------------------------------------------------------- * * Tcl_LinkVar -- * * Link a C variable to a Tcl variable so that changes to either * one causes the other to change. * * Results: * The return value is TCL_OK if everything went well or TCL_ERROR * if an error occurred (interp->result is also set after errors). * * Side effects: * The value at *addr is linked to the Tcl variable "varName", * using "type" to convert between string values for Tcl and * binary values for *addr. * *---------------------------------------------------------------------- */ int Tcl_LinkVar(interp, varName, addr, type) Tcl_Interp *interp; /* Interpreter in which varName exists. */ char *varName; /* Name of a global variable in interp. */ char *addr; /* Address of a C variable to be linked * to varName. */ int type; /* Type of C variable: TCL_LINK_INT, etc. * Also may have TCL_LINK_READ_ONLY * OR'ed in. */ { Link *linkPtr; char buffer[TCL_DOUBLE_SPACE]; int code; linkPtr = (Link *) ckalloc(sizeof(Link)); linkPtr->interp = interp; linkPtr->varName = ckalloc((unsigned) (strlen(varName) + 1)); strcpy(linkPtr->varName, varName); linkPtr->addr = addr; linkPtr->type = type & ~TCL_LINK_READ_ONLY; linkPtr->writable = (type & TCL_LINK_READ_ONLY) == 0; if (Tcl_SetVar(interp, varName, StringValue(linkPtr, buffer), TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) { ckfree(linkPtr->varName); ckfree((char *) linkPtr); return TCL_ERROR; } code = Tcl_TraceVar(interp, varName, TCL_GLOBAL_ONLY|TCL_TRACE_READS |TCL_TRACE_WRITES|TCL_TRACE_UNSETS, LinkTraceProc, (ClientData) linkPtr); if (code != TCL_OK) { ckfree(linkPtr->varName); ckfree((char *) linkPtr); } return code; } /* *---------------------------------------------------------------------- * * Tcl_UnlinkVar -- * * Destroy the link between a Tcl variable and a C variable. * * Results: * None. * * Side effects: * If "varName" was previously linked to a C variable, the link * is broken to make the variable independent. If there was no * previous link for "varName" then nothing happens. * *---------------------------------------------------------------------- */ void Tcl_UnlinkVar(interp, varName) Tcl_Interp *interp; /* Interpreter containing variable to unlink. */ char *varName; /* Global variable in interp to unlink. */ { Link *linkPtr; linkPtr = (Link *) Tcl_VarTraceInfo(interp, varName, TCL_GLOBAL_ONLY, LinkTraceProc, (ClientData) NULL); if (linkPtr == NULL) { return; } Tcl_UntraceVar(interp, varName, TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, LinkTraceProc, (ClientData) linkPtr); ckfree(linkPtr->varName); ckfree((char *) linkPtr); } /* *---------------------------------------------------------------------- * * LinkTraceProc -- * * This procedure is invoked when a linked Tcl variable is read, * written, or unset from Tcl. It's responsible for keeping the * C variable in sync with the Tcl variable. * * Results: * If all goes well, NULL is returned; otherwise an error message * is returned. * * Side effects: * The C variable may be updated to make it consistent with the * Tcl variable, or the Tcl variable may be overwritten to reject * a modification. * *---------------------------------------------------------------------- */ static char * LinkTraceProc(clientData, interp, name1, name2, flags) ClientData clientData; /* Contains information about the link. */ Tcl_Interp *interp; /* Interpreter containing Tcl variable. */ char *name1; /* First part of variable name. */ char *name2; /* Second part of variable name. */ int flags; /* Miscellaneous additional information. */ { Link *linkPtr = (Link *) clientData; int changed; char buffer[TCL_DOUBLE_SPACE]; char *value, **pp; Tcl_DString savedResult; /* * If the variable is being unset, then just re-create it (with a * trace) unless the whole interpreter is going away. */ if (flags & TCL_TRACE_UNSETS) { if (flags & TCL_INTERP_DESTROYED) { ckfree(linkPtr->varName); ckfree((char *) linkPtr); } else if (flags & TCL_TRACE_DESTROYED) { Tcl_SetVar(interp, linkPtr->varName, StringValue(linkPtr, buffer), TCL_GLOBAL_ONLY); Tcl_TraceVar(interp, linkPtr->varName, TCL_GLOBAL_ONLY |TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, LinkTraceProc, (ClientData) linkPtr); } return NULL; } /* * For read accesses, update the Tcl variable if the C variable * has changed since the last time we updated the Tcl variable. */ if (flags & TCL_TRACE_READS) { switch (linkPtr->type) { case TCL_LINK_INT: case TCL_LINK_BOOLEAN: changed = *(int *)(linkPtr->addr) != linkPtr->lastValue.i; break; case TCL_LINK_DOUBLE: changed = *(double *)(linkPtr->addr) != linkPtr->lastValue.d; break; case TCL_LINK_STRING: changed = 1; break; default: return "internal error: bad linked variable type"; } if (changed) { Tcl_SetVar(interp, linkPtr->varName, StringValue(linkPtr, buffer), TCL_GLOBAL_ONLY); } return NULL; } /* * For writes, first make sure that the variable is writable. Then * convert the Tcl value to C if possible. If the variable isn't * writable or can't be converted, then restore the varaible's old * value and return an error. Another tricky thing: we have to save * and restore the interpreter's result, since the variable access * could occur when the result has been partially set. */ if (!linkPtr->writable) { Tcl_SetVar(interp, linkPtr->varName, StringValue(linkPtr, buffer), TCL_GLOBAL_ONLY); return "linked variable is read-only"; } value = Tcl_GetVar(interp, linkPtr->varName, TCL_GLOBAL_ONLY); if (value == NULL) { /* * This shouldn't ever happen. */ return "internal error: linked variable couldn't be read"; } Tcl_DStringInit(&savedResult); Tcl_DStringAppend(&savedResult, interp->result, -1); Tcl_ResetResult(interp); switch (linkPtr->type) { case TCL_LINK_INT: if (Tcl_GetInt(interp, value, &linkPtr->lastValue.i) != TCL_OK) { Tcl_DStringResult(interp, &savedResult); Tcl_SetVar(interp, linkPtr->varName, StringValue(linkPtr, buffer), TCL_GLOBAL_ONLY); return "variable must have integer value"; } *(int *)(linkPtr->addr) = linkPtr->lastValue.i; break; case TCL_LINK_DOUBLE: if (Tcl_GetDouble(interp, value, &linkPtr->lastValue.d) != TCL_OK) { Tcl_DStringResult(interp, &savedResult); Tcl_SetVar(interp, linkPtr->varName, StringValue(linkPtr, buffer), TCL_GLOBAL_ONLY); return "variable must have real value"; } *(double *)(linkPtr->addr) = linkPtr->lastValue.d; break; case TCL_LINK_BOOLEAN: if (Tcl_GetBoolean(interp, value, &linkPtr->lastValue.i) != TCL_OK) { Tcl_DStringResult(interp, &savedResult); Tcl_SetVar(interp, linkPtr->varName, StringValue(linkPtr, buffer), TCL_GLOBAL_ONLY); return "variable must have boolean value"; } *(int *)(linkPtr->addr) = linkPtr->lastValue.i; break; case TCL_LINK_STRING: pp = (char **)(linkPtr->addr); if (*pp != NULL) { ckfree(*pp); } *pp = ckalloc((unsigned) (strlen(value) + 1)); strcpy(*pp, value); break; default: return "internal error: bad linked variable type"; } Tcl_DStringResult(interp, &savedResult); return NULL; } /* *---------------------------------------------------------------------- * * StringValue -- * * Converts the value of a C variable to a string for use in a * Tcl variable to which it is linked. * * Results: * The return value is a pointer to a string that represents * the value of the C variable given by linkPtr. * * Side effects: * None. * *---------------------------------------------------------------------- */ static char * StringValue(linkPtr, buffer) Link *linkPtr; /* Structure describing linked variable. */ char *buffer; /* Small buffer to use for converting * values. Must have TCL_DOUBLE_SPACE * bytes or more. */ { char *p; switch (linkPtr->type) { case TCL_LINK_INT: linkPtr->lastValue.i = *(int *)(linkPtr->addr); sprintf(buffer, "%d", linkPtr->lastValue.i); return buffer; case TCL_LINK_DOUBLE: linkPtr->lastValue.d = *(double *)(linkPtr->addr); Tcl_PrintDouble(linkPtr->interp, linkPtr->lastValue.d, buffer); return buffer; case TCL_LINK_BOOLEAN: linkPtr->lastValue.i = *(int *)(linkPtr->addr); if (linkPtr->lastValue.i != 0) { return "1"; } return "0"; case TCL_LINK_STRING: p = *(char **)(linkPtr->addr); if (p == NULL) { return "NULL"; } return p; } /* * This code only gets executed if the link type is unknown * (shouldn't ever happen). */ return "??"; } tcl7.4b4/tclParse.c010044400630510000012000001115070574500244700147570ustar00ousterstaff00002300000001/* * tclParse.c -- * * This file contains a collection of procedures that are used * to parse Tcl commands or parts of commands (like quoted * strings or nested sub-commands). * * Copyright (c) 1987-1993 The Regents of the University of California. * Copyright (c) 1994-1995 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #ifndef lint static char sccsid[] = "@(#) tclParse.c 1.44 95/04/18 11:30:00"; #endif #include "tclInt.h" #include "tclPort.h" /* * The following table assigns a type to each character. Only types * meaningful to Tcl parsing are represented here. The table is * designed to be referenced with either signed or unsigned characters, * so it has 384 entries. The first 128 entries correspond to negative * character values, the next 256 correspond to positive character * values. The last 128 entries are identical to the first 128. The * table is always indexed with a 128-byte offset (the 128th entry * corresponds to a 0 character value). */ char tclTypeTable[] = { /* * Negative character values, from -128 to -1: */ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, /* * Positive character values, from 0-127: */ TCL_COMMAND_END, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_SPACE, TCL_COMMAND_END, TCL_SPACE, TCL_SPACE, TCL_SPACE, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_SPACE, TCL_NORMAL, TCL_QUOTE, TCL_NORMAL, TCL_DOLLAR, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_COMMAND_END, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_OPEN_BRACKET, TCL_BACKSLASH, TCL_COMMAND_END, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_OPEN_BRACE, TCL_NORMAL, TCL_CLOSE_BRACE, TCL_NORMAL, TCL_NORMAL, /* * Large unsigned character values, from 128-255: */ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, }; /* * Function prototypes for procedures local to this file: */ static char * QuoteEnd _ANSI_ARGS_((char *string, int term)); static char * VarNameEnd _ANSI_ARGS_((char *string)); /* *---------------------------------------------------------------------- * * Tcl_Backslash -- * * Figure out how to handle a backslash sequence. * * Results: * The return value is the character that should be substituted * in place of the backslash sequence that starts at src. If * readPtr isn't NULL then it is filled in with a count of the * number of characters in the backslash sequence. * * Side effects: * None. * *---------------------------------------------------------------------- */ char Tcl_Backslash(src, readPtr) char *src; /* Points to the backslash character of * a backslash sequence. */ int *readPtr; /* Fill in with number of characters read * from src, unless NULL. */ { register char *p = src+1; char result; int count; count = 2; switch (*p) { case 'a': result = 0x7; /* Don't say '\a' here, since some compilers */ break; /* don't support it. */ case 'b': result = '\b'; break; case 'f': result = '\f'; break; case 'n': result = '\n'; break; case 'r': result = '\r'; break; case 't': result = '\t'; break; case 'v': result = '\v'; break; case 'x': if (isxdigit(UCHAR(p[1]))) { char *end; result = strtoul(p+1, &end, 16); count = end - src; } else { count = 2; result = 'x'; } break; case '\n': do { p++; } while (isspace(UCHAR(*p))); result = ' '; count = p - src; break; case 0: result = '\\'; count = 1; break; default: if (isdigit(UCHAR(*p))) { result = *p - '0'; p++; if (!isdigit(UCHAR(*p))) { break; } count = 3; result = (result << 3) + (*p - '0'); p++; if (!isdigit(UCHAR(*p))) { break; } count = 4; result = (result << 3) + (*p - '0'); break; } result = *p; count = 2; break; } if (readPtr != NULL) { *readPtr = count; } return result; } /* *-------------------------------------------------------------- * * TclParseQuotes -- * * This procedure parses a double-quoted string such as a * quoted Tcl command argument or a quoted value in a Tcl * expression. This procedure is also used to parse array * element names within parentheses, or anything else that * needs all the substitutions that happen in quotes. * * Results: * The return value is a standard Tcl result, which is * TCL_OK unless there was an error while parsing the * quoted string. If an error occurs then interp->result * contains a standard error message. *TermPtr is filled * in with the address of the character just after the * last one successfully processed; this is usually the * character just after the matching close-quote. The * fully-substituted contents of the quotes are stored in * standard fashion in *pvPtr, null-terminated with * pvPtr->next pointing to the terminating null character. * * Side effects: * The buffer space in pvPtr may be enlarged by calling its * expandProc. * *-------------------------------------------------------------- */ int TclParseQuotes(interp, string, termChar, flags, termPtr, pvPtr) Tcl_Interp *interp; /* Interpreter to use for nested command * evaluations and error messages. */ char *string; /* Character just after opening double- * quote. */ int termChar; /* Character that terminates "quoted" string * (usually double-quote, but sometimes * right-paren or something else). */ int flags; /* Flags to pass to nested Tcl_Eval calls. */ char **termPtr; /* Store address of terminating character * here. */ ParseValue *pvPtr; /* Information about where to place * fully-substituted result of parse. */ { register char *src, *dst, c; src = string; dst = pvPtr->next; while (1) { if (dst == pvPtr->end) { /* * Target buffer space is about to run out. Make more space. */ pvPtr->next = dst; (*pvPtr->expandProc)(pvPtr, 1); dst = pvPtr->next; } c = *src; src++; if (c == termChar) { *dst = '\0'; pvPtr->next = dst; *termPtr = src; return TCL_OK; } else if (CHAR_TYPE(c) == TCL_NORMAL) { copy: *dst = c; dst++; continue; } else if (c == '$') { int length; char *value; value = Tcl_ParseVar(interp, src-1, termPtr); if (value == NULL) { return TCL_ERROR; } src = *termPtr; length = strlen(value); if ((pvPtr->end - dst) <= length) { pvPtr->next = dst; (*pvPtr->expandProc)(pvPtr, length); dst = pvPtr->next; } strcpy(dst, value); dst += length; continue; } else if (c == '[') { int result; pvPtr->next = dst; result = TclParseNestedCmd(interp, src, flags, termPtr, pvPtr); if (result != TCL_OK) { return result; } src = *termPtr; dst = pvPtr->next; continue; } else if (c == '\\') { int numRead; src--; *dst = Tcl_Backslash(src, &numRead); dst++; src += numRead; continue; } else if (c == '\0') { Tcl_ResetResult(interp); sprintf(interp->result, "missing %c", termChar); *termPtr = string-1; return TCL_ERROR; } else { goto copy; } } } /* *-------------------------------------------------------------- * * TclParseNestedCmd -- * * This procedure parses a nested Tcl command between * brackets, returning the result of the command. * * Results: * The return value is a standard Tcl result, which is * TCL_OK unless there was an error while executing the * nested command. If an error occurs then interp->result * contains a standard error message. *TermPtr is filled * in with the address of the character just after the * last one processed; this is usually the character just * after the matching close-bracket, or the null character * at the end of the string if the close-bracket was missing * (a missing close bracket is an error). The result returned * by the command is stored in standard fashion in *pvPtr, * null-terminated, with pvPtr->next pointing to the null * character. * * Side effects: * The storage space at *pvPtr may be expanded. * *-------------------------------------------------------------- */ int TclParseNestedCmd(interp, string, flags, termPtr, pvPtr) Tcl_Interp *interp; /* Interpreter to use for nested command * evaluations and error messages. */ char *string; /* Character just after opening bracket. */ int flags; /* Flags to pass to nested Tcl_Eval. */ char **termPtr; /* Store address of terminating character * here. */ register ParseValue *pvPtr; /* Information about where to place * result of command. */ { int result, length, shortfall; Interp *iPtr = (Interp *) interp; iPtr->evalFlags = flags | TCL_BRACKET_TERM; result = Tcl_Eval(interp, string); *termPtr = iPtr->termPtr; if (result != TCL_OK) { /* * The increment below results in slightly cleaner message in * the errorInfo variable (the close-bracket will appear). */ if (**termPtr == ']') { *termPtr += 1; } return result; } (*termPtr) += 1; length = strlen(iPtr->result); shortfall = length + 1 - (pvPtr->end - pvPtr->next); if (shortfall > 0) { (*pvPtr->expandProc)(pvPtr, shortfall); } strcpy(pvPtr->next, iPtr->result); pvPtr->next += length; Tcl_FreeResult(iPtr); iPtr->result = iPtr->resultSpace; iPtr->resultSpace[0] = '\0'; return TCL_OK; } /* *-------------------------------------------------------------- * * TclParseBraces -- * * This procedure scans the information between matching * curly braces. * * Results: * The return value is a standard Tcl result, which is * TCL_OK unless there was an error while parsing string. * If an error occurs then interp->result contains a * standard error message. *TermPtr is filled * in with the address of the character just after the * last one successfully processed; this is usually the * character just after the matching close-brace. The * information between curly braces is stored in standard * fashion in *pvPtr, null-terminated with pvPtr->next * pointing to the terminating null character. * * Side effects: * The storage space at *pvPtr may be expanded. * *-------------------------------------------------------------- */ int TclParseBraces(interp, string, termPtr, pvPtr) Tcl_Interp *interp; /* Interpreter to use for nested command * evaluations and error messages. */ char *string; /* Character just after opening bracket. */ char **termPtr; /* Store address of terminating character * here. */ register ParseValue *pvPtr; /* Information about where to place * result of command. */ { int level; register char *src, *dst, *end; register char c; src = string; dst = pvPtr->next; end = pvPtr->end; level = 1; /* * Copy the characters one at a time to the result area, stopping * when the matching close-brace is found. */ while (1) { c = *src; src++; if (dst == end) { pvPtr->next = dst; (*pvPtr->expandProc)(pvPtr, 20); dst = pvPtr->next; end = pvPtr->end; } *dst = c; dst++; if (CHAR_TYPE(c) == TCL_NORMAL) { continue; } else if (c == '{') { level++; } else if (c == '}') { level--; if (level == 0) { dst--; /* Don't copy the last close brace. */ break; } } else if (c == '\\') { int count; /* * Must always squish out backslash-newlines, even when in * braces. This is needed so that this sequence can appear * anywhere in a command, such as the middle of an expression. */ if (*src == '\n') { dst[-1] = Tcl_Backslash(src-1, &count); src += count - 1; } else { (void) Tcl_Backslash(src-1, &count); while (count > 1) { if (dst == end) { pvPtr->next = dst; (*pvPtr->expandProc)(pvPtr, 20); dst = pvPtr->next; end = pvPtr->end; } *dst = *src; dst++; src++; count--; } } } else if (c == '\0') { Tcl_SetResult(interp, "missing close-brace", TCL_STATIC); *termPtr = string-1; return TCL_ERROR; } } *dst = '\0'; pvPtr->next = dst; *termPtr = src; return TCL_OK; } /* *-------------------------------------------------------------- * * TclParseWords -- * * This procedure parses one or more words from a command * string and creates argv-style pointers to fully-substituted * copies of those words. * * Results: * The return value is a standard Tcl result. * * *argcPtr is modified to hold a count of the number of words * successfully parsed, which may be 0. At most maxWords words * will be parsed. If 0 <= *argcPtr < maxWords then it * means that a command separator was seen. If *argcPtr * is maxWords then it means that a command separator was * not seen yet. * * *TermPtr is filled in with the address of the character * just after the last one successfully processed in the * last word. This is either the command terminator (if * *argcPtr < maxWords), the character just after the last * one in a word (if *argcPtr is maxWords), or the vicinity * of an error (if the result is not TCL_OK). * * The pointers at *argv are filled in with pointers to the * fully-substituted words, and the actual contents of the * words are copied to the buffer at pvPtr. * * If an error occurrs then an error message is left in * interp->result and the information at *argv, *argcPtr, * and *pvPtr may be incomplete. * * Side effects: * The buffer space in pvPtr may be enlarged by calling its * expandProc. * *-------------------------------------------------------------- */ int TclParseWords(interp, string, flags, maxWords, termPtr, argcPtr, argv, pvPtr) Tcl_Interp *interp; /* Interpreter to use for nested command * evaluations and error messages. */ char *string; /* First character of word. */ int flags; /* Flags to control parsing (same values as * passed to Tcl_Eval). */ int maxWords; /* Maximum number of words to parse. */ char **termPtr; /* Store address of terminating character * here. */ int *argcPtr; /* Filled in with actual number of words * parsed. */ char **argv; /* Store addresses of individual words here. */ register ParseValue *pvPtr; /* Information about where to place * fully-substituted word. */ { register char *src, *dst; register char c; int type, result, argc; char *oldBuffer; /* Used to detect when pvPtr's buffer gets * reallocated, so we can adjust all of the * argv pointers. */ src = string; oldBuffer = pvPtr->buffer; dst = pvPtr->next; for (argc = 0; argc < maxWords; argc++) { argv[argc] = dst; /* * Skip leading space. */ skipSpace: c = *src; type = CHAR_TYPE(c); while (type == TCL_SPACE) { src++; c = *src; type = CHAR_TYPE(c); } /* * Handle the normal case (i.e. no leading double-quote or brace). */ if (type == TCL_NORMAL) { normalArg: while (1) { if (dst == pvPtr->end) { /* * Target buffer space is about to run out. Make * more space. */ pvPtr->next = dst; (*pvPtr->expandProc)(pvPtr, 1); dst = pvPtr->next; } if (type == TCL_NORMAL) { copy: *dst = c; dst++; src++; } else if (type == TCL_SPACE) { goto wordEnd; } else if (type == TCL_DOLLAR) { int length; char *value; value = Tcl_ParseVar(interp, src, termPtr); if (value == NULL) { return TCL_ERROR; } src = *termPtr; length = strlen(value); if ((pvPtr->end - dst) <= length) { pvPtr->next = dst; (*pvPtr->expandProc)(pvPtr, length); dst = pvPtr->next; } strcpy(dst, value); dst += length; } else if (type == TCL_COMMAND_END) { if ((c == ']') && !(flags & TCL_BRACKET_TERM)) { goto copy; } /* * End of command; simulate a word-end first, so * that the end-of-command can be processed as the * first thing in a new word. */ goto wordEnd; } else if (type == TCL_OPEN_BRACKET) { pvPtr->next = dst; result = TclParseNestedCmd(interp, src+1, flags, termPtr, pvPtr); if (result != TCL_OK) { return result; } src = *termPtr; dst = pvPtr->next; } else if (type == TCL_BACKSLASH) { int numRead; *dst = Tcl_Backslash(src, &numRead); /* * The following special check allows a backslash-newline * to be treated as a word-separator, as if the backslash * and newline had been collapsed before command parsing * began. */ if (src[1] == '\n') { src += numRead; goto wordEnd; } src += numRead; dst++; } else { goto copy; } c = *src; type = CHAR_TYPE(c); } } else { /* * Check for the end of the command. */ if (type == TCL_COMMAND_END) { if (flags & TCL_BRACKET_TERM) { if (c == '\0') { Tcl_SetResult(interp, "missing close-bracket", TCL_STATIC); return TCL_ERROR; } } else { if (c == ']') { goto normalArg; } } goto done; } /* * Now handle the special cases: open braces, double-quotes, * and backslash-newline. */ pvPtr->next = dst; if (type == TCL_QUOTE) { result = TclParseQuotes(interp, src+1, '"', flags, termPtr, pvPtr); } else if (type == TCL_OPEN_BRACE) { result = TclParseBraces(interp, src+1, termPtr, pvPtr); } else if ((type == TCL_BACKSLASH) && (src[1] == '\n')) { /* * This code is needed so that a backslash-newline at the * very beginning of a word is treated as part of the white * space between words and not as a space within the word. */ src += 2; goto skipSpace; } else { goto normalArg; } if (result != TCL_OK) { return result; } /* * Back from quotes or braces; make sure that the terminating * character was the end of the word. */ c = **termPtr; if ((c == '\\') && ((*termPtr)[1] == '\n')) { /* * Line is continued on next line; the backslash-newline * sequence turns into space, which is OK. No need to do * anything here. */ } else { type = CHAR_TYPE(c); if ((type != TCL_SPACE) && (type != TCL_COMMAND_END)) { if (*src == '"') { Tcl_SetResult(interp, "extra characters after close-quote", TCL_STATIC); } else { Tcl_SetResult(interp, "extra characters after close-brace", TCL_STATIC); } return TCL_ERROR; } } src = *termPtr; dst = pvPtr->next; } /* * We're at the end of a word, so add a null terminator. Then * see if the buffer was re-allocated during this word. If so, * update all of the argv pointers. */ wordEnd: *dst = '\0'; dst++; if (oldBuffer != pvPtr->buffer) { int i; for (i = 0; i <= argc; i++) { argv[i] = pvPtr->buffer + (argv[i] - oldBuffer); } oldBuffer = pvPtr->buffer; } } done: pvPtr->next = dst; *termPtr = src; *argcPtr = argc; return TCL_OK; } /* *-------------------------------------------------------------- * * TclExpandParseValue -- * * This procedure is commonly used as the value of the * expandProc in a ParseValue. It uses malloc to allocate * more space for the result of a parse. * * Results: * The buffer space in *pvPtr is reallocated to something * larger, and if pvPtr->clientData is non-zero the old * buffer is freed. Information is copied from the old * buffer to the new one. * * Side effects: * None. * *-------------------------------------------------------------- */ void TclExpandParseValue(pvPtr, needed) register ParseValue *pvPtr; /* Information about buffer that * must be expanded. If the clientData * in the structure is non-zero, it * means that the current buffer is * dynamically allocated. */ int needed; /* Minimum amount of additional space * to allocate. */ { int newSpace; char *new; /* * Either double the size of the buffer or add enough new space * to meet the demand, whichever produces a larger new buffer. */ newSpace = (pvPtr->end - pvPtr->buffer) + 1; if (newSpace < needed) { newSpace += needed; } else { newSpace += newSpace; } new = (char *) ckalloc((unsigned) newSpace); /* * Copy from old buffer to new, free old buffer if needed, and * mark new buffer as malloc-ed. */ memcpy((VOID *) new, (VOID *) pvPtr->buffer, (size_t) (pvPtr->next - pvPtr->buffer)); pvPtr->next = new + (pvPtr->next - pvPtr->buffer); if (pvPtr->clientData != 0) { ckfree(pvPtr->buffer); } pvPtr->buffer = new; pvPtr->end = new + newSpace - 1; pvPtr->clientData = (ClientData) 1; } /* *---------------------------------------------------------------------- * * TclWordEnd -- * * Given a pointer into a Tcl command, find the end of the next * word of the command. * * Results: * The return value is a pointer to the last character that's part * of the word pointed to by "start". If the word doesn't end * properly within the string then the return value is the address * of the null character at the end of the string. * * Side effects: * None. * *---------------------------------------------------------------------- */ char * TclWordEnd(start, nested, semiPtr) char *start; /* Beginning of a word of a Tcl command. */ int nested; /* Zero means this is a top-level command. * One means this is a nested command (close * brace is a word terminator). */ int *semiPtr; /* Set to 1 if word ends with a command- * terminating semi-colon, zero otherwise. * If NULL then ignored. */ { register char *p; int count; if (semiPtr != NULL) { *semiPtr = 0; } /* * Skip leading white space (backslash-newline must be treated like * white-space, except that it better not be the last thing in the * command). */ for (p = start; ; p++) { if (isspace(UCHAR(*p))) { continue; } if ((p[0] == '\\') && (p[1] == '\n')) { if (p[2] == 0) { return p+2; } continue; } break; } /* * Handle words beginning with a double-quote or a brace. */ if (*p == '"') { p = QuoteEnd(p+1, '"'); if (*p == 0) { return p; } p++; } else if (*p == '{') { int braces = 1; while (braces != 0) { p++; while (*p == '\\') { (void) Tcl_Backslash(p, &count); p += count; } if (*p == '}') { braces--; } else if (*p == '{') { braces++; } else if (*p == 0) { return p; } } p++; } /* * Handle words that don't start with a brace or double-quote. * This code is also invoked if the word starts with a brace or * double-quote and there is garbage after the closing brace or * quote. This is an error as far as Tcl_Eval is concerned, but * for here the garbage is treated as part of the word. */ while (1) { if (*p == '[') { for (p++; *p != ']'; p++) { p = TclWordEnd(p, 1, (int *) NULL); if (*p == 0) { return p; } } p++; } else if (*p == '\\') { (void) Tcl_Backslash(p, &count); p += count; if ((*p == 0) && (count == 2) && (p[-1] == '\n')) { return p; } } else if (*p == '$') { p = VarNameEnd(p); if (*p == 0) { return p; } p++; } else if (*p == ';') { /* * Include the semi-colon in the word that is returned. */ if (semiPtr != NULL) { *semiPtr = 1; } return p; } else if (isspace(UCHAR(*p))) { return p-1; } else if ((*p == ']') && nested) { return p-1; } else if (*p == 0) { if (nested) { /* * Nested commands can't end because of the end of the * string. */ return p; } return p-1; } else { p++; } } } /* *---------------------------------------------------------------------- * * QuoteEnd -- * * Given a pointer to a string that obeys the parsing conventions * for quoted things in Tcl, find the end of that quoted thing. * The actual thing may be a quoted argument or a parenthesized * index name. * * Results: * The return value is a pointer to the last character that is * part of the quoted string (i.e the character that's equal to * term). If the quoted string doesn't terminate properly then * the return value is a pointer to the null character at the * end of the string. * * Side effects: * None. * *---------------------------------------------------------------------- */ static char * QuoteEnd(string, term) char *string; /* Pointer to character just after opening * "quote". */ int term; /* This character will terminate the * quoted string (e.g. '"' or ')'). */ { register char *p = string; int count; while (*p != term) { if (*p == '\\') { (void) Tcl_Backslash(p, &count); p += count; } else if (*p == '[') { for (p++; *p != ']'; p++) { p = TclWordEnd(p, 1, (int *) NULL); if (*p == 0) { return p; } } p++; } else if (*p == '$') { p = VarNameEnd(p); if (*p == 0) { return p; } p++; } else if (*p == 0) { return p; } else { p++; } } return p-1; } /* *---------------------------------------------------------------------- * * VarNameEnd -- * * Given a pointer to a variable reference using $-notation, find * the end of the variable name spec. * * Results: * The return value is a pointer to the last character that * is part of the variable name. If the variable name doesn't * terminate properly then the return value is a pointer to the * null character at the end of the string. * * Side effects: * None. * *---------------------------------------------------------------------- */ static char * VarNameEnd(string) char *string; /* Pointer to dollar-sign character. */ { register char *p = string+1; if (*p == '{') { for (p++; (*p != '}') && (*p != 0); p++) { /* Empty loop body. */ } return p; } while (isalnum(UCHAR(*p)) || (*p == '_')) { p++; } if ((*p == '(') && (p != string+1)) { return QuoteEnd(p+1, ')'); } return p-1; } /* *---------------------------------------------------------------------- * * Tcl_ParseVar -- * * Given a string starting with a $ sign, parse off a variable * name and return its value. * * Results: * The return value is the contents of the variable given by * the leading characters of string. If termPtr isn't NULL, * *termPtr gets filled in with the address of the character * just after the last one in the variable specifier. If the * variable doesn't exist, then the return value is NULL and * an error message will be left in interp->result. * * Side effects: * None. * *---------------------------------------------------------------------- */ char * Tcl_ParseVar(interp, string, termPtr) Tcl_Interp *interp; /* Context for looking up variable. */ register char *string; /* String containing variable name. * First character must be "$". */ char **termPtr; /* If non-NULL, points to word to fill * in with character just after last * one in the variable specifier. */ { char *name1, *name1End, c, *result; register char *name2; #define NUM_CHARS 200 char copyStorage[NUM_CHARS]; ParseValue pv; /* * There are three cases: * 1. The $ sign is followed by an open curly brace. Then the variable * name is everything up to the next close curly brace, and the * variable is a scalar variable. * 2. The $ sign is not followed by an open curly brace. Then the * variable name is everything up to the next character that isn't * a letter, digit, or underscore. If the following character is an * open parenthesis, then the information between parentheses is * the array element name, which can include any of the substitutions * permissible between quotes. * 3. The $ sign is followed by something that isn't a letter, digit, * or underscore: in this case, there is no variable name, and "$" * is returned. */ name2 = NULL; string++; if (*string == '{') { string++; name1 = string; while (*string != '}') { if (*string == 0) { Tcl_SetResult(interp, "missing close-brace for variable name", TCL_STATIC); if (termPtr != 0) { *termPtr = string; } return NULL; } string++; } name1End = string; string++; } else { name1 = string; while (isalnum(UCHAR(*string)) || (*string == '_')) { string++; } if (string == name1) { if (termPtr != 0) { *termPtr = string; } return "$"; } name1End = string; if (*string == '(') { char *end; /* * Perform substitutions on the array element name, just as * is done for quotes. */ pv.buffer = pv.next = copyStorage; pv.end = copyStorage + NUM_CHARS - 1; pv.expandProc = TclExpandParseValue; pv.clientData = (ClientData) NULL; if (TclParseQuotes(interp, string+1, ')', 0, &end, &pv) != TCL_OK) { char msg[100]; sprintf(msg, "\n (parsing index for array \"%.*s\")", (int) (string-name1), name1); Tcl_AddErrorInfo(interp, msg); result = NULL; name2 = pv.buffer; if (termPtr != 0) { *termPtr = end; } goto done; } Tcl_ResetResult(interp); string = end; name2 = pv.buffer; } } if (termPtr != 0) { *termPtr = string; } if (((Interp *) interp)->noEval) { return ""; } c = *name1End; *name1End = 0; result = Tcl_GetVar2(interp, name1, name2, TCL_LEAVE_ERR_MSG); *name1End = c; done: if ((name2 != NULL) && (pv.buffer != copyStorage)) { ckfree(pv.buffer); } return result; } /* *---------------------------------------------------------------------- * * Tcl_CommandComplete -- * * Given a partial or complete Tcl command, this procedure * determines whether the command is complete in the sense * of having matched braces and quotes and brackets. * * Results: * 1 is returned if the command is complete, 0 otherwise. * * Side effects: * None. * *---------------------------------------------------------------------- */ int Tcl_CommandComplete(cmd) char *cmd; /* Command to check. */ { register char *p = cmd; int commentOK = 1; while (1) { while (isspace(UCHAR(*p))) { if (*p == '\n') { commentOK = 1; } p++; } if ((*p == '#') && commentOK) { do { p++; } while ((*p != '\n') && (*p != 0)); continue; } if (*p == 0) { return 1; } p = TclWordEnd(p, 0, &commentOK); if (*p == 0) { return 0; } p++; } } buffer)); pvPtr->next = new + (pvPtr->next - pvPtr->buffer); if (pvPtr->clientData != 0) { ckfree(pvPtr->buffer); } pvPtr->buffer = new; pvPtr->end = new + newSpacetcl7.4b4/tclProc.c010044400630510000012000000415550573633175200146210ustar00ousterstaff00002300000001/* * tclProc.c -- * * This file contains routines that implement Tcl procedures, * including the "proc" and "uplevel" commands. * * Copyright (c) 1987-1993 The Regents of the University of California. * Copyright (c) 1994-1995 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ static char sccsid[] = "@(#) tclProc.c 1.71 95/03/29 11:24:22"; #include "tclInt.h" /* * Forward references to procedures defined later in this file: */ static void CleanupProc _ANSI_ARGS_((Proc *procPtr)); static int InterpProc _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); static void ProcDeleteProc _ANSI_ARGS_((ClientData clientData)); /* *---------------------------------------------------------------------- * * Tcl_ProcCmd -- * * This procedure is invoked to process the "proc" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result value. * * Side effects: * A new procedure gets created. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_ProcCmd(dummy, interp, argc, argv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { register Interp *iPtr = (Interp *) interp; register Proc *procPtr; int result, argCount, i; char **argArray = NULL; Arg *lastArgPtr; register Arg *argPtr = NULL; /* Initialization not needed, but * prevents compiler warning. */ if (argc != 4) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " name args body\"", (char *) NULL); return TCL_ERROR; } procPtr = (Proc *) ckalloc(sizeof(Proc)); procPtr->iPtr = iPtr; procPtr->refCount = 1; procPtr->command = (char *) ckalloc((unsigned) strlen(argv[3]) + 1); strcpy(procPtr->command, argv[3]); procPtr->argPtr = NULL; /* * Break up the argument list into argument specifiers, then process * each argument specifier. */ result = Tcl_SplitList(interp, argv[2], &argCount, &argArray); if (result != TCL_OK) { goto procError; } lastArgPtr = NULL; for (i = 0; i < argCount; i++) { int fieldCount, nameLength, valueLength; char **fieldValues; /* * Now divide the specifier up into name and default. */ result = Tcl_SplitList(interp, argArray[i], &fieldCount, &fieldValues); if (result != TCL_OK) { goto procError; } if (fieldCount > 2) { ckfree((char *) fieldValues); Tcl_AppendResult(interp, "too many fields in argument specifier \"", argArray[i], "\"", (char *) NULL); result = TCL_ERROR; goto procError; } if ((fieldCount == 0) || (*fieldValues[0] == 0)) { ckfree((char *) fieldValues); Tcl_AppendResult(interp, "procedure \"", argv[1], "\" has argument with no name", (char *) NULL); result = TCL_ERROR; goto procError; } nameLength = strlen(fieldValues[0]) + 1; if (fieldCount == 2) { valueLength = strlen(fieldValues[1]) + 1; } else { valueLength = 0; } argPtr = (Arg *) ckalloc((unsigned) (sizeof(Arg) - sizeof(argPtr->name) + nameLength + valueLength)); if (lastArgPtr == NULL) { procPtr->argPtr = argPtr; } else { lastArgPtr->nextPtr = argPtr; } lastArgPtr = argPtr; argPtr->nextPtr = NULL; strcpy(argPtr->name, fieldValues[0]); if (fieldCount == 2) { argPtr->defValue = argPtr->name + nameLength; strcpy(argPtr->defValue, fieldValues[1]); } else { argPtr->defValue = NULL; } ckfree((char *) fieldValues); } Tcl_CreateCommand(interp, argv[1], InterpProc, (ClientData) procPtr, ProcDeleteProc); ckfree((char *) argArray); return TCL_OK; procError: ckfree(procPtr->command); while (procPtr->argPtr != NULL) { argPtr = procPtr->argPtr; procPtr->argPtr = argPtr->nextPtr; ckfree((char *) argPtr); } ckfree((char *) procPtr); if (argArray != NULL) { ckfree((char *) argArray); } return result; } /* *---------------------------------------------------------------------- * * TclGetFrame -- * * Given a description of a procedure frame, such as the first * argument to an "uplevel" or "upvar" command, locate the * call frame for the appropriate level of procedure. * * Results: * The return value is -1 if an error occurred in finding the * frame (in this case an error message is left in interp->result). * 1 is returned if string was either a number or a number preceded * by "#" and it specified a valid frame. 0 is returned if string * isn't one of the two things above (in this case, the lookup * acts as if string were "1"). The variable pointed to by * framePtrPtr is filled in with the address of the desired frame * (unless an error occurs, in which case it isn't modified). * * Side effects: * None. * *---------------------------------------------------------------------- */ int TclGetFrame(interp, string, framePtrPtr) Tcl_Interp *interp; /* Interpreter in which to find frame. */ char *string; /* String describing frame. */ CallFrame **framePtrPtr; /* Store pointer to frame here (or NULL * if global frame indicated). */ { register Interp *iPtr = (Interp *) interp; int curLevel, level, result; CallFrame *framePtr; /* * Parse string to figure out which level number to go to. */ result = 1; curLevel = (iPtr->varFramePtr == NULL) ? 0 : iPtr->varFramePtr->level; if (*string == '#') { if (Tcl_GetInt(interp, string+1, &level) != TCL_OK) { return -1; } if (level < 0) { levelError: Tcl_AppendResult(interp, "bad level \"", string, "\"", (char *) NULL); return -1; } } else if (isdigit(UCHAR(*string))) { if (Tcl_GetInt(interp, string, &level) != TCL_OK) { return -1; } level = curLevel - level; } else { level = curLevel - 1; result = 0; } /* * Figure out which frame to use, and modify the interpreter so * its variables come from that frame. */ if (level == 0) { framePtr = NULL; } else { for (framePtr = iPtr->varFramePtr; framePtr != NULL; framePtr = framePtr->callerVarPtr) { if (framePtr->level == level) { break; } } if (framePtr == NULL) { goto levelError; } } *framePtrPtr = framePtr; return result; } /* *---------------------------------------------------------------------- * * Tcl_UplevelCmd -- * * This procedure is invoked to process the "uplevel" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result value. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_UplevelCmd(dummy, interp, argc, argv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { register Interp *iPtr = (Interp *) interp; int result; CallFrame *savedVarFramePtr, *framePtr; if (argc < 2) { uplevelSyntax: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " ?level? command ?arg ...?\"", (char *) NULL); return TCL_ERROR; } /* * Find the level to use for executing the command. */ result = TclGetFrame(interp, argv[1], &framePtr); if (result == -1) { return TCL_ERROR; } argc -= (result+1); if (argc == 0) { goto uplevelSyntax; } argv += (result+1); /* * Modify the interpreter state to execute in the given frame. */ savedVarFramePtr = iPtr->varFramePtr; iPtr->varFramePtr = framePtr; /* * Execute the residual arguments as a command. */ if (argc == 1) { result = Tcl_Eval(interp, argv[0]); } else { char *cmd; cmd = Tcl_Concat(argc, argv); result = Tcl_Eval(interp, cmd); ckfree(cmd); } if (result == TCL_ERROR) { char msg[60]; sprintf(msg, "\n (\"uplevel\" body line %d)", interp->errorLine); Tcl_AddErrorInfo(interp, msg); } /* * Restore the variable frame, and return. */ iPtr->varFramePtr = savedVarFramePtr; return result; } /* *---------------------------------------------------------------------- * * TclFindProc -- * * Given the name of a procedure, return a pointer to the * record describing the procedure. * * Results: * NULL is returned if the name doesn't correspond to any * procedure. Otherwise the return value is a pointer to * the procedure's record. * * Side effects: * None. * *---------------------------------------------------------------------- */ Proc * TclFindProc(iPtr, procName) Interp *iPtr; /* Interpreter in which to look. */ char *procName; /* Name of desired procedure. */ { Tcl_HashEntry *hPtr; Command *cmdPtr; hPtr = Tcl_FindHashEntry(&iPtr->commandTable, procName); if (hPtr == NULL) { return NULL; } cmdPtr = (Command *) Tcl_GetHashValue(hPtr); if (cmdPtr->proc != InterpProc) { return NULL; } return (Proc *) cmdPtr->clientData; } /* *---------------------------------------------------------------------- * * TclIsProc -- * * Tells whether a command is a Tcl procedure or not. * * Results: * If the given command is actuall a Tcl procedure, the * return value is the address of the record describing * the procedure. Otherwise the return value is 0. * * Side effects: * None. * *---------------------------------------------------------------------- */ Proc * TclIsProc(cmdPtr) Command *cmdPtr; /* Command to test. */ { if (cmdPtr->proc == InterpProc) { return (Proc *) cmdPtr->clientData; } return (Proc *) 0; } /* *---------------------------------------------------------------------- * * InterpProc -- * * When a Tcl procedure gets invoked, this routine gets invoked * to interpret the procedure. * * Results: * A standard Tcl result value, usually TCL_OK. * * Side effects: * Depends on the commands in the procedure. * *---------------------------------------------------------------------- */ static int InterpProc(clientData, interp, argc, argv) ClientData clientData; /* Record describing procedure to be * interpreted. */ Tcl_Interp *interp; /* Interpreter in which procedure was * invoked. */ int argc; /* Count of number of arguments to this * procedure. */ char **argv; /* Argument values. */ { register Proc *procPtr = (Proc *) clientData; register Arg *argPtr; register Interp *iPtr; char **args; CallFrame frame; char *value; int result; /* * Set up a call frame for the new procedure invocation. */ iPtr = procPtr->iPtr; Tcl_InitHashTable(&frame.varTable, TCL_STRING_KEYS); if (iPtr->varFramePtr != NULL) { frame.level = iPtr->varFramePtr->level + 1; } else { frame.level = 1; } frame.argc = argc; frame.argv = argv; frame.callerPtr = iPtr->framePtr; frame.callerVarPtr = iPtr->varFramePtr; iPtr->framePtr = &frame; iPtr->varFramePtr = &frame; iPtr->returnCode = TCL_OK; /* * Match the actual arguments against the procedure's formal * parameters to compute local variables. */ for (argPtr = procPtr->argPtr, args = argv+1, argc -= 1; argPtr != NULL; argPtr = argPtr->nextPtr, args++, argc--) { /* * Handle the special case of the last formal being "args". When * it occurs, assign it a list consisting of all the remaining * actual arguments. */ if ((argPtr->nextPtr == NULL) && (strcmp(argPtr->name, "args") == 0)) { if (argc < 0) { argc = 0; } value = Tcl_Merge(argc, args); Tcl_SetVar(interp, argPtr->name, value, 0); ckfree(value); argc = 0; break; } else if (argc > 0) { value = *args; } else if (argPtr->defValue != NULL) { value = argPtr->defValue; } else { Tcl_AppendResult(interp, "no value given for parameter \"", argPtr->name, "\" to \"", argv[0], "\"", (char *) NULL); result = TCL_ERROR; goto procDone; } Tcl_SetVar(interp, argPtr->name, value, 0); } if (argc > 0) { Tcl_AppendResult(interp, "called \"", argv[0], "\" with too many arguments", (char *) NULL); result = TCL_ERROR; goto procDone; } /* * Invoke the commands in the procedure's body. */ procPtr->refCount++; result = Tcl_Eval(interp, procPtr->command); procPtr->refCount--; if (procPtr->refCount <= 0) { CleanupProc(procPtr); } if (result == TCL_RETURN) { result = TclUpdateReturnInfo(iPtr); } else if (result == TCL_ERROR) { char msg[100]; /* * Record information telling where the error occurred. */ sprintf(msg, "\n (procedure \"%.50s\" line %d)", argv[0], iPtr->errorLine); Tcl_AddErrorInfo(interp, msg); } else if (result == TCL_BREAK) { iPtr->result = "invoked \"break\" outside of a loop"; result = TCL_ERROR; } else if (result == TCL_CONTINUE) { iPtr->result = "invoked \"continue\" outside of a loop"; result = TCL_ERROR; } /* * Delete the call frame for this procedure invocation (it's * important to remove the call frame from the interpreter * before deleting it, so that traces invoked during the * deletion don't see the partially-deleted frame). */ procDone: iPtr->framePtr = frame.callerPtr; iPtr->varFramePtr = frame.callerVarPtr; /* * The check below is a hack. The problem is that there could be * unset traces on the variables, which cause scripts to be evaluated. * This will clear the ERR_IN_PROGRESS flag, losing stack trace * information if the procedure was exiting with an error. The * code below preserves the flag. Unfortunately, that isn't * really enough: we really should preserve the errorInfo variable * too (otherwise a nested error in the trace script will trash * errorInfo). What's really needed is a general-purpose * mechanism for saving and restoring interpreter state. */ if (iPtr->flags & ERR_IN_PROGRESS) { TclDeleteVars(iPtr, &frame.varTable); iPtr->flags |= ERR_IN_PROGRESS; } else { TclDeleteVars(iPtr, &frame.varTable); } return result; } /* *---------------------------------------------------------------------- * * ProcDeleteProc -- * * This procedure is invoked just before a command procedure is * removed from an interpreter. Its job is to release all the * resources allocated to the procedure. * * Results: * None. * * Side effects: * Memory gets freed, unless the procedure is actively being * executed. In this case the cleanup is delayed until the * last call to the current procedure completes. * *---------------------------------------------------------------------- */ static void ProcDeleteProc(clientData) ClientData clientData; /* Procedure to be deleted. */ { Proc *procPtr = (Proc *) clientData; procPtr->refCount--; if (procPtr->refCount <= 0) { CleanupProc(procPtr); } } /* *---------------------------------------------------------------------- * * CleanupProc -- * * This procedure does all the real work of freeing up a Proc * structure. It's called only when the structure's reference * count becomes zero. * * Results: * None. * * Side effects: * Memory gets freed. * *---------------------------------------------------------------------- */ static void CleanupProc(procPtr) register Proc *procPtr; /* Procedure to be deleted. */ { register Arg *argPtr; ckfree((char *) procPtr->command); for (argPtr = procPtr->argPtr; argPtr != NULL; ) { Arg *nextPtr = argPtr->nextPtr; ckfree((char *) argPtr); argPtr = nextPtr; } ckfree((char *) procPtr); } /* *---------------------------------------------------------------------- * * TclUpdateReturnInfo -- * * This procedure is called when procedures return, and at other * points where the TCL_RETURN code is used. It examines fields * such as iPtr->returnCode and iPtr->errorCode and modifies * the real return status accordingly. * * Results: * The return value is the true completion code to use for * the procedure, instead of TCL_RETURN. * * Side effects: * The errorInfo and errorCode variables may get modified. * *---------------------------------------------------------------------- */ int TclUpdateReturnInfo(iPtr) Interp *iPtr; /* Interpreter for which TCL_RETURN * exception is being processed. */ { int code; code = iPtr->returnCode; iPtr->returnCode = TCL_OK; if (code == TCL_ERROR) { Tcl_SetVar2((Tcl_Interp *) iPtr, "errorCode", (char *) NULL, (iPtr->errorCode != NULL) ? iPtr->errorCode : "NONE", TCL_GLOBAL_ONLY); iPtr->flags |= ERROR_CODE_SET; if (iPtr->errorInfo != NULL) { Tcl_SetVar2((Tcl_Interp *) iPtr, "errorInfo", (char *) NULL, iPtr->errorInfo, TCL_GLOBAL_ONLY); iPtr->flags |= ERR_IN_PROGRESS; } } return code; } y; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argumentcl7.4b4/tclUtil.c010044400630510000012000001565020576477001200146270ustar00ousterstaff00002300000001/* * tclUtil.c -- * * This file contains utility procedures that are used by many Tcl * commands. * * Copyright (c) 1987-1993 The Regents of the University of California. * Copyright (c) 1994-1995 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ static char sccsid[] = "@(#) tclUtil.c 1.107 95/06/05 23:04:56"; #include "tclInt.h" #include "tclPort.h" /* * The following values are used in the flags returned by Tcl_ScanElement * and used by Tcl_ConvertElement. The value TCL_DONT_USE_BRACES is also * defined in tcl.h; make sure its value doesn't overlap with any of the * values below. * * TCL_DONT_USE_BRACES - 1 means the string mustn't be enclosed in * braces (e.g. it contains unmatched braces, * or ends in a backslash character, or user * just doesn't want braces); handle all * special characters by adding backslashes. * USE_BRACES - 1 means the string contains a special * character that can be handled simply by * enclosing the entire argument in braces. * BRACES_UNMATCHED - 1 means that braces aren't properly matched * in the argument. */ #define USE_BRACES 2 #define BRACES_UNMATCHED 4 /* * Function prototypes for local procedures in this file: */ static void SetupAppendBuffer _ANSI_ARGS_((Interp *iPtr, int newSpace)); /* *---------------------------------------------------------------------- * * TclFindElement -- * * Given a pointer into a Tcl list, locate the first (or next) * element in the list. * * Results: * The return value is normally TCL_OK, which means that the * element was successfully located. If TCL_ERROR is returned * it means that list didn't have proper list structure; * interp->result contains a more detailed error message. * * If TCL_OK is returned, then *elementPtr will be set to point * to the first element of list, and *nextPtr will be set to point * to the character just after any white space following the last * character that's part of the element. If this is the last argument * in the list, then *nextPtr will point to the NULL character at the * end of list. If sizePtr is non-NULL, *sizePtr is filled in with * the number of characters in the element. If the element is in * braces, then *elementPtr will point to the character after the * opening brace and *sizePtr will not include either of the braces. * If there isn't an element in the list, *sizePtr will be zero, and * both *elementPtr and *termPtr will refer to the null character at * the end of list. Note: this procedure does NOT collapse backslash * sequences. * * Side effects: * None. * *---------------------------------------------------------------------- */ int TclFindElement(interp, list, elementPtr, nextPtr, sizePtr, bracePtr) Tcl_Interp *interp; /* Interpreter to use for error reporting. * If NULL, then no error message is left * after errors. */ register char *list; /* String containing Tcl list with zero * or more elements (possibly in braces). */ char **elementPtr; /* Fill in with location of first significant * character in first element of list. */ char **nextPtr; /* Fill in with location of character just * after all white space following end of * argument (i.e. next argument or end of * list). */ int *sizePtr; /* If non-zero, fill in with size of * element. */ int *bracePtr; /* If non-zero fill in with non-zero/zero * to indicate that arg was/wasn't * in braces. */ { register char *p; int openBraces = 0; int inQuotes = 0; int size; /* * Skim off leading white space and check for an opening brace or * quote. Note: use of "isascii" below and elsewhere in this * procedure is a temporary hack (7/27/90) because Mx uses characters * with the high-order bit set for some things. This should probably * be changed back eventually, or all of Tcl should call isascii. */ while (isspace(UCHAR(*list))) { list++; } if (*list == '{') { openBraces = 1; list++; } else if (*list == '"') { inQuotes = 1; list++; } if (bracePtr != 0) { *bracePtr = openBraces; } p = list; /* * Find the end of the element (either a space or a close brace or * the end of the string). */ while (1) { switch (*p) { /* * Open brace: don't treat specially unless the element is * in braces. In this case, keep a nesting count. */ case '{': if (openBraces != 0) { openBraces++; } break; /* * Close brace: if element is in braces, keep nesting * count and quit when the last close brace is seen. */ case '}': if (openBraces == 1) { char *p2; size = p - list; p++; if (isspace(UCHAR(*p)) || (*p == 0)) { goto done; } for (p2 = p; (*p2 != 0) && (!isspace(UCHAR(*p2))) && (p2 < p+20); p2++) { /* null body */ } if (interp != NULL) { Tcl_ResetResult(interp); sprintf(interp->result, "list element in braces followed by \"%.*s\" instead of space", (int) (p2-p), p); } return TCL_ERROR; } else if (openBraces != 0) { openBraces--; } break; /* * Backslash: skip over everything up to the end of the * backslash sequence. */ case '\\': { int size; (void) Tcl_Backslash(p, &size); p += size - 1; break; } /* * Space: ignore if element is in braces or quotes; otherwise * terminate element. */ case ' ': case '\f': case '\n': case '\r': case '\t': case '\v': if ((openBraces == 0) && !inQuotes) { size = p - list; goto done; } break; /* * Double-quote: if element is in quotes then terminate it. */ case '"': if (inQuotes) { char *p2; size = p-list; p++; if (isspace(UCHAR(*p)) || (*p == 0)) { goto done; } for (p2 = p; (*p2 != 0) && (!isspace(UCHAR(*p2))) && (p2 < p+20); p2++) { /* null body */ } if (interp != NULL) { Tcl_ResetResult(interp); sprintf(interp->result, "list element in quotes followed by \"%.*s\" %s", (int) (p2-p), p, "instead of space"); } return TCL_ERROR; } break; /* * End of list: terminate element. */ case 0: if (openBraces != 0) { if (interp != NULL) { Tcl_SetResult(interp, "unmatched open brace in list", TCL_STATIC); } return TCL_ERROR; } else if (inQuotes) { if (interp != NULL) { Tcl_SetResult(interp, "unmatched open quote in list", TCL_STATIC); } return TCL_ERROR; } size = p - list; goto done; } p++; } done: while (isspace(UCHAR(*p))) { p++; } *elementPtr = list; *nextPtr = p; if (sizePtr != 0) { *sizePtr = size; } return TCL_OK; } /* *---------------------------------------------------------------------- * * TclCopyAndCollapse -- * * Copy a string and eliminate any backslashes that aren't in braces. * * Results: * There is no return value. Count chars. get copied from src * to dst. Along the way, if backslash sequences are found outside * braces, the backslashes are eliminated in the copy. * After scanning count chars. from source, a null character is * placed at the end of dst. * * Side effects: * None. * *---------------------------------------------------------------------- */ void TclCopyAndCollapse(count, src, dst) int count; /* Total number of characters to copy * from src. */ register char *src; /* Copy from here... */ register char *dst; /* ... to here. */ { register char c; int numRead; for (c = *src; count > 0; src++, c = *src, count--) { if (c == '\\') { *dst = Tcl_Backslash(src, &numRead); dst++; src += numRead-1; count -= numRead-1; } else { *dst = c; dst++; } } *dst = 0; } /* *---------------------------------------------------------------------- * * Tcl_SplitList -- * * Splits a list up into its constituent fields. * * Results * The return value is normally TCL_OK, which means that * the list was successfully split up. If TCL_ERROR is * returned, it means that "list" didn't have proper list * structure; interp->result will contain a more detailed * error message. * * *argvPtr will be filled in with the address of an array * whose elements point to the elements of list, in order. * *argcPtr will get filled in with the number of valid elements * in the array. A single block of memory is dynamically allocated * to hold both the argv array and a copy of the list (with * backslashes and braces removed in the standard way). * The caller must eventually free this memory by calling free() * on *argvPtr. Note: *argvPtr and *argcPtr are only modified * if the procedure returns normally. * * Side effects: * Memory is allocated. * *---------------------------------------------------------------------- */ int Tcl_SplitList(interp, list, argcPtr, argvPtr) Tcl_Interp *interp; /* Interpreter to use for error reporting. * If NULL, then no error message is left. */ char *list; /* Pointer to string with list structure. */ int *argcPtr; /* Pointer to location to fill in with * the number of elements in the list. */ char ***argvPtr; /* Pointer to place to store pointer to array * of pointers to list elements. */ { char **argv; register char *p; int size, i, result, elSize, brace; char *element; /* * Figure out how much space to allocate. There must be enough * space for both the array of pointers and also for a copy of * the list. To estimate the number of pointers needed, count * the number of space characters in the list. */ for (size = 1, p = list; *p != 0; p++) { if (isspace(UCHAR(*p))) { size++; } } size++; /* Leave space for final NULL pointer. */ argv = (char **) ckalloc((unsigned) ((size * sizeof(char *)) + (p - list) + 1)); for (i = 0, p = ((char *) argv) + size*sizeof(char *); *list != 0; i++) { result = TclFindElement(interp, list, &element, &list, &elSize, &brace); if (result != TCL_OK) { ckfree((char *) argv); return result; } if (*element == 0) { break; } if (i >= size) { ckfree((char *) argv); if (interp != NULL) { Tcl_SetResult(interp, "internal error in Tcl_SplitList", TCL_STATIC); } return TCL_ERROR; } argv[i] = p; if (brace) { strncpy(p, element, (size_t) elSize); p += elSize; *p = 0; p++; } else { TclCopyAndCollapse(elSize, element, p); p += elSize+1; } } argv[i] = NULL; *argvPtr = argv; *argcPtr = i; return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_ScanElement -- * * This procedure is a companion procedure to Tcl_ConvertElement. * It scans a string to see what needs to be done to it (e.g. * add backslashes or enclosing braces) to make the string into * a valid Tcl list element. * * Results: * The return value is an overestimate of the number of characters * that will be needed by Tcl_ConvertElement to produce a valid * list element from string. The word at *flagPtr is filled in * with a value needed by Tcl_ConvertElement when doing the actual * conversion. * * Side effects: * None. * *---------------------------------------------------------------------- */ int Tcl_ScanElement(string, flagPtr) char *string; /* String to convert to Tcl list element. */ int *flagPtr; /* Where to store information to guide * Tcl_ConvertElement. */ { int flags, nestingLevel; register char *p; /* * This procedure and Tcl_ConvertElement together do two things: * * 1. They produce a proper list, one that will yield back the * argument strings when evaluated or when disassembled with * Tcl_SplitList. This is the most important thing. * * 2. They try to produce legible output, which means minimizing the * use of backslashes (using braces instead). However, there are * some situations where backslashes must be used (e.g. an element * like "{abc": the leading brace will have to be backslashed. For * each element, one of three things must be done: * * (a) Use the element as-is (it doesn't contain anything special * characters). This is the most desirable option. * * (b) Enclose the element in braces, but leave the contents alone. * This happens if the element contains embedded space, or if it * contains characters with special interpretation ($, [, ;, or \), * or if it starts with a brace or double-quote, or if there are * no characters in the element. * * (c) Don't enclose the element in braces, but add backslashes to * prevent special interpretation of special characters. This is a * last resort used when the argument would normally fall under case * (b) but contains unmatched braces. It also occurs if the last * character of the argument is a backslash or if the element contains * a backslash followed by newline. * * The procedure figures out how many bytes will be needed to store * the result (actually, it overestimates). It also collects information * about the element in the form of a flags word. */ nestingLevel = 0; flags = 0; if (string == NULL) { string = ""; } p = string; if ((*p == '{') || (*p == '"') || (*p == 0)) { flags |= USE_BRACES; } for ( ; *p != 0; p++) { switch (*p) { case '{': nestingLevel++; break; case '}': nestingLevel--; if (nestingLevel < 0) { flags |= TCL_DONT_USE_BRACES|BRACES_UNMATCHED; } break; case '[': case '$': case ';': case ' ': case '\f': case '\n': case '\r': case '\t': case '\v': flags |= USE_BRACES; break; case '\\': if ((p[1] == 0) || (p[1] == '\n')) { flags = TCL_DONT_USE_BRACES; } else { int size; (void) Tcl_Backslash(p, &size); p += size-1; flags |= USE_BRACES; } break; } } if (nestingLevel != 0) { flags = TCL_DONT_USE_BRACES | BRACES_UNMATCHED; } *flagPtr = flags; /* * Allow enough space to backslash every character plus leave * two spaces for braces. */ return 2*(p-string) + 2; } /* *---------------------------------------------------------------------- * * Tcl_ConvertElement -- * * This is a companion procedure to Tcl_ScanElement. Given the * information produced by Tcl_ScanElement, this procedure converts * a string to a list element equal to that string. * * Results: * Information is copied to *dst in the form of a list element * identical to src (i.e. if Tcl_SplitList is applied to dst it * will produce a string identical to src). The return value is * a count of the number of characters copied (not including the * terminating NULL character). * * Side effects: * None. * *---------------------------------------------------------------------- */ int Tcl_ConvertElement(src, dst, flags) register char *src; /* Source information for list element. */ char *dst; /* Place to put list-ified element. */ int flags; /* Flags produced by Tcl_ScanElement. */ { register char *p = dst; /* * See the comment block at the beginning of the Tcl_ScanElement * code for details of how this works. */ if ((src == NULL) || (*src == 0)) { p[0] = '{'; p[1] = '}'; p[2] = 0; return 2; } if ((flags & USE_BRACES) && !(flags & TCL_DONT_USE_BRACES)) { *p = '{'; p++; for ( ; *src != 0; src++, p++) { *p = *src; } *p = '}'; p++; } else { if (*src == '{') { /* * Can't have a leading brace unless the whole element is * enclosed in braces. Add a backslash before the brace. * Furthermore, this may destroy the balance between open * and close braces, so set BRACES_UNMATCHED. */ p[0] = '\\'; p[1] = '{'; p += 2; src++; flags |= BRACES_UNMATCHED; } for (; *src != 0 ; src++) { switch (*src) { case ']': case '[': case '$': case ';': case ' ': case '\\': case '"': *p = '\\'; p++; break; case '{': case '}': /* * It may not seem necessary to backslash braces, but * it is. The reason for this is that the resulting * list element may actually be an element of a sub-list * enclosed in braces (e.g. if Tcl_DStringStartSublist * has been invoked), so there may be a brace mismatch * if the braces aren't backslashed. */ if (flags & BRACES_UNMATCHED) { *p = '\\'; p++; } break; case '\f': *p = '\\'; p++; *p = 'f'; p++; continue; case '\n': *p = '\\'; p++; *p = 'n'; p++; continue; case '\r': *p = '\\'; p++; *p = 'r'; p++; continue; case '\t': *p = '\\'; p++; *p = 't'; p++; continue; case '\v': *p = '\\'; p++; *p = 'v'; p++; continue; } *p = *src; p++; } } *p = '\0'; return p-dst; } /* *---------------------------------------------------------------------- * * Tcl_Merge -- * * Given a collection of strings, merge them together into a * single string that has proper Tcl list structured (i.e. * Tcl_SplitList may be used to retrieve strings equal to the * original elements, and Tcl_Eval will parse the string back * into its original elements). * * Results: * The return value is the address of a dynamically-allocated * string containing the merged list. * * Side effects: * None. * *---------------------------------------------------------------------- */ char * Tcl_Merge(argc, argv) int argc; /* How many strings to merge. */ char **argv; /* Array of string values. */ { # define LOCAL_SIZE 20 int localFlags[LOCAL_SIZE], *flagPtr; int numChars; char *result; register char *dst; int i; /* * Pass 1: estimate space, gather flags. */ if (argc <= LOCAL_SIZE) { flagPtr = localFlags; } else { flagPtr = (int *) ckalloc((unsigned) argc*sizeof(int)); } numChars = 1; for (i = 0; i < argc; i++) { numChars += Tcl_ScanElement(argv[i], &flagPtr[i]) + 1; } /* * Pass two: copy into the result area. */ result = (char *) ckalloc((unsigned) numChars); dst = result; for (i = 0; i < argc; i++) { numChars = Tcl_ConvertElement(argv[i], dst, flagPtr[i]); dst += numChars; *dst = ' '; dst++; } if (dst == result) { *dst = 0; } else { dst[-1] = 0; } if (flagPtr != localFlags) { ckfree((char *) flagPtr); } return result; } /* *---------------------------------------------------------------------- * * Tcl_Concat -- * * Concatenate a set of strings into a single large string. * * Results: * The return value is dynamically-allocated string containing * a concatenation of all the strings in argv, with spaces between * the original argv elements. * * Side effects: * Memory is allocated for the result; the caller is responsible * for freeing the memory. * *---------------------------------------------------------------------- */ char * Tcl_Concat(argc, argv) int argc; /* Number of strings to concatenate. */ char **argv; /* Array of strings to concatenate. */ { int totalSize, i; register char *p; char *result; for (totalSize = 1, i = 0; i < argc; i++) { totalSize += strlen(argv[i]) + 1; } result = (char *) ckalloc((unsigned) totalSize); if (argc == 0) { *result = '\0'; return result; } for (p = result, i = 0; i < argc; i++) { char *element; int length; /* * Clip white space off the front and back of the string * to generate a neater result, and ignore any empty * elements. */ element = argv[i]; while (isspace(UCHAR(*element))) { element++; } for (length = strlen(element); (length > 0) && (isspace(UCHAR(element[length-1]))); length--) { /* Null loop body. */ } if (length == 0) { continue; } (void) strncpy(p, element, (size_t) length); p += length; *p = ' '; p++; } if (p != result) { p[-1] = 0; } else { *p = 0; } return result; } /* *---------------------------------------------------------------------- * * Tcl_StringMatch -- * * See if a particular string matches a particular pattern. * * Results: * The return value is 1 if string matches pattern, and * 0 otherwise. The matching operation permits the following * special characters in the pattern: *?\[] (see the manual * entry for details on what these mean). * * Side effects: * None. * *---------------------------------------------------------------------- */ int Tcl_StringMatch(string, pattern) register char *string; /* String. */ register char *pattern; /* Pattern, which may contain * special characters. */ { char c2; while (1) { /* See if we're at the end of both the pattern and the string. * If so, we succeeded. If we're at the end of the pattern * but not at the end of the string, we failed. */ if (*pattern == 0) { if (*string == 0) { return 1; } else { return 0; } } if ((*string == 0) && (*pattern != '*')) { return 0; } /* Check for a "*" as the next pattern character. It matches * any substring. We handle this by calling ourselves * recursively for each postfix of string, until either we * match or we reach the end of the string. */ if (*pattern == '*') { pattern += 1; if (*pattern == 0) { return 1; } while (1) { if (Tcl_StringMatch(string, pattern)) { return 1; } if (*string == 0) { return 0; } string += 1; } } /* Check for a "?" as the next pattern character. It matches * any single character. */ if (*pattern == '?') { goto thisCharOK; } /* Check for a "[" as the next pattern character. It is followed * by a list of characters that are acceptable, or by a range * (two characters separated by "-"). */ if (*pattern == '[') { pattern += 1; while (1) { if ((*pattern == ']') || (*pattern == 0)) { return 0; } if (*pattern == *string) { break; } if (pattern[1] == '-') { c2 = pattern[2]; if (c2 == 0) { return 0; } if ((*pattern <= *string) && (c2 >= *string)) { break; } if ((*pattern >= *string) && (c2 <= *string)) { break; } pattern += 2; } pattern += 1; } while (*pattern != ']') { if (*pattern == 0) { pattern--; break; } pattern += 1; } goto thisCharOK; } /* If the next pattern character is '/', just strip off the '/' * so we do exact matching on the character that follows. */ if (*pattern == '\\') { pattern += 1; if (*pattern == 0) { return 0; } } /* There's no special character. Just make sure that the next * characters of each string match. */ if (*pattern != *string) { return 0; } thisCharOK: pattern += 1; string += 1; } } /* *---------------------------------------------------------------------- * * Tcl_SetResult -- * * Arrange for "string" to be the Tcl return value. * * Results: * None. * * Side effects: * interp->result is left pointing either to "string" (if "copy" is 0) * or to a copy of string. * *---------------------------------------------------------------------- */ void Tcl_SetResult(interp, string, freeProc) Tcl_Interp *interp; /* Interpreter with which to associate the * return value. */ char *string; /* Value to be returned. If NULL, * the result is set to an empty string. */ Tcl_FreeProc *freeProc; /* Gives information about the string: * TCL_STATIC, TCL_VOLATILE, or the address * of a Tcl_FreeProc such as free. */ { register Interp *iPtr = (Interp *) interp; int length; Tcl_FreeProc *oldFreeProc = iPtr->freeProc; char *oldResult = iPtr->result; if (string == NULL) { iPtr->resultSpace[0] = 0; iPtr->result = iPtr->resultSpace; iPtr->freeProc = 0; } else if (freeProc == TCL_DYNAMIC) { iPtr->result = string; iPtr->freeProc = (Tcl_FreeProc *) free; } else if (freeProc == TCL_VOLATILE) { length = strlen(string); if (length > TCL_RESULT_SIZE) { iPtr->result = (char *) ckalloc((unsigned) length+1); iPtr->freeProc = (Tcl_FreeProc *) free; } else { iPtr->result = iPtr->resultSpace; iPtr->freeProc = 0; } strcpy(iPtr->result, string); } else { iPtr->result = string; iPtr->freeProc = freeProc; } /* * If the old result was dynamically-allocated, free it up. Do it * here, rather than at the beginning, in case the new result value * was part of the old result value. */ if (oldFreeProc != 0) { if (oldFreeProc == (Tcl_FreeProc *) free) { ckfree(oldResult); } else { (*oldFreeProc)(oldResult); } } } /* *---------------------------------------------------------------------- * * Tcl_AppendResult -- * * Append a variable number of strings onto the result already * present for an interpreter. * * Results: * None. * * Side effects: * The result in the interpreter given by the first argument * is extended by the strings given by the second and following * arguments (up to a terminating NULL argument). * *---------------------------------------------------------------------- */ /* VARARGS2 */ #ifndef lint void Tcl_AppendResult(va_alist) #else void /* VARARGS2 */ /* ARGSUSED */ Tcl_AppendResult(interp, p, va_alist) Tcl_Interp *interp; /* Interpreter whose result is to be * extended. */ char *p; /* One or more strings to add to the * result, terminated with NULL. */ #endif va_dcl { va_list argList; register Interp *iPtr; char *string; int newSpace; /* * First, scan through all the arguments to see how much space is * needed. */ va_start(argList); iPtr = va_arg(argList, Interp *); newSpace = 0; while (1) { string = va_arg(argList, char *); if (string == NULL) { break; } newSpace += strlen(string); } va_end(argList); /* * If the append buffer isn't already setup and large enough * to hold the new data, set it up. */ if ((iPtr->result != iPtr->appendResult) || (iPtr->appendResult[iPtr->appendUsed] != 0) || ((newSpace + iPtr->appendUsed) >= iPtr->appendAvl)) { SetupAppendBuffer(iPtr, newSpace); } /* * Final step: go through all the argument strings again, copying * them into the buffer. */ va_start(argList); (void) va_arg(argList, Tcl_Interp *); while (1) { string = va_arg(argList, char *); if (string == NULL) { break; } strcpy(iPtr->appendResult + iPtr->appendUsed, string); iPtr->appendUsed += strlen(string); } va_end(argList); } /* *---------------------------------------------------------------------- * * Tcl_AppendElement -- * * Convert a string to a valid Tcl list element and append it * to the current result (which is ostensibly a list). * * Results: * None. * * Side effects: * The result in the interpreter given by the first argument * is extended with a list element converted from string. A * separator space is added before the converted list element * unless the current result is empty, contains the single * character "{", or ends in " {". * *---------------------------------------------------------------------- */ void Tcl_AppendElement(interp, string) Tcl_Interp *interp; /* Interpreter whose result is to be * extended. */ char *string; /* String to convert to list element and * add to result. */ { register Interp *iPtr = (Interp *) interp; int size, flags; char *dst; /* * See how much space is needed, and grow the append buffer if * needed to accommodate the list element. */ size = Tcl_ScanElement(string, &flags) + 1; if ((iPtr->result != iPtr->appendResult) || (iPtr->appendResult[iPtr->appendUsed] != 0) || ((size + iPtr->appendUsed) >= iPtr->appendAvl)) { SetupAppendBuffer(iPtr, size+iPtr->appendUsed); } /* * Convert the string into a list element and copy it to the * buffer that's forming, with a space separator if needed. */ dst = iPtr->appendResult + iPtr->appendUsed; if (TclNeedSpace(iPtr->appendResult, dst)) { iPtr->appendUsed++; *dst = ' '; dst++; } iPtr->appendUsed += Tcl_ConvertElement(string, dst, flags); } /* *---------------------------------------------------------------------- * * SetupAppendBuffer -- * * This procedure makes sure that there is an append buffer * properly initialized for interp, and that it has at least * enough room to accommodate newSpace new bytes of information. * * Results: * None. * * Side effects: * None. * *---------------------------------------------------------------------- */ static void SetupAppendBuffer(iPtr, newSpace) register Interp *iPtr; /* Interpreter whose result is being set up. */ int newSpace; /* Make sure that at least this many bytes * of new information may be added. */ { int totalSpace; /* * Make the append buffer larger, if that's necessary, then * copy the current result into the append buffer and make the * append buffer the official Tcl result. */ if (iPtr->result != iPtr->appendResult) { /* * If an oversized buffer was used recently, then free it up * so we go back to a smaller buffer. This avoids tying up * memory forever after a large operation. */ if (iPtr->appendAvl > 500) { ckfree(iPtr->appendResult); iPtr->appendResult = NULL; iPtr->appendAvl = 0; } iPtr->appendUsed = strlen(iPtr->result); } else if (iPtr->result[iPtr->appendUsed] != 0) { /* * Most likely someone has modified a result created by * Tcl_AppendResult et al. so that it has a different size. * Just recompute the size. */ iPtr->appendUsed = strlen(iPtr->result); } totalSpace = newSpace + iPtr->appendUsed; if (totalSpace >= iPtr->appendAvl) { char *new; if (totalSpace < 100) { totalSpace = 200; } else { totalSpace *= 2; } new = (char *) ckalloc((unsigned) totalSpace); strcpy(new, iPtr->result); if (iPtr->appendResult != NULL) { ckfree(iPtr->appendResult); } iPtr->appendResult = new; iPtr->appendAvl = totalSpace; } else if (iPtr->result != iPtr->appendResult) { strcpy(iPtr->appendResult, iPtr->result); } Tcl_FreeResult(iPtr); iPtr->result = iPtr->appendResult; } /* *---------------------------------------------------------------------- * * Tcl_ResetResult -- * * This procedure restores the result area for an interpreter * to its default initialized state, freeing up any memory that * may have been allocated for the result and clearing any * error information for the interpreter. * * Results: * None. * * Side effects: * None. * *---------------------------------------------------------------------- */ void Tcl_ResetResult(interp) Tcl_Interp *interp; /* Interpreter for which to clear result. */ { register Interp *iPtr = (Interp *) interp; Tcl_FreeResult(iPtr); iPtr->result = iPtr->resultSpace; iPtr->resultSpace[0] = 0; iPtr->flags &= ~(ERR_ALREADY_LOGGED | ERR_IN_PROGRESS | ERROR_CODE_SET); } /* *---------------------------------------------------------------------- * * Tcl_SetErrorCode -- * * This procedure is called to record machine-readable information * about an error that is about to be returned. * * Results: * None. * * Side effects: * The errorCode global variable is modified to hold all of the * arguments to this procedure, in a list form with each argument * becoming one element of the list. A flag is set internally * to remember that errorCode has been set, so the variable doesn't * get set automatically when the error is returned. * *---------------------------------------------------------------------- */ /* VARARGS2 */ #ifndef lint void Tcl_SetErrorCode(va_alist) #else void /* VARARGS2 */ /* ARGSUSED */ Tcl_SetErrorCode(interp, p, va_alist) Tcl_Interp *interp; /* Interpreter whose errorCode variable is * to be set. */ char *p; /* One or more elements to add to errorCode, * terminated with NULL. */ #endif va_dcl { va_list argList; char *string; int flags; Interp *iPtr; /* * Scan through the arguments one at a time, appending them to * $errorCode as list elements. */ va_start(argList); iPtr = va_arg(argList, Interp *); flags = TCL_GLOBAL_ONLY | TCL_LIST_ELEMENT; while (1) { string = va_arg(argList, char *); if (string == NULL) { break; } (void) Tcl_SetVar2((Tcl_Interp *) iPtr, "errorCode", (char *) NULL, string, flags); flags |= TCL_APPEND_VALUE; } va_end(argList); iPtr->flags |= ERROR_CODE_SET; } /* *---------------------------------------------------------------------- * * TclGetListIndex -- * * Parse a list index, which may be either an integer or the * value "end". * * Results: * The return value is either TCL_OK or TCL_ERROR. If it is * TCL_OK, then the index corresponding to string is left in * *indexPtr. If the return value is TCL_ERROR, then string * was bogus; an error message is returned in interp->result. * If a negative index is specified, it is rounded up to 0. * The index value may be larger than the size of the list * (this happens when "end" is specified). * * Side effects: * None. * *---------------------------------------------------------------------- */ int TclGetListIndex(interp, string, indexPtr) Tcl_Interp *interp; /* Interpreter for error reporting. */ char *string; /* String containing list index. */ int *indexPtr; /* Where to store index. */ { if (isdigit(UCHAR(*string)) || (*string == '-')) { if (Tcl_GetInt(interp, string, indexPtr) != TCL_OK) { return TCL_ERROR; } if (*indexPtr < 0) { *indexPtr = 0; } } else if (strncmp(string, "end", strlen(string)) == 0) { *indexPtr = INT_MAX; } else { Tcl_AppendResult(interp, "bad index \"", string, "\": must be integer or \"end\"", (char *) NULL); return TCL_ERROR; } return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_RegExpCompile -- * * Compile a regular expression into a form suitable for fast * matching. This procedure retains a small cache of pre-compiled * regular expressions in the interpreter, in order to avoid * compilation costs as much as possible. * * Results: * The return value is a pointer to the compiled form of string, * suitable for passing to Tcl_RegExpExec. This compiled form * is only valid up until the next call to this procedure, so * don't keep these around for a long time! If an error occurred * while compiling the pattern, then NULL is returned and an error * message is left in interp->result. * * Side effects: * The cache of compiled regexp's in interp will be modified to * hold information for string, if such information isn't already * present in the cache. * *---------------------------------------------------------------------- */ Tcl_RegExp Tcl_RegExpCompile(interp, string) Tcl_Interp *interp; /* For use in error reporting. */ char *string; /* String for which to produce * compiled regular expression. */ { register Interp *iPtr = (Interp *) interp; int i, length; regexp *result; length = strlen(string); for (i = 0; i < NUM_REGEXPS; i++) { if ((length == iPtr->patLengths[i]) && (strcmp(string, iPtr->patterns[i]) == 0)) { /* * Move the matched pattern to the first slot in the * cache and shift the other patterns down one position. */ if (i != 0) { int j; char *cachedString; cachedString = iPtr->patterns[i]; result = iPtr->regexps[i]; for (j = i-1; j >= 0; j--) { iPtr->patterns[j+1] = iPtr->patterns[j]; iPtr->patLengths[j+1] = iPtr->patLengths[j]; iPtr->regexps[j+1] = iPtr->regexps[j]; } iPtr->patterns[0] = cachedString; iPtr->patLengths[0] = length; iPtr->regexps[0] = result; } return (Tcl_RegExp) iPtr->regexps[0]; } } /* * No match in the cache. Compile the string and add it to the * cache. */ TclRegError(NULL); result = TclRegComp(string); if (TclGetRegError() != NULL) { Tcl_AppendResult(interp, "couldn't compile regular expression pattern: ", TclGetRegError(), (char *) NULL); return NULL; } if (iPtr->patterns[NUM_REGEXPS-1] != NULL) { ckfree(iPtr->patterns[NUM_REGEXPS-1]); ckfree((char *) iPtr->regexps[NUM_REGEXPS-1]); } for (i = NUM_REGEXPS - 2; i >= 0; i--) { iPtr->patterns[i+1] = iPtr->patterns[i]; iPtr->patLengths[i+1] = iPtr->patLengths[i]; iPtr->regexps[i+1] = iPtr->regexps[i]; } iPtr->patterns[0] = (char *) ckalloc((unsigned) (length+1)); strcpy(iPtr->patterns[0], string); iPtr->patLengths[0] = length; iPtr->regexps[0] = result; return (Tcl_RegExp) result; } /* *---------------------------------------------------------------------- * * Tcl_RegExpExec -- * * Execute the regular expression matcher using a compiled form * of a regular expression and save information about any match * that is found. * * Results: * If an error occurs during the matching operation then -1 * is returned and interp->result contains an error message. * Otherwise the return value is 1 if * * Side effects: * None. * *---------------------------------------------------------------------- */ int Tcl_RegExpExec(interp, re, string, start) Tcl_Interp *interp; /* Interpreter to use for error reporting. */ Tcl_RegExp re; /* Compiled regular expression; must have * been returned by previous call to * Tcl_RegExpCompile. */ char *string; /* String against which to match re. */ char *start; /* If string is part of a larger string, * this identifies beginning of larger * string, so that "^" won't match. */ { int match; regexp *regexpPtr = (regexp *) re; TclRegError(NULL); match = TclRegExec(regexpPtr, string, start); if (TclGetRegError() != NULL) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "error while matching regular expression: ", TclGetRegError(), (char *) NULL); return -1; } return match; } /* *---------------------------------------------------------------------- * * Tcl_RegExpRange -- * * Returns pointers describing the range of a regular expression match, * or one of the subranges within the match. * * Results: * The variables at *startPtr and *endPtr are modified to hold the * addresses of the endpoints of the range given by index. If the * specified range doesn't exist then NULLs are returned. * * Side effects: * None. * *---------------------------------------------------------------------- */ void Tcl_RegExpRange(re, index, startPtr, endPtr) Tcl_RegExp re; /* Compiled regular expression that has * been passed to Tcl_RegExpExec. */ int index; /* 0 means give the range of the entire * match, > 0 means give the range of * a matching subrange. Must be no greater * than NSUBEXP. */ char **startPtr; /* Store address of first character in * (sub-) range here. */ char **endPtr; /* Store address of character just after last * in (sub-) range here. */ { regexp *regexpPtr = (regexp *) re; if (index >= NSUBEXP) { *startPtr = *endPtr = NULL; } else { *startPtr = regexpPtr->startp[index]; *endPtr = regexpPtr->endp[index]; } } /* *---------------------------------------------------------------------- * * Tcl_RegExpMatch -- * * See if a string matches a regular expression. * * Results: * If an error occurs during the matching operation then -1 * is returned and interp->result contains an error message. * Otherwise the return value is 1 if "string" matches "pattern" * and 0 otherwise. * * Side effects: * None. * *---------------------------------------------------------------------- */ int Tcl_RegExpMatch(interp, string, pattern) Tcl_Interp *interp; /* Used for error reporting. */ char *string; /* String. */ char *pattern; /* Regular expression to match against * string. */ { Tcl_RegExp re; re = Tcl_RegExpCompile(interp, pattern); if (re == NULL) { return -1; } return Tcl_RegExpExec(interp, re, string, string); } /* *---------------------------------------------------------------------- * * Tcl_DStringInit -- * * Initializes a dynamic string, discarding any previous contents * of the string (Tcl_DStringFree should have been called already * if the dynamic string was previously in use). * * Results: * None. * * Side effects: * The dynamic string is initialized to be empty. * *---------------------------------------------------------------------- */ void Tcl_DStringInit(dsPtr) register Tcl_DString *dsPtr; /* Pointer to structure for * dynamic string. */ { dsPtr->string = dsPtr->staticSpace; dsPtr->length = 0; dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; dsPtr->staticSpace[0] = 0; } /* *---------------------------------------------------------------------- * * Tcl_DStringAppend -- * * Append more characters to the current value of a dynamic string. * * Results: * The return value is a pointer to the dynamic string's new value. * * Side effects: * Length bytes from string (or all of string if length is less * than zero) are added to the current value of the string. Memory * gets reallocated if needed to accomodate the string's new size. * *---------------------------------------------------------------------- */ char * Tcl_DStringAppend(dsPtr, string, length) register Tcl_DString *dsPtr; /* Structure describing dynamic * string. */ char *string; /* String to append. If length is * -1 then this must be * null-terminated. */ int length; /* Number of characters from string * to append. If < 0, then append all * of string, up to null at end. */ { int newSize; char *newString, *dst, *end; if (length < 0) { length = strlen(string); } newSize = length + dsPtr->length; /* * Allocate a larger buffer for the string if the current one isn't * large enough. Allocate extra space in the new buffer so that there * will be room to grow before we have to allocate again. */ if (newSize >= dsPtr->spaceAvl) { dsPtr->spaceAvl = newSize*2; newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl); memcpy((VOID *)newString, (VOID *) dsPtr->string, (size_t) dsPtr->length); if (dsPtr->string != dsPtr->staticSpace) { ckfree(dsPtr->string); } dsPtr->string = newString; } /* * Copy the new string into the buffer at the end of the old * one. */ for (dst = dsPtr->string + dsPtr->length, end = string+length; string < end; string++, dst++) { *dst = *string; } *dst = 0; dsPtr->length += length; return dsPtr->string; } /* *---------------------------------------------------------------------- * * Tcl_DStringAppendElement -- * * Append a list element to the current value of a dynamic string. * * Results: * The return value is a pointer to the dynamic string's new value. * * Side effects: * String is reformatted as a list element and added to the current * value of the string. Memory gets reallocated if needed to * accomodate the string's new size. * *---------------------------------------------------------------------- */ char * Tcl_DStringAppendElement(dsPtr, string) register Tcl_DString *dsPtr; /* Structure describing dynamic * string. */ char *string; /* String to append. Must be * null-terminated. */ { int newSize, flags; char *dst, *newString; newSize = Tcl_ScanElement(string, &flags) + dsPtr->length + 1; /* * Allocate a larger buffer for the string if the current one isn't * large enough. Allocate extra space in the new buffer so that there * will be room to grow before we have to allocate again. * SPECIAL NOTE: must use memcpy, not strcpy, to copy the string * to a larger buffer, since there may be embedded NULLs in the * string in some cases. */ if (newSize >= dsPtr->spaceAvl) { dsPtr->spaceAvl = newSize*2; newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl); memcpy((VOID *) newString, (VOID *) dsPtr->string, (size_t) dsPtr->length); if (dsPtr->string != dsPtr->staticSpace) { ckfree(dsPtr->string); } dsPtr->string = newString; } /* * Convert the new string to a list element and copy it into the * buffer at the end, with a space, if needed. */ dst = dsPtr->string + dsPtr->length; if (TclNeedSpace(dsPtr->string, dst)) { *dst = ' '; dst++; dsPtr->length++; } dsPtr->length += Tcl_ConvertElement(string, dst, flags); return dsPtr->string; } /* *---------------------------------------------------------------------- * * Tcl_DStringSetLength -- * * Change the length of a dynamic string. This can cause the * string to either grow or shrink, depending on the value of * length. * * Results: * None. * * Side effects: * The length of dsPtr is changed to length and a null byte is * stored at that position in the string. If length is larger * than the space allocated for dsPtr, then a panic occurs. * *---------------------------------------------------------------------- */ void Tcl_DStringSetLength(dsPtr, length) register Tcl_DString *dsPtr; /* Structure describing dynamic * string. */ int length; /* New length for dynamic string. */ { if (length < 0) { length = 0; } if (length >= dsPtr->spaceAvl) { char *newString; dsPtr->spaceAvl = length+1; newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl); /* * SPECIAL NOTE: must use memcpy, not strcpy, to copy the string * to a larger buffer, since there may be embedded NULLs in the * string in some cases. */ memcpy((VOID *) newString, (VOID *) dsPtr->string, (size_t) dsPtr->length); if (dsPtr->string != dsPtr->staticSpace) { ckfree(dsPtr->string); } dsPtr->string = newString; } dsPtr->length = length; dsPtr->string[length] = 0; } /* *---------------------------------------------------------------------- * * Tcl_DStringFree -- * * Frees up any memory allocated for the dynamic string and * reinitializes the string to an empty state. * * Results: * None. * * Side effects: * The previous contents of the dynamic string are lost, and * the new value is an empty string. * *---------------------------------------------------------------------- */ void Tcl_DStringFree(dsPtr) register Tcl_DString *dsPtr; /* Structure describing dynamic * string. */ { if (dsPtr->string != dsPtr->staticSpace) { ckfree(dsPtr->string); } dsPtr->string = dsPtr->staticSpace; dsPtr->length = 0; dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; dsPtr->staticSpace[0] = 0; } /* *---------------------------------------------------------------------- * * Tcl_DStringResult -- * * This procedure moves the value of a dynamic string into an * interpreter as its result. The string itself is reinitialized * to an empty string. * * Results: * None. * * Side effects: * The string is "moved" to interp's result, and any existing * result for interp is freed up. DsPtr is reinitialized to * an empty string. * *---------------------------------------------------------------------- */ void Tcl_DStringResult(interp, dsPtr) Tcl_Interp *interp; /* Interpreter whose result is to be * reset. */ Tcl_DString *dsPtr; /* Dynamic string that is to become * the result of interp. */ { Tcl_ResetResult(interp); if (dsPtr->string != dsPtr->staticSpace) { interp->result = dsPtr->string; interp->freeProc = (Tcl_FreeProc *) free; } else if (dsPtr->length < TCL_RESULT_SIZE) { interp->result = ((Interp *) interp)->resultSpace; strcpy(interp->result, dsPtr->string); } else { Tcl_SetResult(interp, dsPtr->string, TCL_VOLATILE); } dsPtr->string = dsPtr->staticSpace; dsPtr->length = 0; dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; dsPtr->staticSpace[0] = 0; } /* *---------------------------------------------------------------------- * * Tcl_DStringGetResult -- * * This procedure moves the result of an interpreter into a * dynamic string. * * Results: * None. * * Side effects: * The interpreter's result is cleared, and the previous contents * of dsPtr are freed. * *---------------------------------------------------------------------- */ void Tcl_DStringGetResult(interp, dsPtr) Tcl_Interp *interp; /* Interpreter whose result is to be * reset. */ Tcl_DString *dsPtr; /* Dynamic string that is to become * the result of interp. */ { Interp *iPtr = (Interp *) interp; if (dsPtr->string != dsPtr->staticSpace) { ckfree(dsPtr->string); } dsPtr->length = strlen(iPtr->result); if (iPtr->freeProc != NULL) { if (iPtr->freeProc == (Tcl_FreeProc *) free) { dsPtr->string = iPtr->result; dsPtr->spaceAvl = dsPtr->length+1; } else { dsPtr->string = ckalloc((unsigned) (dsPtr->length+1)); strcpy(dsPtr->string, iPtr->result); (*iPtr->freeProc)(iPtr->result); } dsPtr->spaceAvl = dsPtr->length+1; iPtr->freeProc = NULL; } else { if (dsPtr->length < TCL_DSTRING_STATIC_SIZE) { dsPtr->string = dsPtr->staticSpace; dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; } else { dsPtr->string = ckalloc((unsigned) (dsPtr->length + 1)); dsPtr->spaceAvl = dsPtr->length + 1; } strcpy(dsPtr->string, iPtr->result); } iPtr->result = iPtr->resultSpace; iPtr->resultSpace[0] = 0; } /* *---------------------------------------------------------------------- * * Tcl_DStringStartSublist -- * * This procedure adds the necessary information to a dynamic * string (e.g. " {" to start a sublist. Future element * appends will be in the sublist rather than the main list. * * Results: * None. * * Side effects: * Characters get added to the dynamic string. * *---------------------------------------------------------------------- */ void Tcl_DStringStartSublist(dsPtr) Tcl_DString *dsPtr; /* Dynamic string. */ { if (TclNeedSpace(dsPtr->string, dsPtr->string + dsPtr->length)) { Tcl_DStringAppend(dsPtr, " {", -1); } else { Tcl_DStringAppend(dsPtr, "{", -1); } } /* *---------------------------------------------------------------------- * * Tcl_DStringEndSublist -- * * This procedure adds the necessary characters to a dynamic * string to end a sublist (e.g. "}"). Future element appends * will be in the enclosing (sub)list rather than the current * sublist. * * Results: * None. * * Side effects: * None. * *---------------------------------------------------------------------- */ void Tcl_DStringEndSublist(dsPtr) Tcl_DString *dsPtr; /* Dynamic string. */ { Tcl_DStringAppend(dsPtr, "}", -1); } /* *---------------------------------------------------------------------- * * Tcl_PrintDouble -- * * Given a floating-point value, this procedure converts it to * an ASCII string using. * * Results: * The ASCII equivalent of "value" is written at "dst". It is * written using the current precision, and it is guaranteed to * contain a decimal point or exponent, so that it looks like * a floating-point value and not an integer. * * Side effects: * None. * *---------------------------------------------------------------------- */ void Tcl_PrintDouble(interp, value, dst) Tcl_Interp *interp; /* Interpreter whose tcl_precision * variable controls printing. */ double value; /* Value to print as string. */ char *dst; /* Where to store converted value; * must have at least TCL_DOUBLE_SPACE * characters. */ { register char *p; sprintf(dst, ((Interp *) interp)->pdFormat, value); /* * If the ASCII result looks like an integer, add ".0" so that it * doesn't look like an integer anymore. This prevents floating-point * values from being converted to integers unintentionally. */ for (p = dst; *p != 0; p++) { if ((*p == '.') || (isalpha(UCHAR(*p)))) { return; } } p[0] = '.'; p[1] = '0'; p[2] = 0; } /* *---------------------------------------------------------------------- * * TclPrecTraceProc -- * * This procedure is invoked whenever the variable "tcl_precision" * is written. * * Results: * Returns NULL if all went well, or an error message if the * new value for the variable doesn't make sense. * * Side effects: * If the new value doesn't make sense then this procedure * undoes the effect of the variable modification. Otherwise * it modifies the format string that's used by Tcl_PrintDouble. * *---------------------------------------------------------------------- */ /* ARGSUSED */ char * TclPrecTraceProc(clientData, interp, name1, name2, flags) ClientData clientData; /* Not used. */ Tcl_Interp *interp; /* Interpreter containing variable. */ char *name1; /* Name of variable. */ char *name2; /* Second part of variable name. */ int flags; /* Information about what happened. */ { register Interp *iPtr = (Interp *) interp; char *value, *end; int prec; /* * If the variable is unset, then recreate the trace and restore * the default value of the format string. */ if (flags & TCL_TRACE_UNSETS) { if ((flags & TCL_TRACE_DESTROYED) && !(flags & TCL_INTERP_DESTROYED)) { Tcl_TraceVar2(interp, name1, name2, TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, TclPrecTraceProc, clientData); } strcpy(iPtr->pdFormat, DEFAULT_PD_FORMAT); iPtr->pdPrec = DEFAULT_PD_PREC; return (char *) NULL; } value = Tcl_GetVar2(interp, name1, name2, flags & TCL_GLOBAL_ONLY); if (value == NULL) { value = ""; } prec = strtoul(value, &end, 10); if ((prec <= 0) || (prec > TCL_MAX_PREC) || (prec > 100) || (end == value) || (*end != 0)) { char oldValue[10]; sprintf(oldValue, "%d", iPtr->pdPrec); Tcl_SetVar2(interp, name1, name2, oldValue, flags & TCL_GLOBAL_ONLY); return "improper value for precision"; } sprintf(iPtr->pdFormat, "%%.%dg", prec); iPtr->pdPrec = prec; return (char *) NULL; } /* *---------------------------------------------------------------------- * * TclNeedSpace -- * * This procedure checks to see whether it is appropriate to * add a space before appending a new list element to an * existing string. * * Results: * The return value is 1 if a space is appropriate, 0 otherwise. * * Side effects: * None. * *---------------------------------------------------------------------- */ int TclNeedSpace(start, end) char *start; /* First character in string. */ char *end; /* End of string (place where space will * be added, if appropriate). */ { /* * A space is needed unless either * (a) we're at the start of the string, or * (b) the trailing characters of the string consist of one or more * open curly braces preceded by a space or extending back to * the beginning of the string. * (c) the trailing characters of the string consist of a space * preceded by a character other than backslash. */ if (end == start) { return 0; } end--; if (*end != '{') { if (isspace(UCHAR(*end)) && ((end == start) || (end[-1] != '\\'))) { return 0; } return 1; } do { if (end == start) { return 0; } end--; } while (*end == '{'); if (isspace(UCHAR(*end))) { return 0; } return 1; } g dynamic * string. */ int length; /* New length for dynamic string. */ { if (length < 0) { length = 0; } if (length >= dsPtr->spaceAvl) { char *newString; dsPtrtcl7.4b4/tclVar.c010044400630510000012000002171150576363613300144440ustar00ousterstaff00002300000001/* * tclVar.c -- * * This file contains routines that implement Tcl variables * (both scalars and arrays). * * The implementation of arrays is modelled after an initial * implementation by Mark Diekhans and Karl Lehenbauer. * * Copyright (c) 1987-1994 The Regents of the University of California. * Copyright (c) 1994-1995 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ static char sccsid[] = "@(#) tclVar.c 1.61 95/06/02 09:29:16"; #include "tclInt.h" #include "tclPort.h" /* * The strings below are used to indicate what went wrong when a * variable access is denied. */ static char *noSuchVar = "no such variable"; static char *isArray = "variable is array"; static char *needArray = "variable isn't array"; static char *noSuchElement = "no such element in array"; static char *danglingUpvar = "upvar refers to element in deleted array"; /* * Creation flag values passed in to LookupVar: * * CRT_PART1 - 1 means create hash table entry for part 1 of * name, if it doesn't already exist. 0 means * return an error if it doesn't exist. * CRT_PART2 - 1 means create hash table entry for part 2 of * name, if it doesn't already exist. 0 means * return an error if it doesn't exist. */ #define CRT_PART1 1 #define CRT_PART2 2 /* * The following additional flag is used internally and passed through * to LookupVar to indicate that a procedure like Tcl_GetVar was called * instead of Tcl_GetVar2 and the single name value hasn't yet been * parsed into an array name and index (if any). */ #define PART1_NOT_PARSED 0x10000 /* * Forward references to procedures defined later in this file: */ static char * CallTraces _ANSI_ARGS_((Interp *iPtr, Var *arrayPtr, Var *varPtr, char *part1, char *part2, int flags)); static void CleanupVar _ANSI_ARGS_((Var *varPtr, Var *arrayPtr)); static void DeleteSearches _ANSI_ARGS_((Var *arrayVarPtr)); static void DeleteArray _ANSI_ARGS_((Interp *iPtr, char *arrayName, Var *varPtr, int flags)); static Var * LookupVar _ANSI_ARGS_((Tcl_Interp *interp, char *part1, char *part2, int flags, char *msg, int create, Var **arrayPtrPtr)); static int MakeUpvar _ANSI_ARGS_((Interp *iPtr, CallFrame *framePtr, char *otherP1, char *otherP2, char *myName, int flags)); static Var * NewVar _ANSI_ARGS_((void)); static ArraySearch * ParseSearchId _ANSI_ARGS_((Tcl_Interp *interp, Var *varPtr, char *varName, char *string)); static void VarErrMsg _ANSI_ARGS_((Tcl_Interp *interp, char *part1, char *part2, char *operation, char *reason)); /* *---------------------------------------------------------------------- * * LookupVar -- * * This procedure is used by virtually all of the variable * code to locate a variable given its name(s). * * Results: * The return value is a pointer to the variable indicated by * part1 and part2, or NULL if the variable couldn't be found. * If the variable is found, *arrayPtrPtr is filled in with * the address of the array that contains the variable (or NULL * if the variable is a scalar). Note: it's possible that the * variable returned may be VAR_UNDEFINED, even if CRT_PART1 and * CRT_PART2 are specified (these only cause the hash table entry * and/or array to be created). * * Side effects: * None. * *---------------------------------------------------------------------- */ static Var * LookupVar(interp, part1, part2, flags, msg, create, arrayPtrPtr) Tcl_Interp *interp; /* Interpreter to use for lookup. */ char *part1; /* If part2 isn't NULL, this is the name * of an array. Otherwise, if the * PART1_NOT_PARSED flag bit is set this * is a full variable name that could * include a parenthesized array elemnt. * If PART1_NOT_PARSED isn't present, then * this is the name of a scalar variable. */ char *part2; /* Name of an element within array, or NULL. */ int flags; /* Only the TCL_GLOBAL_ONLY, TCL_LEAVE_ERR_MSG, * and PART1_NOT_PARSED bits matter. */ char *msg; /* Verb to use in error messages, e.g. * "read" or "set". Only needed if * TCL_LEAVE_ERR_MSG is set in flags. */ int create; /* OR'ed combination of CRT_PART1 and * CRT_PART2. Tells which entries to create * if they don't already exist. */ Var **arrayPtrPtr; /* If the name refers to an element of an * array, *arrayPtrPtr gets filled in with * address of array variable. Otherwise * this is set to NULL. */ { Interp *iPtr = (Interp *) interp; Tcl_HashTable *tablePtr; Tcl_HashEntry *hPtr; Var *varPtr; int new; char *openParen, *closeParen; /* If this procedure parses a name * into array and index, these point * to the parens around the index. * Otherwise they are NULL. These * are needed to restore the parens * after parsing the name. */ char *elName; /* Name of array element or NULL; * may be same as part2, or may be * openParen+1. */ char *p; /* * If the name hasn't been parsed into array name and index yet, * do it now. */ openParen = closeParen = NULL; elName = part2; if (flags & PART1_NOT_PARSED) { for (p = part1; ; p++) { if (*p == 0) { elName = NULL; break; } if (*p == '(') { openParen = p; do { p++; } while (*p != '\0'); p--; if (*p == ')') { closeParen = p; *openParen = 0; elName = openParen+1; } else { openParen = NULL; elName = NULL; } break; } } } /* * Lookup part1. */ *arrayPtrPtr = NULL; if ((flags & TCL_GLOBAL_ONLY) || (iPtr->varFramePtr == NULL)) { tablePtr = &iPtr->globalTable; } else { tablePtr = &iPtr->varFramePtr->varTable; } if (create & CRT_PART1) { hPtr = Tcl_CreateHashEntry(tablePtr, part1, &new); if (openParen != NULL) { *openParen = '('; } if (new) { varPtr = NewVar(); Tcl_SetHashValue(hPtr, varPtr); varPtr->hPtr = hPtr; } } else { hPtr = Tcl_FindHashEntry(tablePtr, part1); if (openParen != NULL) { *openParen = '('; } if (hPtr == NULL) { if (flags & TCL_LEAVE_ERR_MSG) { VarErrMsg(interp, part1, part2, msg, noSuchVar); } return NULL; } } varPtr = (Var *) Tcl_GetHashValue(hPtr); if (varPtr->flags & VAR_UPVAR) { varPtr = varPtr->value.upvarPtr; } if (elName == NULL) { return varPtr; } /* * We're dealing with an array element, so make sure the variable * is an array and lookup the element (create it if desired). */ if (varPtr->flags & VAR_UNDEFINED) { if (!(create & CRT_PART1)) { if (flags & TCL_LEAVE_ERR_MSG) { VarErrMsg(interp, part1, part2, msg, noSuchVar); } return NULL; } varPtr->flags = VAR_ARRAY; varPtr->value.tablePtr = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(varPtr->value.tablePtr, TCL_STRING_KEYS); } else if (!(varPtr->flags & VAR_ARRAY)) { if (flags & TCL_LEAVE_ERR_MSG) { VarErrMsg(interp, part1, part2, msg, needArray); } return NULL; } *arrayPtrPtr = varPtr; if (closeParen != NULL) { *closeParen = 0; } if (create & CRT_PART2) { hPtr = Tcl_CreateHashEntry(varPtr->value.tablePtr, elName, &new); if (closeParen != NULL) { *closeParen = ')'; } if (new) { if (varPtr->searchPtr != NULL) { DeleteSearches(varPtr); } varPtr = NewVar(); Tcl_SetHashValue(hPtr, varPtr); varPtr->hPtr = hPtr; } } else { hPtr = Tcl_FindHashEntry(varPtr->value.tablePtr, elName); if (closeParen != NULL) { *closeParen = ')'; } if (hPtr == NULL) { if (flags & TCL_LEAVE_ERR_MSG) { VarErrMsg(interp, part1, part2, msg, noSuchElement); } return NULL; } } return (Var *) Tcl_GetHashValue(hPtr); } /* *---------------------------------------------------------------------- * * Tcl_GetVar -- * * Return the value of a Tcl variable. * * Results: * The return value points to the current value of varName. If * the variable is not defined or can't be read because of a clash * in array usage then a NULL pointer is returned and an error * message is left in interp->result if the TCL_LEAVE_ERR_MSG * flag is set. Note: the return value is only valid up until * the next call to Tcl_SetVar or Tcl_SetVar2; if you depend on * the value lasting longer than that, then make yourself a private * copy. * * Side effects: * None. * *---------------------------------------------------------------------- */ char * Tcl_GetVar(interp, varName, flags) Tcl_Interp *interp; /* Command interpreter in which varName is * to be looked up. */ char *varName; /* Name of a variable in interp. */ int flags; /* OR-ed combination of TCL_GLOBAL_ONLY * or TCL_LEAVE_ERR_MSG bits. */ { return Tcl_GetVar2(interp, varName, (char *) NULL, flags | PART1_NOT_PARSED); } /* *---------------------------------------------------------------------- * * Tcl_GetVar2 -- * * Return the value of a Tcl variable, given a two-part name * consisting of array name and element within array. * * Results: * The return value points to the current value of the variable * given by part1 and part2. If the specified variable doesn't * exist, or if there is a clash in array usage, then NULL is * returned and a message will be left in interp->result if the * TCL_LEAVE_ERR_MSG flag is set. Note: the return value is * only valid up until the next call to Tcl_SetVar or Tcl_SetVar2; * if you depend on the value lasting longer than that, then make * yourself a private copy. * * Side effects: * None. * *---------------------------------------------------------------------- */ char * Tcl_GetVar2(interp, part1, part2, flags) Tcl_Interp *interp; /* Command interpreter in which variable is * to be looked up. */ char *part1; /* Name of array (if part2 is NULL) or * name of variable. */ char *part2; /* If non-null, gives name of element in * array. */ int flags; /* OR-ed combination of TCL_GLOBAL_ONLY, * TCL_LEAVE_ERR_MSG, and PART1_NOT_PARSED * bits. */ { Var *varPtr, *arrayPtr; Interp *iPtr = (Interp *) interp; varPtr = LookupVar(interp, part1, part2, flags, "read", CRT_PART2, &arrayPtr); if (varPtr == NULL) { return NULL; } /* * Invoke any traces that have been set for the variable. */ if ((varPtr->tracePtr != NULL) || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) { char *msg; msg = CallTraces(iPtr, arrayPtr, varPtr, part1, part2, (flags & (TCL_GLOBAL_ONLY|PART1_NOT_PARSED)) | TCL_TRACE_READS); if (msg != NULL) { VarErrMsg(interp, part1, part2, "read", msg); goto cleanup; } } if (!(varPtr->flags & (VAR_UNDEFINED|VAR_UPVAR|VAR_ARRAY))) { return varPtr->value.string; } if (flags & TCL_LEAVE_ERR_MSG) { char *msg; if ((varPtr->flags & VAR_UNDEFINED) && (arrayPtr != NULL) && !(arrayPtr->flags & VAR_UNDEFINED)) { msg = noSuchElement; } else if (varPtr->flags & VAR_ARRAY) { msg = isArray; } else { msg = noSuchVar; } VarErrMsg(interp, part1, part2, "read", msg); } /* * If the variable doesn't exist anymore and no-one's using it, * then free up the relevant structures and hash table entries. */ cleanup: if (varPtr->flags & VAR_UNDEFINED) { CleanupVar(varPtr, arrayPtr); } return NULL; } /* *---------------------------------------------------------------------- * * Tcl_SetVar -- * * Change the value of a variable. * * Results: * Returns a pointer to the malloc'ed string holding the new * value of the variable. The caller should not modify this * string. If the write operation was disallowed then NULL * is returned; if the TCL_LEAVE_ERR_MSG flag is set, then * an explanatory message will be left in interp->result. * * Side effects: * If varName is defined as a local or global variable in interp, * its value is changed to newValue. If varName isn't currently * defined, then a new global variable by that name is created. * *---------------------------------------------------------------------- */ char * Tcl_SetVar(interp, varName, newValue, flags) Tcl_Interp *interp; /* Command interpreter in which varName is * to be looked up. */ char *varName; /* Name of a variable in interp. */ char *newValue; /* New value for varName. */ int flags; /* Various flags that tell how to set value: * any of TCL_GLOBAL_ONLY, TCL_APPEND_VALUE, * TCL_LIST_ELEMENT, or TCL_LEAVE_ERR_MSG. */ { return Tcl_SetVar2(interp, varName, (char *) NULL, newValue, flags | PART1_NOT_PARSED); } /* *---------------------------------------------------------------------- * * Tcl_SetVar2 -- * * Given a two-part variable name, which may refer either to a * scalar variable or an element of an array, change the value * of the variable. If the named scalar or array or element * doesn't exist then create one. * * Results: * Returns a pointer to the malloc'ed string holding the new * value of the variable. The caller should not modify this * string. If the write operation was disallowed because an * array was expected but not found (or vice versa), then NULL * is returned; if the TCL_LEAVE_ERR_MSG flag is set, then * an explanatory message will be left in interp->result. * * Side effects: * The value of the given variable is set. If either the array * or the entry didn't exist then a new one is created. * *---------------------------------------------------------------------- */ char * Tcl_SetVar2(interp, part1, part2, newValue, flags) Tcl_Interp *interp; /* Command interpreter in which variable is * to be looked up. */ char *part1; /* If part2 is NULL, this is name of scalar * variable. Otherwise it is name of array. */ char *part2; /* Name of an element within array, or NULL. */ char *newValue; /* New value for variable. */ int flags; /* Various flags that tell how to set value: * any of TCL_GLOBAL_ONLY, TCL_APPEND_VALUE, * TCL_LIST_ELEMENT, TCL_LEAVE_ERR_MSG, or * PART1_NOT_PARSED. */ { register Var *varPtr; register Interp *iPtr = (Interp *) interp; int length, listFlags; Var *arrayPtr; char *result; varPtr = LookupVar(interp, part1, part2, flags, "set", CRT_PART1|CRT_PART2, &arrayPtr); if (varPtr == NULL) { return NULL; } /* * If the variable's hPtr field is NULL, it means that this is an * upvar to an array element where the array was deleted, leaving * the element dangling at the end of the upvar. Generate an error * (allowing the variable to be reset would screw up our storage * allocation and is meaningless anyway). */ if (varPtr->hPtr == NULL) { if (flags & TCL_LEAVE_ERR_MSG) { VarErrMsg(interp, part1, part2, "set", danglingUpvar); } return NULL; } /* * Clear the variable's current value unless this is an * append operation. */ if (varPtr->flags & VAR_ARRAY) { if (flags & TCL_LEAVE_ERR_MSG) { VarErrMsg(interp, part1, part2, "set", isArray); } return NULL; } if (!(flags & TCL_APPEND_VALUE) || (varPtr->flags & VAR_UNDEFINED)) { varPtr->valueLength = 0; } /* * Call read trace if variable is being appended to. */ if ((flags & TCL_APPEND_VALUE) && ((varPtr->tracePtr != NULL) || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL)))) { char *msg; msg = CallTraces(iPtr, arrayPtr, varPtr, part1, part2, (flags & (TCL_GLOBAL_ONLY|PART1_NOT_PARSED)) | TCL_TRACE_READS); if (msg != NULL) { VarErrMsg(interp, part1, part2, "read", msg); result = NULL; goto cleanup; } } /* * Compute how many total bytes will be needed for the variable's * new value (leave space for a separating space between list * elements). Allocate new space for the value if needed. */ if (flags & TCL_LIST_ELEMENT) { length = Tcl_ScanElement(newValue, &listFlags) + 1; } else { length = strlen(newValue); } length += varPtr->valueLength; if (length >= varPtr->valueSpace) { char *newValue; int newSize; newSize = 2*varPtr->valueSpace; if (newSize <= length) { newSize = length + 1; } if (newSize < 24) { /* * Don't waste time with teensy-tiny variables; we'll * just end up expanding them later. */ newSize = 24; } newValue = ckalloc((unsigned) newSize); if (varPtr->valueSpace > 0) { strcpy(newValue, varPtr->value.string); ckfree(varPtr->value.string); } varPtr->valueSpace = newSize; varPtr->value.string = newValue; } /* * Append the new value to the variable, either as a list * element or as a string. */ if (flags & TCL_LIST_ELEMENT) { char *dst = varPtr->value.string + varPtr->valueLength; if (TclNeedSpace(varPtr->value.string, dst)) { *dst = ' '; dst++; varPtr->valueLength++; } varPtr->valueLength += Tcl_ConvertElement(newValue, dst, listFlags); } else { strcpy(varPtr->value.string + varPtr->valueLength, newValue); varPtr->valueLength = length; } varPtr->flags &= ~VAR_UNDEFINED; /* * Invoke any write traces for the variable. */ if ((varPtr->tracePtr != NULL) || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) { char *msg; msg = CallTraces(iPtr, arrayPtr, varPtr, part1, part2, (flags & (TCL_GLOBAL_ONLY|PART1_NOT_PARSED)) | TCL_TRACE_WRITES); if (msg != NULL) { VarErrMsg(interp, part1, part2, "set", msg); result = NULL; goto cleanup; } } /* * If the variable was changed in some gross way by a trace (e.g. * it was unset and then recreated as an array) then just return * an empty string; otherwise return the variable's current * value. */ if (!(varPtr->flags & (VAR_UNDEFINED|VAR_UPVAR|VAR_ARRAY))) { return varPtr->value.string; } result = ""; /* * If the variable doesn't exist anymore and no-one's using it, * then free up the relevant structures and hash table entries. */ cleanup: if (varPtr->flags & VAR_UNDEFINED) { CleanupVar(varPtr, arrayPtr); } return result; } /* *---------------------------------------------------------------------- * * Tcl_UnsetVar -- * * Delete a variable, so that it may not be accessed anymore. * * Results: * Returns TCL_OK if the variable was successfully deleted, TCL_ERROR * if the variable can't be unset. In the event of an error, * if the TCL_LEAVE_ERR_MSG flag is set then an error message * is left in interp->result. * * Side effects: * If varName is defined as a local or global variable in interp, * it is deleted. * *---------------------------------------------------------------------- */ int Tcl_UnsetVar(interp, varName, flags) Tcl_Interp *interp; /* Command interpreter in which varName is * to be looked up. */ char *varName; /* Name of a variable in interp. May be * either a scalar name or an array name * or an element in an array. */ int flags; /* OR-ed combination of any of * TCL_GLOBAL_ONLY or TCL_LEAVE_ERR_MSG. */ { return Tcl_UnsetVar2(interp, varName, (char *) NULL, flags | PART1_NOT_PARSED); } /* *---------------------------------------------------------------------- * * Tcl_UnsetVar2 -- * * Delete a variable, given a 2-part name. * * Results: * Returns TCL_OK if the variable was successfully deleted, TCL_ERROR * if the variable can't be unset. In the event of an error, * if the TCL_LEAVE_ERR_MSG flag is set then an error message * is left in interp->result. * * Side effects: * If part1 and part2 indicate a local or global variable in interp, * it is deleted. If part1 is an array name and part2 is NULL, then * the whole array is deleted. * *---------------------------------------------------------------------- */ int Tcl_UnsetVar2(interp, part1, part2, flags) Tcl_Interp *interp; /* Command interpreter in which varName is * to be looked up. */ char *part1; /* Name of variable or array. */ char *part2; /* Name of element within array or NULL. */ int flags; /* OR-ed combination of any of * TCL_GLOBAL_ONLY, TCL_LEAVE_ERR_MSG, * or PART1_NOT_PARSED. */ { Var *varPtr, dummyVar; Interp *iPtr = (Interp *) interp; Var *arrayPtr; ActiveVarTrace *activePtr; int result; varPtr = LookupVar(interp, part1, part2, flags, "unset", 0, &arrayPtr); if (varPtr == NULL) { return TCL_ERROR; } result = (varPtr->flags & VAR_UNDEFINED) ? TCL_ERROR : TCL_OK; if ((arrayPtr != NULL) && (arrayPtr->searchPtr != NULL)) { DeleteSearches(arrayPtr); } /* * The code below is tricky, because of the possibility that * a trace procedure might try to access a variable being * deleted. To handle this situation gracefully, do things * in three steps: * 1. Copy the contents of the variable to a dummy variable * structure, and mark the original structure as undefined. * 2. Invoke traces and clean up the variable, using the copy. * 3. If at the end of this the original variable is still * undefined and has no outstanding references, then delete * it (but it could have gotten recreated by a trace). */ dummyVar = *varPtr; varPtr->valueSpace = 0; varPtr->flags = VAR_UNDEFINED; varPtr->tracePtr = NULL; varPtr->searchPtr = NULL; /* * Call trace procedures for the variable being deleted and delete * its traces. Be sure to abort any other traces for the variable * that are still pending. Special tricks: * 1. Increment varPtr's refCount around this: CallTraces will * use dummyVar so it won't increment varPtr's refCount. * 2. Turn off the VAR_TRACE_ACTIVE flag in dummyVar: we want to * call unset traces even if other traces are pending. */ if ((dummyVar.tracePtr != NULL) || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) { varPtr->refCount++; dummyVar.flags &= ~VAR_TRACE_ACTIVE; (void) CallTraces(iPtr, arrayPtr, &dummyVar, part1, part2, (flags & (TCL_GLOBAL_ONLY|PART1_NOT_PARSED)) | TCL_TRACE_UNSETS); while (dummyVar.tracePtr != NULL) { VarTrace *tracePtr = dummyVar.tracePtr; dummyVar.tracePtr = tracePtr->nextPtr; ckfree((char *) tracePtr); } for (activePtr = iPtr->activeTracePtr; activePtr != NULL; activePtr = activePtr->nextPtr) { if (activePtr->varPtr == varPtr) { activePtr->nextTracePtr = NULL; } } varPtr->refCount--; } /* * If the variable is an array, delete all of its elements. This * must be done after calling the traces on the array, above (that's * the way traces are defined). */ if (dummyVar.flags & VAR_ARRAY) { DeleteArray(iPtr, part1, &dummyVar, (flags & TCL_GLOBAL_ONLY) | TCL_TRACE_UNSETS); } if (dummyVar.valueSpace > 0) { ckfree(dummyVar.value.string); } if (result == TCL_ERROR) { if (flags & TCL_LEAVE_ERR_MSG) { VarErrMsg(interp, part1, part2, "unset", (arrayPtr == NULL) ? noSuchVar : noSuchElement); } } /* * Finally, if the variable is truly not in use then free up its * record and remove it from the hash table. */ CleanupVar(varPtr, arrayPtr); return result; } /* *---------------------------------------------------------------------- * * Tcl_TraceVar -- * * Arrange for reads and/or writes to a variable to cause a * procedure to be invoked, which can monitor the operations * and/or change their actions. * * Results: * A standard Tcl return value. * * Side effects: * A trace is set up on the variable given by varName, such that * future references to the variable will be intermediated by * proc. See the manual entry for complete details on the calling * sequence for proc. * *---------------------------------------------------------------------- */ int Tcl_TraceVar(interp, varName, flags, proc, clientData) Tcl_Interp *interp; /* Interpreter in which variable is * to be traced. */ char *varName; /* Name of variable; may end with "(index)" * to signify an array reference. */ int flags; /* OR-ed collection of bits, including any * of TCL_TRACE_READS, TCL_TRACE_WRITES, * TCL_TRACE_UNSETS, and TCL_GLOBAL_ONLY. */ Tcl_VarTraceProc *proc; /* Procedure to call when specified ops are * invoked upon varName. */ ClientData clientData; /* Arbitrary argument to pass to proc. */ { return Tcl_TraceVar2(interp, varName, (char *) NULL, flags | PART1_NOT_PARSED, proc, clientData); } /* *---------------------------------------------------------------------- * * Tcl_TraceVar2 -- * * Arrange for reads and/or writes to a variable to cause a * procedure to be invoked, which can monitor the operations * and/or change their actions. * * Results: * A standard Tcl return value. * * Side effects: * A trace is set up on the variable given by part1 and part2, such * that future references to the variable will be intermediated by * proc. See the manual entry for complete details on the calling * sequence for proc. * *---------------------------------------------------------------------- */ int Tcl_TraceVar2(interp, part1, part2, flags, proc, clientData) Tcl_Interp *interp; /* Interpreter in which variable is * to be traced. */ char *part1; /* Name of scalar variable or array. */ char *part2; /* Name of element within array; NULL means * trace applies to scalar variable or array * as-a-whole. */ int flags; /* OR-ed collection of bits, including any * of TCL_TRACE_READS, TCL_TRACE_WRITES, * TCL_TRACE_UNSETS, TCL_GLOBAL_ONLY, and * PART1_NOT_PARSED. */ Tcl_VarTraceProc *proc; /* Procedure to call when specified ops are * invoked upon varName. */ ClientData clientData; /* Arbitrary argument to pass to proc. */ { Var *varPtr, *arrayPtr; register VarTrace *tracePtr; varPtr = LookupVar(interp, part1, part2, (flags | TCL_LEAVE_ERR_MSG), "trace", CRT_PART1|CRT_PART2, &arrayPtr); if (varPtr == NULL) { return TCL_ERROR; } /* * Set up trace information. */ tracePtr = (VarTrace *) ckalloc(sizeof(VarTrace)); tracePtr->traceProc = proc; tracePtr->clientData = clientData; tracePtr->flags = flags & (TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS); tracePtr->nextPtr = varPtr->tracePtr; varPtr->tracePtr = tracePtr; return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_UntraceVar -- * * Remove a previously-created trace for a variable. * * Results: * None. * * Side effects: * If there exists a trace for the variable given by varName * with the given flags, proc, and clientData, then that trace * is removed. * *---------------------------------------------------------------------- */ void Tcl_UntraceVar(interp, varName, flags, proc, clientData) Tcl_Interp *interp; /* Interpreter containing traced variable. */ char *varName; /* Name of variable; may end with "(index)" * to signify an array reference. */ int flags; /* OR-ed collection of bits describing * current trace, including any of * TCL_TRACE_READS, TCL_TRACE_WRITES, * TCL_TRACE_UNSETS, and TCL_GLOBAL_ONLY. */ Tcl_VarTraceProc *proc; /* Procedure assocated with trace. */ ClientData clientData; /* Arbitrary argument to pass to proc. */ { Tcl_UntraceVar2(interp, varName, (char *) NULL, flags | PART1_NOT_PARSED, proc, clientData); } /* *---------------------------------------------------------------------- * * Tcl_UntraceVar2 -- * * Remove a previously-created trace for a variable. * * Results: * None. * * Side effects: * If there exists a trace for the variable given by part1 * and part2 with the given flags, proc, and clientData, then * that trace is removed. * *---------------------------------------------------------------------- */ void Tcl_UntraceVar2(interp, part1, part2, flags, proc, clientData) Tcl_Interp *interp; /* Interpreter containing traced variable. */ char *part1; /* Name of variable or array. */ char *part2; /* Name of element within array; NULL means * trace applies to scalar variable or array * as-a-whole. */ int flags; /* OR-ed collection of bits describing * current trace, including any of * TCL_TRACE_READS, TCL_TRACE_WRITES, * TCL_TRACE_UNSETS, TCL_GLOBAL_ONLY, and * PART1_NOT_PARSED. */ Tcl_VarTraceProc *proc; /* Procedure assocated with trace. */ ClientData clientData; /* Arbitrary argument to pass to proc. */ { register VarTrace *tracePtr; VarTrace *prevPtr; Var *varPtr, *arrayPtr; Interp *iPtr = (Interp *) interp; ActiveVarTrace *activePtr; varPtr = LookupVar(interp, part1, part2, flags & (TCL_GLOBAL_ONLY|PART1_NOT_PARSED), (char *) NULL, 0, &arrayPtr); if (varPtr == NULL) { return; } flags &= (TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS); for (tracePtr = varPtr->tracePtr, prevPtr = NULL; ; prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) { if (tracePtr == NULL) { return; } if ((tracePtr->traceProc == proc) && (tracePtr->flags == flags) && (tracePtr->clientData == clientData)) { break; } } /* * The code below makes it possible to delete traces while traces * are active: it makes sure that the deleted trace won't be * processed by CallTraces. */ for (activePtr = iPtr->activeTracePtr; activePtr != NULL; activePtr = activePtr->nextPtr) { if (activePtr->nextTracePtr == tracePtr) { activePtr->nextTracePtr = tracePtr->nextPtr; } } if (prevPtr == NULL) { varPtr->tracePtr = tracePtr->nextPtr; } else { prevPtr->nextPtr = tracePtr->nextPtr; } ckfree((char *) tracePtr); /* * If this is the last trace on the variable, and the variable is * unset and unused, then free up the variable. */ if (varPtr->flags & VAR_UNDEFINED) { CleanupVar(varPtr, (Var *) NULL); } } /* *---------------------------------------------------------------------- * * Tcl_VarTraceInfo -- * * Return the clientData value associated with a trace on a * variable. This procedure can also be used to step through * all of the traces on a particular variable that have the * same trace procedure. * * Results: * The return value is the clientData value associated with * a trace on the given variable. Information will only be * returned for a trace with proc as trace procedure. If * the clientData argument is NULL then the first such trace is * returned; otherwise, the next relevant one after the one * given by clientData will be returned. If the variable * doesn't exist, or if there are no (more) traces for it, * then NULL is returned. * * Side effects: * None. * *---------------------------------------------------------------------- */ ClientData Tcl_VarTraceInfo(interp, varName, flags, proc, prevClientData) Tcl_Interp *interp; /* Interpreter containing variable. */ char *varName; /* Name of variable; may end with "(index)" * to signify an array reference. */ int flags; /* 0 or TCL_GLOBAL_ONLY. */ Tcl_VarTraceProc *proc; /* Procedure assocated with trace. */ ClientData prevClientData; /* If non-NULL, gives last value returned * by this procedure, so this call will * return the next trace after that one. * If NULL, this call will return the * first trace. */ { return Tcl_VarTraceInfo2(interp, varName, (char *) NULL, flags | PART1_NOT_PARSED, proc, prevClientData); } /* *---------------------------------------------------------------------- * * Tcl_VarTraceInfo2 -- * * Same as Tcl_VarTraceInfo, except takes name in two pieces * instead of one. * * Results: * Same as Tcl_VarTraceInfo. * * Side effects: * None. * *---------------------------------------------------------------------- */ ClientData Tcl_VarTraceInfo2(interp, part1, part2, flags, proc, prevClientData) Tcl_Interp *interp; /* Interpreter containing variable. */ char *part1; /* Name of variable or array. */ char *part2; /* Name of element within array; NULL means * trace applies to scalar variable or array * as-a-whole. */ int flags; /* OR-ed combination of TCL_GLOBAL_ONLY and * PART1_NOT_PARSED. */ Tcl_VarTraceProc *proc; /* Procedure assocated with trace. */ ClientData prevClientData; /* If non-NULL, gives last value returned * by this procedure, so this call will * return the next trace after that one. * If NULL, this call will return the * first trace. */ { register VarTrace *tracePtr; Var *varPtr, *arrayPtr; varPtr = LookupVar(interp, part1, part2, flags & (TCL_GLOBAL_ONLY|PART1_NOT_PARSED), (char *) NULL, 0, &arrayPtr); if (varPtr == NULL) { return NULL; } /* * Find the relevant trace, if any, and return its clientData. */ tracePtr = varPtr->tracePtr; if (prevClientData != NULL) { for ( ; tracePtr != NULL; tracePtr = tracePtr->nextPtr) { if ((tracePtr->clientData == prevClientData) && (tracePtr->traceProc == proc)) { tracePtr = tracePtr->nextPtr; break; } } } for ( ; tracePtr != NULL; tracePtr = tracePtr->nextPtr) { if (tracePtr->traceProc == proc) { return tracePtr->clientData; } } return NULL; } /* *---------------------------------------------------------------------- * * Tcl_SetCmd -- * * This procedure is invoked to process the "set" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result value. * * Side effects: * A variable's value may be changed. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_SetCmd(dummy, interp, argc, argv) ClientData dummy; /* Not used. */ register Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { if (argc == 2) { char *value; value = Tcl_GetVar2(interp, argv[1], (char *) NULL, TCL_LEAVE_ERR_MSG|PART1_NOT_PARSED); if (value == NULL) { return TCL_ERROR; } interp->result = value; return TCL_OK; } else if (argc == 3) { char *result; result = Tcl_SetVar2(interp, argv[1], (char *) NULL, argv[2], TCL_LEAVE_ERR_MSG|PART1_NOT_PARSED); if (result == NULL) { return TCL_ERROR; } interp->result = result; return TCL_OK; } else { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " varName ?newValue?\"", (char *) NULL); return TCL_ERROR; } } /* *---------------------------------------------------------------------- * * Tcl_UnsetCmd -- * * This procedure is invoked to process the "unset" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result value. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_UnsetCmd(dummy, interp, argc, argv) ClientData dummy; /* Not used. */ register Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { int i; if (argc < 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " varName ?varName ...?\"", (char *) NULL); return TCL_ERROR; } for (i = 1; i < argc; i++) { if (Tcl_UnsetVar2(interp, argv[i], (char *) NULL, TCL_LEAVE_ERR_MSG|PART1_NOT_PARSED) != TCL_OK) { return TCL_ERROR; } } return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_AppendCmd -- * * This procedure is invoked to process the "append" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result value. * * Side effects: * A variable's value may be changed. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_AppendCmd(dummy, interp, argc, argv) ClientData dummy; /* Not used. */ register Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { int i; char *result = NULL; /* (Initialization only needed to keep * the compiler from complaining) */ if (argc < 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " varName ?value value ...?\"", (char *) NULL); return TCL_ERROR; } if (argc == 2) { result = Tcl_GetVar2(interp, argv[1], (char *) NULL, TCL_LEAVE_ERR_MSG|PART1_NOT_PARSED); if (result == NULL) { return TCL_ERROR; } interp->result = result; return TCL_OK; } for (i = 2; i < argc; i++) { result = Tcl_SetVar2(interp, argv[1], (char *) NULL, argv[i], TCL_APPEND_VALUE|TCL_LEAVE_ERR_MSG|PART1_NOT_PARSED); if (result == NULL) { return TCL_ERROR; } } interp->result = result; return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_LappendCmd -- * * This procedure is invoked to process the "lappend" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result value. * * Side effects: * A variable's value may be changed. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_LappendCmd(dummy, interp, argc, argv) ClientData dummy; /* Not used. */ register Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { int i; char *result = NULL; /* (Initialization only needed to keep * the compiler from complaining) */ if (argc < 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " varName ?value value ...?\"", (char *) NULL); return TCL_ERROR; } if (argc == 2) { result = Tcl_GetVar2(interp, argv[1], (char *) NULL, TCL_LEAVE_ERR_MSG|PART1_NOT_PARSED); if (result == NULL) { return TCL_ERROR; } interp->result = result; return TCL_OK; } for (i = 2; i < argc; i++) { result = Tcl_SetVar2(interp, argv[1], (char *) NULL, argv[i], TCL_APPEND_VALUE|TCL_LIST_ELEMENT|TCL_LEAVE_ERR_MSG |PART1_NOT_PARSED); if (result == NULL) { return TCL_ERROR; } } interp->result = result; return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_ArrayCmd -- * * This procedure is invoked to process the "array" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result value. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_ArrayCmd(dummy, interp, argc, argv) ClientData dummy; /* Not used. */ register Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { int c, notArray; size_t length; Var *varPtr = NULL; /* Initialization needed only to prevent * compiler warning. */ Tcl_HashEntry *hPtr; Interp *iPtr = (Interp *) interp; if (argc < 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " option arrayName ?arg ...?\"", (char *) NULL); return TCL_ERROR; } /* * Locate the array variable (and it better be an array). */ if (iPtr->varFramePtr == NULL) { hPtr = Tcl_FindHashEntry(&iPtr->globalTable, argv[2]); } else { hPtr = Tcl_FindHashEntry(&iPtr->varFramePtr->varTable, argv[2]); } notArray = 0; if (hPtr == NULL) { notArray = 1; } else { varPtr = (Var *) Tcl_GetHashValue(hPtr); if (varPtr->flags & VAR_UPVAR) { varPtr = varPtr->value.upvarPtr; } if (!(varPtr->flags & VAR_ARRAY)) { notArray = 1; } } /* * Dispatch based on the option. */ c = argv[1][0]; length = strlen(argv[1]); if ((c == 'a') && (strncmp(argv[1], "anymore", length) == 0)) { ArraySearch *searchPtr; if (argc != 4) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " anymore arrayName searchId\"", (char *) NULL); return TCL_ERROR; } if (notArray) { goto error; } searchPtr = ParseSearchId(interp, varPtr, argv[2], argv[3]); if (searchPtr == NULL) { return TCL_ERROR; } while (1) { Var *varPtr2; if (searchPtr->nextEntry != NULL) { varPtr2 = (Var *) Tcl_GetHashValue(searchPtr->nextEntry); if (!(varPtr2->flags & VAR_UNDEFINED)) { break; } } searchPtr->nextEntry = Tcl_NextHashEntry(&searchPtr->search); if (searchPtr->nextEntry == NULL) { interp->result = "0"; return TCL_OK; } } interp->result = "1"; return TCL_OK; } else if ((c == 'd') && (strncmp(argv[1], "donesearch", length) == 0)) { ArraySearch *searchPtr, *prevPtr; if (argc != 4) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " donesearch arrayName searchId\"", (char *) NULL); return TCL_ERROR; } if (notArray) { goto error; } searchPtr = ParseSearchId(interp, varPtr, argv[2], argv[3]); if (searchPtr == NULL) { return TCL_ERROR; } if (varPtr->searchPtr == searchPtr) { varPtr->searchPtr = searchPtr->nextPtr; } else { for (prevPtr = varPtr->searchPtr; ; prevPtr = prevPtr->nextPtr) { if (prevPtr->nextPtr == searchPtr) { prevPtr->nextPtr = searchPtr->nextPtr; break; } } } ckfree((char *) searchPtr); } else if ((c == 'e') && (strncmp(argv[1], "exists", length) == 0)) { if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " exists arrayName\"", (char *) NULL); return TCL_ERROR; } interp->result = (notArray) ? "0" : "1"; } else if ((c == 'g') && (strncmp(argv[1], "get", length) == 0)) { Tcl_HashSearch search; Var *varPtr2; char *name; if ((argc != 3) && (argc != 4)) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " get arrayName ?pattern?\"", (char *) NULL); return TCL_ERROR; } if (notArray) { return TCL_OK; } for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search); hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { varPtr2 = (Var *) Tcl_GetHashValue(hPtr); if (varPtr2->flags & VAR_UNDEFINED) { continue; } name = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr); if ((argc == 4) && !Tcl_StringMatch(name, argv[3])) { continue; } Tcl_AppendElement(interp, name); Tcl_AppendElement(interp, varPtr2->value.string); } } else if ((c == 'n') && (strncmp(argv[1], "names", length) == 0) && (length >= 2)) { Tcl_HashSearch search; Var *varPtr2; char *name; if ((argc != 3) && (argc != 4)) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " names arrayName ?pattern?\"", (char *) NULL); return TCL_ERROR; } if (notArray) { return TCL_OK; } for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search); hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { varPtr2 = (Var *) Tcl_GetHashValue(hPtr); if (varPtr2->flags & VAR_UNDEFINED) { continue; } name = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr); if ((argc == 4) && !Tcl_StringMatch(name, argv[3])) { continue; } Tcl_AppendElement(interp, name); } } else if ((c == 'n') && (strncmp(argv[1], "nextelement", length) == 0) && (length >= 2)) { ArraySearch *searchPtr; Tcl_HashEntry *hPtr; if (argc != 4) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " nextelement arrayName searchId\"", (char *) NULL); return TCL_ERROR; } if (notArray) { goto error; } searchPtr = ParseSearchId(interp, varPtr, argv[2], argv[3]); if (searchPtr == NULL) { return TCL_ERROR; } while (1) { Var *varPtr2; hPtr = searchPtr->nextEntry; if (hPtr == NULL) { hPtr = Tcl_NextHashEntry(&searchPtr->search); if (hPtr == NULL) { return TCL_OK; } } else { searchPtr->nextEntry = NULL; } varPtr2 = (Var *) Tcl_GetHashValue(hPtr); if (!(varPtr2->flags & VAR_UNDEFINED)) { break; } } interp->result = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr); } else if ((c == 's') && (strncmp(argv[1], "set", length) == 0) && (length >= 2)) { char **valueArgv; int valueArgc, i, result; if (argc != 4) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " set arrayName list\"", (char *) NULL); return TCL_ERROR; } if (Tcl_SplitList(interp, argv[3], &valueArgc, &valueArgv) != TCL_OK) { return TCL_ERROR; } result = TCL_OK; if (valueArgc & 1) { interp->result = "list must have an even number of elements"; result = TCL_ERROR; goto setDone; } for (i = 0; i < valueArgc; i += 2) { if (Tcl_SetVar2(interp, argv[2], valueArgv[i], valueArgv[i+1], TCL_LEAVE_ERR_MSG) == NULL) { result = TCL_ERROR; break; } } setDone: ckfree((char *) valueArgv); return result; } else if ((c == 's') && (strncmp(argv[1], "size", length) == 0) && (length >= 2)) { Tcl_HashSearch search; Var *varPtr2; int size; if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " size arrayName\"", (char *) NULL); return TCL_ERROR; } size = 0; if (!notArray) { for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search); hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { varPtr2 = (Var *) Tcl_GetHashValue(hPtr); if (varPtr2->flags & VAR_UNDEFINED) { continue; } size++; } } sprintf(interp->result, "%d", size); } else if ((c == 's') && (strncmp(argv[1], "startsearch", length) == 0) && (length >= 2)) { ArraySearch *searchPtr; if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " startsearch arrayName\"", (char *) NULL); return TCL_ERROR; } if (notArray) { goto error; } searchPtr = (ArraySearch *) ckalloc(sizeof(ArraySearch)); if (varPtr->searchPtr == NULL) { searchPtr->id = 1; Tcl_AppendResult(interp, "s-1-", argv[2], (char *) NULL); } else { char string[20]; searchPtr->id = varPtr->searchPtr->id + 1; sprintf(string, "%d", searchPtr->id); Tcl_AppendResult(interp, "s-", string, "-", argv[2], (char *) NULL); } searchPtr->varPtr = varPtr; searchPtr->nextEntry = Tcl_FirstHashEntry(varPtr->value.tablePtr, &searchPtr->search); searchPtr->nextPtr = varPtr->searchPtr; varPtr->searchPtr = searchPtr; } else { Tcl_AppendResult(interp, "bad option \"", argv[1], "\": should be anymore, donesearch, exists, ", "get, names, nextelement, ", "set, size, or startsearch", (char *) NULL); return TCL_ERROR; } return TCL_OK; error: Tcl_AppendResult(interp, "\"", argv[2], "\" isn't an array", (char *) NULL); return TCL_ERROR; } /* *---------------------------------------------------------------------- * * MakeUpvar -- * * This procedure does all of the work of the "global" and "upvar" * commands. * * Results: * A standard Tcl completion code. If an error occurs then an * error message is left in iPtr->result. * * Side effects: * The variable given by myName is linked to the variable in * framePtr given by otherP1 and otherP2, so that references to * myName are redirected to the other variable like a symbolic * link. * *---------------------------------------------------------------------- */ static int MakeUpvar(iPtr, framePtr, otherP1, otherP2, myName, flags) Interp *iPtr; /* Interpreter containing variables. Used * for error messages, too. */ CallFrame *framePtr; /* Call frame containing "other" variable. * NULL means use global context. */ char *otherP1, *otherP2; /* Two-part name of variable in framePtr. */ char *myName; /* Name of variable in local table, which * will refer to otherP1/P2. Must be a * scalar. */ int flags; /* 0 or TCL_GLOBAL_ONLY: indicates scope of * myName. */ { Tcl_HashEntry *hPtr; Var *otherPtr, *varPtr, *arrayPtr; CallFrame *savedFramePtr; int new; /* * In order to use LookupVar to find "other", temporarily replace * the current frame pointer in the interpreter. */ savedFramePtr = iPtr->varFramePtr; iPtr->varFramePtr = framePtr; otherPtr = LookupVar((Tcl_Interp *) iPtr, otherP1, otherP2, TCL_LEAVE_ERR_MSG, "access", CRT_PART1|CRT_PART2, &arrayPtr); iPtr->varFramePtr = savedFramePtr; if (otherPtr == NULL) { return TCL_ERROR; } if ((flags & TCL_GLOBAL_ONLY) || (iPtr->varFramePtr == NULL)) { hPtr = Tcl_CreateHashEntry(&iPtr->globalTable, myName, &new); } else { hPtr = Tcl_CreateHashEntry(&iPtr->varFramePtr->varTable, myName, &new); } if (new) { varPtr = NewVar(); Tcl_SetHashValue(hPtr, varPtr); varPtr->hPtr = hPtr; } else { /* * The variable already exists. Make sure that this variable * isn't also "otherVar" (avoid circular links). Also, if it's * not an upvar then it's an error. If it is an upvar, then * just disconnect it from the thing it currently refers to. */ varPtr = (Var *) Tcl_GetHashValue(hPtr); if (varPtr == otherPtr) { iPtr->result = "can't upvar from variable to itself"; return TCL_ERROR; } if (varPtr->flags & VAR_UPVAR) { Var *upvarPtr; upvarPtr = varPtr->value.upvarPtr; if (upvarPtr == otherPtr) { return TCL_OK; } upvarPtr->refCount--; if (upvarPtr->flags & VAR_UNDEFINED) { CleanupVar(upvarPtr, (Var *) NULL); } } else if (!(varPtr->flags & VAR_UNDEFINED)) { Tcl_AppendResult((Tcl_Interp *) iPtr, "variable \"", myName, "\" already exists", (char *) NULL); return TCL_ERROR; } } varPtr->flags = (varPtr->flags & ~VAR_UNDEFINED) | VAR_UPVAR; varPtr->value.upvarPtr = otherPtr; otherPtr->refCount++; return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_UpVar -- * * Delete a variable, so that it may not be accessed anymore. * * Results: * Returns TCL_OK if the variable was successfully deleted, TCL_ERROR * if the variable can't be unset. In the event of an error, * if the TCL_LEAVE_ERR_MSG flag is set then an error message * is left in interp->result. * * Side effects: * If varName is defined as a local or global variable in interp, * it is deleted. * *---------------------------------------------------------------------- */ int Tcl_UpVar(interp, frameName, varName, localName, flags) Tcl_Interp *interp; /* Command interpreter in which varName is * to be looked up. */ char *frameName; /* Name of the frame containing the source * variable, such as "1" or "#0". */ char *varName; /* Name of a variable in interp. May be * either a scalar name or an element * in an array. */ char *localName; /* Destination variable name. */ int flags; /* Either 0 or TCL_GLOBAL_ONLY; indicates * whether localName is local or global. */ { int result; CallFrame *framePtr; register char *p; result = TclGetFrame(interp, frameName, &framePtr); if (result == -1) { return TCL_ERROR; } /* * Figure out whether this is an array reference, then call * Tcl_UpVar2 to do all the real work. */ for (p = varName; *p != '\0'; p++) { if (*p == '(') { char *openParen = p; do { p++; } while (*p != '\0'); p--; if (*p != ')') { goto scalar; } *openParen = '\0'; *p = '\0'; result = MakeUpvar((Interp *) interp, framePtr, varName, openParen+1, localName, flags); *openParen = '('; *p = ')'; return result; } } scalar: return MakeUpvar((Interp *) interp, framePtr, varName, (char *) NULL, localName, flags); } /* *---------------------------------------------------------------------- * * Tcl_UpVar2 -- * * This procedure links one variable to another, just like * the "upvar" command. * * Results: * A standard Tcl completion code. If an error occurs then * an error message is left in interp->result. * * Side effects: * The variable in frameName whose name is given by part1 and * part2 becomes accessible under the name newName, so that * references to newName are redirected to the other variable * like a symbolic link. * *---------------------------------------------------------------------- */ int Tcl_UpVar2(interp, frameName, part1, part2, localName, flags) Tcl_Interp *interp; /* Interpreter containing variables. Used * for error messages too. */ char *frameName; /* Name of the frame containing the source * variable, such as "1" or "#0". */ char *part1, *part2; /* Two parts of source variable name. */ char *localName; /* Destination variable name. */ int flags; /* TCL_GLOBAL_ONLY or 0. */ { int result; CallFrame *framePtr; result = TclGetFrame(interp, frameName, &framePtr); if (result == -1) { return TCL_ERROR; } return MakeUpvar((Interp *) interp, framePtr, part1, part2, localName, flags); } /* *---------------------------------------------------------------------- * * Tcl_GlobalCmd -- * * This procedure is invoked to process the "global" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result value. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_GlobalCmd(dummy, interp, argc, argv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { register Interp *iPtr = (Interp *) interp; if (argc < 2) { Tcl_AppendResult((Tcl_Interp *) iPtr, "wrong # args: should be \"", argv[0], " varName ?varName ...?\"", (char *) NULL); return TCL_ERROR; } if (iPtr->varFramePtr == NULL) { return TCL_OK; } for (argc--, argv++; argc > 0; argc--, argv++) { if (MakeUpvar(iPtr, (CallFrame *) NULL, *argv, (char *) NULL, *argv, 0) != TCL_OK) { return TCL_ERROR; } } return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_UpvarCmd -- * * This procedure is invoked to process the "upvar" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result value. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_UpvarCmd(dummy, interp, argc, argv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { register Interp *iPtr = (Interp *) interp; int result; CallFrame *framePtr; register char *p; if (argc < 3) { upvarSyntax: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " ?level? otherVar localVar ?otherVar localVar ...?\"", (char *) NULL); return TCL_ERROR; } /* * Find the hash table containing the variable being referenced. */ result = TclGetFrame(interp, argv[1], &framePtr); if (result == -1) { return TCL_ERROR; } argc -= result+1; if ((argc & 1) != 0) { goto upvarSyntax; } argv += result+1; /* * Iterate over all the pairs of (other variable, local variable) * names. For each pair, divide the other variable name into two * parts, then call MakeUpvar to do all the work of creating linking * it to the local variable. */ for ( ; argc > 0; argc -= 2, argv += 2) { for (p = argv[0]; *p != 0; p++) { if (*p == '(') { char *openParen = p; do { p++; } while (*p != '\0'); p--; if (*p != ')') { goto scalar; } *openParen = '\0'; *p = '\0'; result = MakeUpvar(iPtr, framePtr, argv[0], openParen+1, argv[1], 0); *openParen = '('; *p = ')'; goto checkResult; } } scalar: result = MakeUpvar(iPtr, framePtr, argv[0], (char *) NULL, argv[1], 0); checkResult: if (result != TCL_OK) { return TCL_ERROR; } } return TCL_OK; } /* *---------------------------------------------------------------------- * * CallTraces -- * * This procedure is invoked to find and invoke relevant * trace procedures associated with a particular operation on * a variable. This procedure invokes traces both on the * variable and on its containing array (where relevant). * * Results: * The return value is NULL if no trace procedures were invoked, or * if all the invoked trace procedures returned successfully. * The return value is non-zero if a trace procedure returned an * error (in this case no more trace procedures were invoked after * the error was returned). In this case the return value is a * pointer to a static string describing the error. * * Side effects: * Almost anything can happen, depending on trace; this procedure * itself doesn't have any side effects. * *---------------------------------------------------------------------- */ static char * CallTraces(iPtr, arrayPtr, varPtr, part1, part2, flags) Interp *iPtr; /* Interpreter containing variable. */ register Var *arrayPtr; /* Pointer to array variable that * contains the variable, or NULL if * the variable isn't an element of an * array. */ Var *varPtr; /* Variable whose traces are to be * invoked. */ char *part1, *part2; /* Variable's two-part name. */ int flags; /* Flags to pass to trace procedures: * indicates what's happening to * variable, plus other stuff like * TCL_GLOBAL_ONLY and * TCL_INTERP_DESTROYED. */ { register VarTrace *tracePtr; ActiveVarTrace active; char *result, *openParen, *p; Tcl_DString nameCopy; int copiedName; /* * If there are already similar trace procedures active for the * variable, don't call them again. */ if (varPtr->flags & VAR_TRACE_ACTIVE) { return NULL; } varPtr->flags |= VAR_TRACE_ACTIVE; varPtr->refCount++; /* * If the variable name hasn't been parsed into array name and * element, do it here. If there really is an array element, * make a copy of the original name so that NULLs can be * inserted into it to separate the names (can't modify the name * string in place, because the string might get used by the * callbacks we invoke). */ copiedName = 0; if (flags & PART1_NOT_PARSED) { for (p = part1; ; p++) { if (*p == 0) { break; } if (*p == '(') { openParen = p; do { p++; } while (*p != '\0'); p--; if (*p == ')') { Tcl_DStringInit(&nameCopy); Tcl_DStringAppend(&nameCopy, part1, (p-part1)); part2 = Tcl_DStringValue(&nameCopy) + (openParen + 1 - part1); part2[-1] = 0; part1 = Tcl_DStringValue(&nameCopy); copiedName = 1; } break; } } } /* * Invoke traces on the array containing the variable, if relevant. */ result = NULL; active.nextPtr = iPtr->activeTracePtr; iPtr->activeTracePtr = &active; if (arrayPtr != NULL) { arrayPtr->refCount++; active.varPtr = arrayPtr; for (tracePtr = arrayPtr->tracePtr; tracePtr != NULL; tracePtr = active.nextTracePtr) { active.nextTracePtr = tracePtr->nextPtr; if (!(tracePtr->flags & flags)) { continue; } result = (*tracePtr->traceProc)(tracePtr->clientData, (Tcl_Interp *) iPtr, part1, part2, flags); if (result != NULL) { if (flags & TCL_TRACE_UNSETS) { result = NULL; } else { goto done; } } } } /* * Invoke traces on the variable itself. */ if (flags & TCL_TRACE_UNSETS) { flags |= TCL_TRACE_DESTROYED; } active.varPtr = varPtr; for (tracePtr = varPtr->tracePtr; tracePtr != NULL; tracePtr = active.nextTracePtr) { active.nextTracePtr = tracePtr->nextPtr; if (!(tracePtr->flags & flags)) { continue; } result = (*tracePtr->traceProc)(tracePtr->clientData, (Tcl_Interp *) iPtr, part1, part2, flags); if (result != NULL) { if (flags & TCL_TRACE_UNSETS) { result = NULL; } else { goto done; } } } /* * Restore the variable's flags, remove the record of our active * traces, and then return. */ done: if (arrayPtr != NULL) { arrayPtr->refCount--; } if (copiedName) { Tcl_DStringFree(&nameCopy); } varPtr->flags &= ~VAR_TRACE_ACTIVE; varPtr->refCount--; iPtr->activeTracePtr = active.nextPtr; return result; } /* *---------------------------------------------------------------------- * * NewVar -- * * Create a new variable with a given amount of storage * space. * * Results: * The return value is a pointer to the new variable structure. * The variable will not be part of any hash table yet. Its * initial value is empty. * * Side effects: * Storage gets allocated. * *---------------------------------------------------------------------- */ static Var * NewVar() { register Var *varPtr; varPtr = (Var *) ckalloc(sizeof(Var)); varPtr->valueLength = 0; varPtr->valueSpace = 0; varPtr->value.string = NULL; varPtr->hPtr = NULL; varPtr->refCount = 0; varPtr->tracePtr = NULL; varPtr->searchPtr = NULL; varPtr->flags = VAR_UNDEFINED; return varPtr; } /* *---------------------------------------------------------------------- * * ParseSearchId -- * * This procedure translates from a string to a pointer to an * active array search (if there is one that matches the string). * * Results: * The return value is a pointer to the array search indicated * by string, or NULL if there isn't one. If NULL is returned, * interp->result contains an error message. * * Side effects: * None. * *---------------------------------------------------------------------- */ static ArraySearch * ParseSearchId(interp, varPtr, varName, string) Tcl_Interp *interp; /* Interpreter containing variable. */ Var *varPtr; /* Array variable search is for. */ char *varName; /* Name of array variable that search is * supposed to be for. */ char *string; /* String containing id of search. Must have * form "search-num-var" where "num" is a * decimal number and "var" is a variable * name. */ { char *end; int id; ArraySearch *searchPtr; /* * Parse the id into the three parts separated by dashes. */ if ((string[0] != 's') || (string[1] != '-')) { syntax: Tcl_AppendResult(interp, "illegal search identifier \"", string, "\"", (char *) NULL); return NULL; } id = strtoul(string+2, &end, 10); if ((end == (string+2)) || (*end != '-')) { goto syntax; } if (strcmp(end+1, varName) != 0) { Tcl_AppendResult(interp, "search identifier \"", string, "\" isn't for variable \"", varName, "\"", (char *) NULL); return NULL; } /* * Search through the list of active searches on the interpreter * to see if the desired one exists. */ for (searchPtr = varPtr->searchPtr; searchPtr != NULL; searchPtr = searchPtr->nextPtr) { if (searchPtr->id == id) { return searchPtr; } } Tcl_AppendResult(interp, "couldn't find search \"", string, "\"", (char *) NULL); return NULL; } /* *---------------------------------------------------------------------- * * DeleteSearches -- * * This procedure is called to free up all of the searches * associated with an array variable. * * Results: * None. * * Side effects: * Memory is released to the storage allocator. * *---------------------------------------------------------------------- */ static void DeleteSearches(arrayVarPtr) register Var *arrayVarPtr; /* Variable whose searches are * to be deleted. */ { ArraySearch *searchPtr; while (arrayVarPtr->searchPtr != NULL) { searchPtr = arrayVarPtr->searchPtr; arrayVarPtr->searchPtr = searchPtr->nextPtr; ckfree((char *) searchPtr); } } /* *---------------------------------------------------------------------- * * TclDeleteVars -- * * This procedure is called to recycle all the storage space * associated with a table of variables. For this procedure * to work correctly, it must not be possible for any of the * variable in the table to be accessed from Tcl commands * (e.g. from trace procedures). * * Results: * None. * * Side effects: * Variables are deleted and trace procedures are invoked, if * any are declared. * *---------------------------------------------------------------------- */ void TclDeleteVars(iPtr, tablePtr) Interp *iPtr; /* Interpreter to which variables belong. */ Tcl_HashTable *tablePtr; /* Hash table containing variables to * delete. */ { Tcl_HashSearch search; Tcl_HashEntry *hPtr; register Var *varPtr; Var *upvarPtr; int flags; ActiveVarTrace *activePtr; flags = TCL_TRACE_UNSETS; if (tablePtr == &iPtr->globalTable) { flags |= TCL_INTERP_DESTROYED | TCL_GLOBAL_ONLY; } for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { varPtr = (Var *) Tcl_GetHashValue(hPtr); /* * For global/upvar variables referenced in procedures, decrement * the reference count on the variable referred to, and free up * the referenced variable if it's no longer needed. */ if (varPtr->flags & VAR_UPVAR) { upvarPtr = varPtr->value.upvarPtr; upvarPtr->refCount--; if (upvarPtr->flags & VAR_UNDEFINED) { CleanupVar(upvarPtr, (Var *) NULL); } } /* * Invoke traces on the variable that is being deleted, then * free up the variable's space (no need to free the hash entry * here, unless we're dealing with a global variable: the * hash entries will be deleted automatically when the whole * table is deleted). */ if (varPtr->tracePtr != NULL) { (void) CallTraces(iPtr, (Var *) NULL, varPtr, Tcl_GetHashKey(tablePtr, hPtr), (char *) NULL, flags); while (varPtr->tracePtr != NULL) { VarTrace *tracePtr = varPtr->tracePtr; varPtr->tracePtr = tracePtr->nextPtr; ckfree((char *) tracePtr); } for (activePtr = iPtr->activeTracePtr; activePtr != NULL; activePtr = activePtr->nextPtr) { if (activePtr->varPtr == varPtr) { activePtr->nextTracePtr = NULL; } } } if (varPtr->flags & VAR_ARRAY) { DeleteArray(iPtr, Tcl_GetHashKey(tablePtr, hPtr), varPtr, flags); } if (varPtr->valueSpace > 0) { /* * SPECIAL TRICK: it's possible that the interpreter's result * currently points to this variable (for example, a "set" or * "lappend" command was the last command in a procedure that's * being returned from). If this is the case, then just pass * ownership of the value string to the Tcl interpreter. */ if (iPtr->result == varPtr->value.string) { iPtr->freeProc = (Tcl_FreeProc *) free; } else { ckfree(varPtr->value.string); } varPtr->valueSpace = 0; } varPtr->hPtr = NULL; varPtr->tracePtr = NULL; varPtr->flags = VAR_UNDEFINED; if (varPtr->refCount == 0) { ckfree((char *) varPtr); } } Tcl_DeleteHashTable(tablePtr); } /* *---------------------------------------------------------------------- * * DeleteArray -- * * This procedure is called to free up everything in an array * variable. It's the caller's responsibility to make sure * that the array is no longer accessible before this procedure * is called. * * Results: * None. * * Side effects: * All storage associated with varPtr's array elements is deleted * (including the hash table). Delete trace procedures for * array elements are invoked. * *---------------------------------------------------------------------- */ static void DeleteArray(iPtr, arrayName, varPtr, flags) Interp *iPtr; /* Interpreter containing array. */ char *arrayName; /* Name of array (used for trace * callbacks). */ Var *varPtr; /* Pointer to variable structure. */ int flags; /* Flags to pass to CallTraces: * TCL_TRACE_UNSETS and sometimes * TCL_INTERP_DESTROYED and/or * TCL_GLOBAL_ONLY. */ { Tcl_HashSearch search; register Tcl_HashEntry *hPtr; register Var *elPtr; ActiveVarTrace *activePtr; DeleteSearches(varPtr); for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search); hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { elPtr = (Var *) Tcl_GetHashValue(hPtr); if (elPtr->valueSpace != 0) { /* * SPECIAL TRICK: it's possible that the interpreter's result * currently points to this element (for example, a "set" or * "lappend" command was the last command in a procedure that's * being returned from). If this is the case, then just pass * ownership of the value string to the Tcl interpreter. */ if (iPtr->result == elPtr->value.string) { iPtr->freeProc = (Tcl_FreeProc *) free; } else { ckfree(elPtr->value.string); } elPtr->valueSpace = 0; } elPtr->hPtr = NULL; if (elPtr->tracePtr != NULL) { elPtr->flags &= ~VAR_TRACE_ACTIVE; (void) CallTraces(iPtr, (Var *) NULL, elPtr, arrayName, Tcl_GetHashKey(varPtr->value.tablePtr, hPtr), flags); while (elPtr->tracePtr != NULL) { VarTrace *tracePtr = elPtr->tracePtr; elPtr->tracePtr = tracePtr->nextPtr; ckfree((char *) tracePtr); } for (activePtr = iPtr->activeTracePtr; activePtr != NULL; activePtr = activePtr->nextPtr) { if (activePtr->varPtr == elPtr) { activePtr->nextTracePtr = NULL; } } } elPtr->flags = VAR_UNDEFINED; if (elPtr->refCount == 0) { ckfree((char *) elPtr); } } Tcl_DeleteHashTable(varPtr->value.tablePtr); ckfree((char *) varPtr->value.tablePtr); } /* *---------------------------------------------------------------------- * * CleanupVar -- * * This procedure is called when it looks like it may be OK * to free up the variable's record and hash table entry, and * those of its containing parent. It's called, for example, * when a trace on a variable deletes the variable. * * Results: * None. * * Side effects: * If the variable (or its containing array) really is dead then * its record, and possibly its hash table entry, gets freed up. * *---------------------------------------------------------------------- */ static void CleanupVar(varPtr, arrayPtr) Var *varPtr; /* Pointer to variable that may be a * candidate for being expunged. */ Var *arrayPtr; /* Array that contains the variable, or * NULL if this variable isn't an array * element. */ { if ((varPtr->flags & VAR_UNDEFINED) && (varPtr->refCount == 0) && (varPtr->tracePtr == NULL)) { if (varPtr->hPtr != NULL) { Tcl_DeleteHashEntry(varPtr->hPtr); } ckfree((char *) varPtr); } if (arrayPtr != NULL) { if ((arrayPtr->flags & VAR_UNDEFINED) && (arrayPtr->refCount == 0) && (arrayPtr->tracePtr == NULL)) { if (arrayPtr->hPtr != NULL) { Tcl_DeleteHashEntry(arrayPtr->hPtr); } ckfree((char *) arrayPtr); } } return; } /* *---------------------------------------------------------------------- * * VarErrMsg -- * * Generate a reasonable error message describing why a variable * operation failed. * * Results: * None. * * Side effects: * Interp->result is reset to hold a message identifying the * variable given by part1 and part2 and describing why the * variable operation failed. * *---------------------------------------------------------------------- */ static void VarErrMsg(interp, part1, part2, operation, reason) Tcl_Interp *interp; /* Interpreter in which to record message. */ char *part1, *part2; /* Variable's two-part name. */ char *operation; /* String describing operation that failed, * e.g. "read", "set", or "unset". */ char *reason; /* String describing why operation failed. */ { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "can't ", operation, " \"", part1, (char *) NULL); if (part2 != NULL) { Tcl_AppendResult(interp, "(", part2, ")", (char *) NULL); } Tcl_AppendResult(interp, "\": ", reason, (char *) NULL); } r *varPtr; /* Array variable search is for. */ char *varName; /* Name of array variable that search is * supposed to be for. */ char *string; /* String containing id of search. Must have * form "search-num-var" where "num" is a * decimal number and "var" is a variable * name. */ { char *end; int id; ArraySearch *searchPtr; /* * Parse the id into the three parts separated by dashtcl7.4b4/panic.c010044400630510000012000000026000567467740000142750ustar00ousterstaff00002300000001/* * panic.c -- * * Source code for the "panic" library procedure for Tcl; * individual applications will probably override this with * an application-specific panic procedure. * * Copyright (c) 1988-1993 The Regents of the University of California. * Copyright (c) 1994 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #ifndef lint static char sccsid[] = "@(#) panic.c 1.6 94/12/17 16:14:02"; #endif #include #ifdef NO_STDLIB_H # include "compat/stdlib.h" #else # include #endif /* *---------------------------------------------------------------------- * * panic -- * * Print an error message and kill the process. * * Results: * None. * * Side effects: * The process dies, entering the debugger if possible. * *---------------------------------------------------------------------- */ /* VARARGS ARGSUSED */ void panic(format, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8) char *format; /* Format string, suitable for passing to * fprintf. */ char *arg1, *arg2, *arg3; /* Additional arguments (variable in number) * to pass to fprintf. */ char *arg4, *arg5, *arg6, *arg7, *arg8; { (void) fprintf(stderr, format, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8); (void) fflush(stderr); abort(); } tcl7.4b4/tclEnv.c010044400630510000012000000322760570237215600144420ustar00ousterstaff00002300000001/* * tclEnv.c -- * * Tcl support for environment variables, including a setenv * procedure. * * Copyright (c) 1991-1994 The Regents of the University of California. * Copyright (c) 1994-1995 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #ifndef lint static char sccsid[] = "@(#) tclEnv.c 1.21 95/01/03 17:05:31"; #endif /* not lint */ /* * The putenv and setenv definitions below cause any system prototypes for * those procedures to be ignored so that there won't be a clash when the * versions in this file are compiled. */ #define putenv ignore_putenv #define setenv ignore_setenv #include "tclInt.h" #include "tclPort.h" #undef putenv #undef setenv /* * The structure below is used to keep track of all of the interpereters * for which we're managing the "env" array. It's needed so that they * can all be updated whenever an environment variable is changed * anywhere. */ typedef struct EnvInterp { Tcl_Interp *interp; /* Interpreter for which we're managing * the env array. */ struct EnvInterp *nextPtr; /* Next in list of all such interpreters, * or zero. */ } EnvInterp; static EnvInterp *firstInterpPtr; /* First in list of all managed interpreters, * or NULL if none. */ static int environSize = 0; /* Non-zero means that the all of the * environ-related information is malloc-ed * and the environ array itself has this * many total entries allocated to it (not * all may be in use at once). Zero means * that the environment array is in its * original static state. */ /* * Declarations for local procedures defined in this file: */ static void EnvInit _ANSI_ARGS_((void)); static char * EnvTraceProc _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, char *name1, char *name2, int flags)); static int FindVariable _ANSI_ARGS_((CONST char *name, int *lengthPtr)); void TclSetEnv _ANSI_ARGS_((CONST char *name, CONST char *value)); void TclUnsetEnv _ANSI_ARGS_((CONST char *name)); /* *---------------------------------------------------------------------- * * TclSetupEnv -- * * This procedure is invoked for an interpreter to make environment * variables accessible from that interpreter via the "env" * associative array. * * Results: * None. * * Side effects: * The interpreter is added to a list of interpreters managed * by us, so that its view of envariables can be kept consistent * with the view in other interpreters. If this is the first * call to Tcl_SetupEnv, then additional initialization happens, * such as copying the environment to dynamically-allocated space * for ease of management. * *---------------------------------------------------------------------- */ void TclSetupEnv(interp) Tcl_Interp *interp; /* Interpreter whose "env" array is to be * managed. */ { EnvInterp *eiPtr; int i; /* * First, initialize our environment-related information, if * necessary. */ if (environSize == 0) { EnvInit(); } /* * Next, add the interpreter to the list of those that we manage. */ eiPtr = (EnvInterp *) ckalloc(sizeof(EnvInterp)); eiPtr->interp = interp; eiPtr->nextPtr = firstInterpPtr; firstInterpPtr = eiPtr; /* * Store the environment variable values into the interpreter's * "env" array, and arrange for us to be notified on future * writes and unsets to that array. */ (void) Tcl_UnsetVar2(interp, "env", (char *) NULL, TCL_GLOBAL_ONLY); for (i = 0; ; i++) { char *p, *p2; p = environ[i]; if (p == NULL) { break; } for (p2 = p; *p2 != '='; p2++) { /* Empty loop body. */ } *p2 = 0; (void) Tcl_SetVar2(interp, "env", p, p2+1, TCL_GLOBAL_ONLY); *p2 = '='; } Tcl_TraceVar2(interp, "env", (char *) NULL, TCL_GLOBAL_ONLY | TCL_TRACE_WRITES | TCL_TRACE_UNSETS, EnvTraceProc, (ClientData) NULL); } /* *---------------------------------------------------------------------- * * FindVariable -- * * Locate the entry in environ for a given name. * * Results: * The return value is the index in environ of an entry with the * name "name", or -1 if there is no such entry. The integer at * *lengthPtr is filled in with the length of name (if a matching * entry is found) or the length of the environ array (if no matching * entry is found). * * Side effects: * None. * *---------------------------------------------------------------------- */ static int FindVariable(name, lengthPtr) CONST char *name; /* Name of desired environment variable. */ int *lengthPtr; /* Used to return length of name (for * successful searches) or number of non-NULL * entries in environ (for unsuccessful * searches). */ { int i; register CONST char *p1, *p2; for (i = 0, p1 = environ[i]; p1 != NULL; i++, p1 = environ[i]) { for (p2 = name; *p2 == *p1; p1++, p2++) { /* NULL loop body. */ } if ((*p1 == '=') && (*p2 == '\0')) { *lengthPtr = p2-name; return i; } } *lengthPtr = i; return -1; } /* *---------------------------------------------------------------------- * * TclSetEnv -- * * Set an environment variable, replacing an existing value * or creating a new variable if there doesn't exist a variable * by the given name. This procedure is intended to be a * stand-in for the UNIX "setenv" procedure so that applications * using that procedure will interface properly to Tcl. To make * it a stand-in, the Makefile must define "TclSetEnv" to "setenv". * * Results: * None. * * Side effects: * The environ array gets updated, as do all of the interpreters * that we manage. * *---------------------------------------------------------------------- */ void TclSetEnv(name, value) CONST char *name; /* Name of variable whose value is to be * set. */ CONST char *value; /* New value for variable. */ { int index, length, nameLength; char *p; EnvInterp *eiPtr; if (environSize == 0) { EnvInit(); } /* * Figure out where the entry is going to go. If the name doesn't * already exist, enlarge the array if necessary to make room. If * the name exists, free its old entry. */ index = FindVariable(name, &length); if (index == -1) { if ((length+2) > environSize) { char **newEnviron; newEnviron = (char **) ckalloc((unsigned) ((length+5) * sizeof(char *))); memcpy((VOID *) newEnviron, (VOID *) environ, length*sizeof(char *)); ckfree((char *) environ); environ = newEnviron; environSize = length+5; } index = length; environ[index+1] = NULL; nameLength = strlen(name); } else { /* * Compare the new value to the existing value. If they're * the same then quit immediately (e.g. don't rewrite the * value or propagate it to other interpreters). Otherwise, * when there are N interpreters there will be N! propagations * of the same value among the interpreters. */ if (strcmp(value, environ[index]+length+1) == 0) { return; } ckfree(environ[index]); nameLength = length; } /* * Create a new entry and enter it into the table. */ p = (char *) ckalloc((unsigned) (nameLength + strlen(value) + 2)); environ[index] = p; strcpy(p, name); p += nameLength; *p = '='; strcpy(p+1, value); /* * Update all of the interpreters. */ for (eiPtr= firstInterpPtr; eiPtr != NULL; eiPtr = eiPtr->nextPtr) { (void) Tcl_SetVar2(eiPtr->interp, "env", (char *) name, p+1, TCL_GLOBAL_ONLY); } } /* *---------------------------------------------------------------------- * * Tcl_PutEnv -- * * Set an environment variable. Similar to setenv except that * the information is passed in a single string of the form * NAME=value, rather than as separate name strings. This procedure * is intended to be a stand-in for the UNIX "putenv" procedure * so that applications using that procedure will interface * properly to Tcl. To make it a stand-in, the Makefile will * define "Tcl_PutEnv" to "putenv". * * Results: * None. * * Side effects: * The environ array gets updated, as do all of the interpreters * that we manage. * *---------------------------------------------------------------------- */ int Tcl_PutEnv(string) CONST char *string; /* Info about environment variable in the * form NAME=value. */ { int nameLength; char *name, *value; if (string == NULL) { return 0; } /* * Separate the string into name and value parts, then call * TclSetEnv to do all of the real work. */ value = strchr(string, '='); if (value == NULL) { return 0; } nameLength = value - string; if (nameLength == 0) { return 0; } name = ckalloc((unsigned) nameLength+1); memcpy(name, string, (size_t) nameLength); name[nameLength] = 0; TclSetEnv(name, value+1); ckfree(name); return 0; } /* *---------------------------------------------------------------------- * * TclUnsetEnv -- * * Remove an environment variable, updating the "env" arrays * in all interpreters managed by us. This function is intended * to replace the UNIX "unsetenv" function (but to do this the * Makefile must be modified to redefine "TclUnsetEnv" to * "unsetenv". * * Results: * None. * * Side effects: * Interpreters are updated, as is environ. * *---------------------------------------------------------------------- */ void TclUnsetEnv(name) CONST char *name; /* Name of variable to remove. */ { int index, dummy; char **envPtr; EnvInterp *eiPtr; if (environSize == 0) { EnvInit(); } /* * Update the environ array. */ index = FindVariable(name, &dummy); if (index == -1) { return; } ckfree(environ[index]); for (envPtr = environ+index+1; ; envPtr++) { envPtr[-1] = *envPtr; if (*envPtr == NULL) { break; } } /* * Update all of the interpreters. */ for (eiPtr = firstInterpPtr; eiPtr != NULL; eiPtr = eiPtr->nextPtr) { (void) Tcl_UnsetVar2(eiPtr->interp, "env", (char *) name, TCL_GLOBAL_ONLY); } } /* *---------------------------------------------------------------------- * * EnvTraceProc -- * * This procedure is invoked whenever an environment variable * is modified or deleted. It propagates the change to the * "environ" array and to any other interpreters for whom * we're managing an "env" array. * * Results: * Always returns NULL to indicate success. * * Side effects: * Environment variable changes get propagated. If the whole * "env" array is deleted, then we stop managing things for * this interpreter (usually this happens because the whole * interpreter is being deleted). * *---------------------------------------------------------------------- */ /* ARGSUSED */ static char * EnvTraceProc(clientData, interp, name1, name2, flags) ClientData clientData; /* Not used. */ Tcl_Interp *interp; /* Interpreter whose "env" variable is * being modified. */ char *name1; /* Better be "env". */ char *name2; /* Name of variable being modified, or * NULL if whole array is being deleted. */ int flags; /* Indicates what's happening. */ { /* * First see if the whole "env" variable is being deleted. If * so, just forget about this interpreter. */ if (name2 == NULL) { register EnvInterp *eiPtr, *prevPtr; if ((flags & (TCL_TRACE_UNSETS|TCL_TRACE_DESTROYED)) != (TCL_TRACE_UNSETS|TCL_TRACE_DESTROYED)) { panic("EnvTraceProc called with confusing arguments"); } eiPtr = firstInterpPtr; if (eiPtr->interp == interp) { firstInterpPtr = eiPtr->nextPtr; } else { for (prevPtr = eiPtr, eiPtr = eiPtr->nextPtr; ; prevPtr = eiPtr, eiPtr = eiPtr->nextPtr) { if (eiPtr == NULL) { panic("EnvTraceProc couldn't find interpreter"); } if (eiPtr->interp == interp) { prevPtr->nextPtr = eiPtr->nextPtr; break; } } } ckfree((char *) eiPtr); return NULL; } /* * If a value is being set, call TclSetEnv to do all of the work. */ if (flags & TCL_TRACE_WRITES) { TclSetEnv(name2, Tcl_GetVar2(interp, "env", name2, TCL_GLOBAL_ONLY)); } if (flags & TCL_TRACE_UNSETS) { TclUnsetEnv(name2); } return NULL; } /* *---------------------------------------------------------------------- * * EnvInit -- * * This procedure is called to initialize our management * of the environ array. * * Results: * None. * * Side effects: * Environ gets copied to malloc-ed storage, so that in * the future we don't have to worry about which entries * are malloc-ed and which are static. * *---------------------------------------------------------------------- */ static void EnvInit() { char **newEnviron; int i, length; if (environSize != 0) { return; } for (length = 0; environ[length] != NULL; length++) { /* Empty loop body. */ } environSize = length+5; newEnviron = (char **) ckalloc((unsigned) (environSize * sizeof(char *))); for (i = 0; i < length; i++) { newEnviron[i] = (char *) ckalloc((unsigned) (strlen(environ[i]) + 1)); strcpy(newEnviron[i], environ[i]); } newEnviron[length] = NULL; environ = newEnviron; } tcl7.4b4/tclGlob.c010044400630510000012000000266060576563467500146150ustar00ousterstaff00002300000001/* * tclGlob.c -- * * This file provides procedures and commands for file name * manipulation, such as tilde expansion and globbing. * * Copyright (c) 1990-1994 The Regents of the University of California. * Copyright (c) 1994 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #ifndef lint static char sccsid[] = "@(#) tclGlob.c 1.42 95/06/08 10:56:13"; #endif /* not lint */ #include "tclInt.h" #include "tclPort.h" /* * Declarations for procedures local to this file: */ static int DoGlob _ANSI_ARGS_((Tcl_Interp *interp, char *dir, char *rem)); /* *---------------------------------------------------------------------- * * DoGlob -- * * This recursive procedure forms the heart of the globbing * code. It performs a depth-first traversal of the tree * given by the path name to be globbed. * * Results: * The return value is a standard Tcl result indicating whether * an error occurred in globbing. After a normal return the * result in interp will be set to hold all of the file names * given by the dir and rem arguments. After an error the * result in interp will hold an error message. * * Side effects: * None. * *---------------------------------------------------------------------- */ static int DoGlob(interp, dir, rem) Tcl_Interp *interp; /* Interpreter to use for error * reporting (e.g. unmatched brace). */ char *dir; /* Name of a directory at which to * start glob expansion. This name * is fixed: it doesn't contain any * globbing chars. */ char *rem; /* Path to glob-expand. */ { /* * When this procedure is entered, the name to be globbed may * already have been partly expanded by ancestor invocations of * DoGlob. The part that's already been expanded is in "dir" * (this may initially be empty), and the part still to expand * is in "rem". This procedure expands "rem" one level, making * recursive calls to itself if there's still more stuff left * in the remainder. */ Tcl_DString newName; /* Holds new name consisting of * dir plus the first part of rem. */ register char *p; register char c; char *openBrace, *closeBrace, *name, *dirName; int gotSpecial, baseLength; int result = TCL_OK; struct stat statBuf; /* * Make sure that the directory part of the name really is a * directory. If the directory name is "", use the name "." * instead, because some UNIX systems don't treat "" like "." * automatically. Keep the "" for use in generating file names, * otherwise "glob foo.c" would return "./foo.c". */ if (*dir == '\0') { dirName = "."; } else { dirName = dir; } if ((stat(dirName, &statBuf) != 0) || !S_ISDIR(statBuf.st_mode)) { return TCL_OK; } Tcl_DStringInit(&newName); /* * First, find the end of the next element in rem, checking * along the way for special globbing characters. */ gotSpecial = 0; openBrace = closeBrace = NULL; for (p = rem; ; p++) { c = *p; if ((c == '\0') || ((openBrace == NULL) && (c == '/'))) { break; } if ((c == '{') && (openBrace == NULL)) { openBrace = p; } if ((c == '}') && (openBrace != NULL) && (closeBrace == NULL)) { closeBrace = p; } if ((c == '*') || (c == '[') || (c == '\\') || (c == '?')) { gotSpecial = 1; } } /* * If there is an open brace in the argument, then make a recursive * call for each element between the braces. In this case, the * recursive call to DoGlob uses the same "dir" that we got. * If there are several brace-pairs in a single name, we just handle * one here, and the others will be handled in recursive calls. */ if (openBrace != NULL) { char *element; if (closeBrace == NULL) { Tcl_ResetResult(interp); interp->result = "unmatched open-brace in file name"; result = TCL_ERROR; goto done; } Tcl_DStringAppend(&newName, rem, openBrace-rem); baseLength = newName.length; for (p = openBrace; *p != '}'; ) { element = p+1; for (p = element; ((*p != '}') && (*p != ',')); p++) { /* Empty loop body. */ } Tcl_DStringAppend(&newName, element, p-element); Tcl_DStringAppend(&newName, closeBrace+1, -1); result = DoGlob(interp, dir, newName.string); if (result != TCL_OK) { goto done; } newName.length = baseLength; } goto done; } /* * Start building up the next-level name with dir plus a slash if * needed to separate it from the next file name. */ Tcl_DStringAppend(&newName, dir, -1); if ((dir[0] != 0) && (newName.string[newName.length-1] != '/')) { Tcl_DStringAppend(&newName, "/", 1); } baseLength = newName.length; /* * If there were any pattern-matching characters, then scan through * the directory to find all the matching names. */ if (gotSpecial) { DIR *d; struct dirent *entryPtr; char savedChar; d = opendir(dirName); if (d == NULL) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "couldn't read directory \"", dirName, "\": ", Tcl_PosixError(interp), (char *) NULL); result = TCL_ERROR; goto done; } /* * Temporarily store a null into rem so that the pattern string * is now null-terminated. */ savedChar = *p; *p = 0; while (1) { entryPtr = readdir(d); if (entryPtr == NULL) { break; } /* * Don't match names starting with "." unless the "." is * present in the pattern. */ if ((*entryPtr->d_name == '.') && (*rem != '.')) { continue; } if (Tcl_StringMatch(entryPtr->d_name, rem)) { newName.length = baseLength; Tcl_DStringAppend(&newName, entryPtr->d_name, -1); if (savedChar == 0) { Tcl_AppendElement(interp, newName.string); } else { result = DoGlob(interp, newName.string, p+1); if (result != TCL_OK) { break; } } } } closedir(d); *p = savedChar; goto done; } /* * The current element is a simple one with no fancy features. Add * it to the new name. If there are more elements still to come, * then recurse to process them. */ Tcl_DStringAppend(&newName, rem, p-rem); if (*p != 0) { result = DoGlob(interp, newName.string, p+1); goto done; } /* * There are no more elements in the pattern. Check to be sure the * file actually exists, then add its name to the list being formed * in interp-result. */ name = newName.string; if (*name == 0) { name = "."; } if (access(name, F_OK) != 0) { goto done; } Tcl_AppendElement(interp, name); done: Tcl_DStringFree(&newName); return result; } /* *---------------------------------------------------------------------- * * Tcl_TildeSubst -- * * Given a name starting with a tilde, produce a name where * the tilde and following characters have been replaced by * the home directory location for the named user. * * Results: * The result is a pointer to a static string containing * the new name. If there was an error in processing the * tilde, then an error message is left in interp->result * and the return value is NULL. The result may be stored * in bufferPtr; the caller must call Tcl_DStringFree(bufferPtr) * to free the name. * * Side effects: * Information may be left in bufferPtr. * *---------------------------------------------------------------------- */ char * Tcl_TildeSubst(interp, name, bufferPtr) Tcl_Interp *interp; /* Interpreter in which to store error * message (if necessary). */ char *name; /* File name, which may begin with "~/" * (to indicate current user's home directory) * or "~/" (to indicate any user's * home directory). */ Tcl_DString *bufferPtr; /* May be used to hold result. Must not hold * anything at the time of the call, and need * not even be initialized. */ { char *dir; register char *p; Tcl_DStringInit(bufferPtr); if (name[0] != '~') { return name; } if ((name[1] == '/') || (name[1] == '\0')) { dir = getenv("HOME"); if (dir == NULL) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "couldn't find HOME environment ", "variable to expand \"", name, "\"", (char *) NULL); return NULL; } Tcl_DStringAppend(bufferPtr, dir, -1); Tcl_DStringAppend(bufferPtr, name+1, -1); } else { struct passwd *pwPtr; for (p = &name[1]; (*p != 0) && (*p != '/'); p++) { /* Null body; just find end of name. */ } Tcl_DStringAppend(bufferPtr, name+1, p - (name+1)); pwPtr = getpwnam(bufferPtr->string); if (pwPtr == NULL) { endpwent(); Tcl_ResetResult(interp); Tcl_AppendResult(interp, "user \"", bufferPtr->string, "\" doesn't exist", (char *) NULL); Tcl_DStringFree(bufferPtr); return NULL; } Tcl_DStringFree(bufferPtr); Tcl_DStringAppend(bufferPtr, pwPtr->pw_dir, -1); Tcl_DStringAppend(bufferPtr, p, -1); endpwent(); } return bufferPtr->string; } /* *---------------------------------------------------------------------- * * Tcl_GlobCmd -- * * This procedure is invoked to process the "glob" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_GlobCmd(dummy, interp, argc, argv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { int i, result, noComplain, firstArg; if (argc < 2) { notEnoughArgs: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " ?switches? name ?name ...?\"", (char *) NULL); return TCL_ERROR; } noComplain = 0; for (firstArg = 1; (firstArg < argc) && (argv[firstArg][0] == '-'); firstArg++) { if (strcmp(argv[firstArg], "-nocomplain") == 0) { noComplain = 1; } else if (strcmp(argv[firstArg], "--") == 0) { firstArg++; break; } else { Tcl_AppendResult(interp, "bad switch \"", argv[firstArg], "\": must be -nocomplain or --", (char *) NULL); return TCL_ERROR; } } if (firstArg >= argc) { goto notEnoughArgs; } for (i = firstArg; i < argc; i++) { char *thisName; Tcl_DString buffer; thisName = Tcl_TildeSubst(interp, argv[i], &buffer); if (thisName == NULL) { if (noComplain) { Tcl_ResetResult(interp); continue; } else { return TCL_ERROR; } } if (*thisName == '/') { if (thisName[1] == '/') { /* * This is a special hack for systems like those from Apollo * where there is a super-root at "//": need to treat the * double-slash as a single name. */ result = DoGlob(interp, "//", thisName+2); } else { result = DoGlob(interp, "/", thisName+1); } } else { result = DoGlob(interp, "", thisName); } Tcl_DStringFree(&buffer); if (result != TCL_OK) { return result; } } if ((*interp->result == 0) && !noComplain) { char *sep = ""; Tcl_AppendResult(interp, "no files matched glob pattern", (argc == 2) ? " \"" : "s \"", (char *) NULL); for (i = firstArg; i < argc; i++) { Tcl_AppendResult(interp, sep, argv[i], (char *) NULL); sep = " "; } Tcl_AppendResult(interp, "\"", (char *) NULL); return TCL_ERROR; } return TCL_OK; } tcl7.4b4/tclMain.c010044400630510000012000000167270576563465500146170ustar00ousterstaff00002300000001/* * main.c -- * * Main program for Tcl shells and other Tcl-based applications. * * Copyright (c) 1988-1994 The Regents of the University of California. * Copyright (c) 1994 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #ifndef lint static char sccsid[] = "@(#) tclMain.c 1.21 95/06/08 10:55:55"; #endif #include #include #include #ifdef NO_STDLIB_H # include "compat/stdlib.h" #else # include #endif /* * Declarations for various library procedures and variables (don't want * to include tclPort.h here, because people might copy this file out of * the Tcl source directory to make their own modified versions). * Note: "exit" should really be declared here, but there's no way to * declare it without causing conflicts with other definitions elsewher * on some systems, so it's better just to leave it out. */ extern int errno; extern int isatty _ANSI_ARGS_((int fd)); extern char * strcpy _ANSI_ARGS_((char *dst, CONST char *src)); static Tcl_Interp *interp; /* Interpreter for application. */ static Tcl_DString command; /* Used to buffer incomplete commands being * read from stdin. */ #ifdef TCL_MEM_DEBUG static char dumpFile[100]; /* Records where to dump memory allocation * information. */ static int quitFlag = 0; /* 1 means the "checkmem" command was * invoked, so the application should quit * and dump memory allocation information. */ #endif /* * Forward references for procedures defined later in this file: */ #ifdef TCL_MEM_DEBUG static int CheckmemCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char *argv[])); #endif /* *---------------------------------------------------------------------- * * Tcl_Main -- * * Main program for tclsh and most other Tcl-based applications. * * Results: * None. This procedure never returns (it exits the process when * it's done. * * Side effects: * This procedure initializes the Tk world and then starts * interpreting commands; almost anything could happen, depending * on the script being interpreted. * *---------------------------------------------------------------------- */ void Tcl_Main(argc, argv, appInitProc) int argc; /* Number of arguments. */ char **argv; /* Array of argument strings. */ Tcl_AppInitProc *appInitProc; /* Application-specific initialization * procedure to call after most * initialization but before starting * to execute commands. */ { char buffer[1000], *cmd, *args, *fileName; int code, gotPartial, tty; int exitCode = 0; interp = Tcl_CreateInterp(); #ifdef TCL_MEM_DEBUG Tcl_InitMemory(interp); Tcl_CreateCommand(interp, "checkmem", CheckmemCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); #endif /* * Make command-line arguments available in the Tcl variables "argc" * and "argv". If the first argument doesn't start with a "-" then * strip it off and use it as the name of a script file to process. */ fileName = NULL; if ((argc > 1) && (argv[1][0] != '-')) { fileName = argv[1]; argc--; argv++; } args = Tcl_Merge(argc-1, argv+1); Tcl_SetVar(interp, "argv", args, TCL_GLOBAL_ONLY); ckfree(args); sprintf(buffer, "%d", argc-1); Tcl_SetVar(interp, "argc", buffer, TCL_GLOBAL_ONLY); Tcl_SetVar(interp, "argv0", (fileName != NULL) ? fileName : argv[0], TCL_GLOBAL_ONLY); /* * Set the "tcl_interactive" variable. */ tty = isatty(0); Tcl_SetVar(interp, "tcl_interactive", ((fileName == NULL) && tty) ? "1" : "0", TCL_GLOBAL_ONLY); /* * Invoke application-specific initialization. */ if ((*appInitProc)(interp) != TCL_OK) { fprintf(stderr, "application-specific initialization failed: %s\n", interp->result); } /* * If a script file was specified then just source that file * and quit. */ if (fileName != NULL) { code = Tcl_EvalFile(interp, fileName); if (code != TCL_OK) { fprintf(stderr, "%s\n", interp->result); exitCode = 1; } goto done; } /* * We're running interactively. Source a user-specific startup * file if the application specified one and if the file exists. */ if (tcl_RcFileName != NULL) { Tcl_DString buffer; char *fullName; FILE *f; fullName = Tcl_TildeSubst(interp, tcl_RcFileName, &buffer); if (fullName == NULL) { fprintf(stderr, "%s\n", interp->result); } else { f = fopen(fullName, "r"); if (f != NULL) { code = Tcl_EvalFile(interp, fullName); if (code != TCL_OK) { fprintf(stderr, "%s\n", interp->result); } fclose(f); } } Tcl_DStringFree(&buffer); } /* * Process commands from stdin until there's an end-of-file. */ gotPartial = 0; Tcl_DStringInit(&command); while (1) { clearerr(stdin); if (tty) { char *promptCmd; promptCmd = Tcl_GetVar(interp, gotPartial ? "tcl_prompt2" : "tcl_prompt1", TCL_GLOBAL_ONLY); if (promptCmd == NULL) { defaultPrompt: if (!gotPartial) { fputs("% ", stdout); } } else { code = Tcl_Eval(interp, promptCmd); if (code != TCL_OK) { fprintf(stderr, "%s\n", interp->result); Tcl_AddErrorInfo(interp, "\n (script that generates prompt)"); goto defaultPrompt; } } fflush(stdout); } if (fgets(buffer, 1000, stdin) == NULL) { if (ferror(stdin)) { if (errno == EINTR) { if (tcl_AsyncReady) { (void) Tcl_AsyncInvoke((Tcl_Interp *) NULL, 0); } clearerr(stdin); } else { goto done; } } else { if (!gotPartial) { goto done; } } buffer[0] = 0; } cmd = Tcl_DStringAppend(&command, buffer, -1); if ((buffer[0] != 0) && !Tcl_CommandComplete(cmd)) { gotPartial = 1; continue; } gotPartial = 0; code = Tcl_RecordAndEval(interp, cmd, 0); Tcl_DStringFree(&command); if (code != TCL_OK) { fprintf(stderr, "%s\n", interp->result); } else if (tty && (*interp->result != 0)) { printf("%s\n", interp->result); } #ifdef TCL_MEM_DEBUG if (quitFlag) { Tcl_DeleteInterp(interp); Tcl_DumpActiveMemory(dumpFile); exit(0); } #endif } /* * Rather than calling exit, invoke the "exit" command so that * users can replace "exit" with some other command to do additional * cleanup on exit. The Tcl_Eval call should never return. */ done: sprintf(buffer, "exit %d", exitCode); Tcl_Eval(interp, buffer); } /* *---------------------------------------------------------------------- * * CheckmemCmd -- * * This is the command procedure for the "checkmem" command, which * causes the application to exit after printing information about * memory usage to the file passed to this command as its first * argument. * * Results: * Returns a standard Tcl completion code. * * Side effects: * None. * *---------------------------------------------------------------------- */ #ifdef TCL_MEM_DEBUG /* ARGSUSED */ static int CheckmemCmd(clientData, interp, argc, argv) ClientData clientData; /* Not used. */ Tcl_Interp *interp; /* Interpreter for evaluation. */ int argc; /* Number of arguments. */ char *argv[]; /* String values of arguments. */ { if (argc != 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " fileName\"", (char *) NULL); return TCL_ERROR; } strcpy(dumpFile, argv[1]); quitFlag = 1; return TCL_OK; } #endif tcl7.4b4/tclMtherr.c010044400630510000012000000037550567467740500151700ustar00ousterstaff00002300000001/* * tclMatherr.c -- * * This function provides a default implementation of the * "matherr" function, for SYS-V systems where it's needed. * * Copyright (c) 1993-1994 The Regents of the University of California. * Copyright (c) 1994 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #ifndef lint static char sccsid[] = "@(#) tclMtherr.c 1.10 94/12/17 16:14:25"; #endif /* not lint */ #include "tclInt.h" #include #ifndef TCL_GENERIC_ONLY #include "tclPort.h" #else #define NO_ERRNO_H #endif #ifdef NO_ERRNO_H extern int errno; /* Use errno from tclExpr.c. */ #define EDOM 33 #define ERANGE 34 #endif /* * The following variable is secretly shared with Tcl so we can * tell if expression evaluation is in progress. If not, matherr * just emulates the default behavior, which includes printing * a message. */ extern int tcl_MathInProgress; /* * The following definitions allow matherr to compile on systems * that don't really support it. The compiled procedure is bogus, * but it will never be executed on these systems anyway. */ #ifndef NEED_MATHERR struct exception { int type; }; #define DOMAIN 0 #define SING 0 #endif /* *---------------------------------------------------------------------- * * matherr -- * * This procedure is invoked on Sys-V systems when certain * errors occur in mathematical functions. Type "man matherr" * for more information on how this function works. * * Results: * Returns 1 to indicate that we've handled the error * locally. * * Side effects: * Sets errno based on what's in xPtr. * *---------------------------------------------------------------------- */ int matherr(xPtr) struct exception *xPtr; /* Describes error that occurred. */ { if (!tcl_MathInProgress) { return 0; } if ((xPtr->type == DOMAIN) || (xPtr->type == SING)) { errno = EDOM; } else { errno = ERANGE; } return 1; } tcl7.4b4/tclUnixAZ.c010044400630510000012000001437160574107242300150670ustar00ousterstaff00002300000001/* * tclUnixAZ.c -- * * This file contains the top-level command procedures for * commands in the Tcl core that require UNIX facilities * such as files and process execution. Much of the code * in this file is based on earlier versions contributed * by Karl Lehenbauer, Mark Diekhans and Peter da Silva. * * Copyright (c) 1991-1994 The Regents of the University of California. * Copyright (c) 1994-1995 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ static char sccsid[] = "@(#) tclUnixAZ.c 1.84 95/04/06 16:11:15"; #include "tclInt.h" #include "tclPort.h" /* * The variable is a secret trap-door used by the "fileevent" command * in Tk to destroy file event bindings whenever a file is closed. I * realize that this is a big ugly... */ void (*tcl_FileCloseProc) _ANSI_ARGS_((FILE *f)) = NULL; /* * The variable below caches the name of the current working directory * in order to avoid repeated calls to getcwd. The string is malloc-ed. * NULL means the cache needs to be refreshed. */ static char *currentDir = NULL; /* * If the system doesn't define one or both of the errno values EAGAIN * and EWOULDBLOCK, #define them to a bogus value that will never occur. */ #ifndef EAGAIN # define EAGAIN -1901 #endif #ifndef EWOULDBLOCK # define EWOULDBLOCK -1901 #endif /* * Prototypes for local procedures defined in this file: */ static int CleanupChildren _ANSI_ARGS_((Tcl_Interp *interp, int numPids, int *pidPtr, int errorId, int keepNewline)); static char * GetFileType _ANSI_ARGS_((int mode)); static char * GetOpenMode _ANSI_ARGS_((Tcl_Interp *interp, char *string, int *modePtr)); static int StoreStatData _ANSI_ARGS_((Tcl_Interp *interp, char *varName, struct stat *statPtr)); /* *---------------------------------------------------------------------- * * Tcl_CdCmd -- * * This procedure is invoked to process the "cd" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_CdCmd(dummy, interp, argc, argv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { char *dirName; Tcl_DString buffer; int result; if (argc > 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " dirName\"", (char *) NULL); return TCL_ERROR; } if (argc == 2) { dirName = argv[1]; } else { dirName = "~"; } dirName = Tcl_TildeSubst(interp, dirName, &buffer); if (dirName == NULL) { return TCL_ERROR; } if (currentDir != NULL) { ckfree(currentDir); currentDir = NULL; } result = TCL_OK; if (chdir(dirName) != 0) { Tcl_AppendResult(interp, "couldn't change working directory to \"", dirName, "\": ", Tcl_PosixError(interp), (char *) NULL); result = TCL_ERROR; } Tcl_DStringFree(&buffer); return result; } /* *---------------------------------------------------------------------- * * Tcl_CloseCmd -- * * This procedure is invoked to process the "close" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_CloseCmd(dummy, interp, argc, argv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { OpenFile *oFilePtr; int result = TCL_OK; FILE *f; if (argc != 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " fileId\"", (char *) NULL); return TCL_ERROR; } if (Tcl_GetOpenFile(interp, argv[1], 0, 0, &f) != TCL_OK) { return TCL_ERROR; } oFilePtr = tclOpenFiles[fileno(f)]; tclOpenFiles[fileno(f)] = NULL; /* * First close the file (in the case of a process pipeline, there may * be two files, one for the pipe at each end of the pipeline). The * calls to *tcl_FileCloseProc are a hack so that Tk's "fileevent" * command can clean up its state, if any, when files are closed. */ if (oFilePtr->f2 != NULL) { if (tcl_FileCloseProc != NULL) { (*tcl_FileCloseProc)(oFilePtr->f2); } clearerr(oFilePtr->f2); if (fclose(oFilePtr->f2) == EOF) { Tcl_AppendResult(interp, "error closing \"", argv[1], "\": ", Tcl_PosixError(interp), "\n", (char *) NULL); result = TCL_ERROR; } } if (tcl_FileCloseProc != NULL) { (*tcl_FileCloseProc)(oFilePtr->f); } clearerr(oFilePtr->f); if (fclose(oFilePtr->f) == EOF) { Tcl_AppendResult(interp, "error closing \"", argv[1], "\": ", Tcl_PosixError(interp), "\n", (char *) NULL); result = TCL_ERROR; } /* * If the file was a connection to a pipeline, clean up everything * associated with the child processes. */ if (oFilePtr->numPids > 0) { if (CleanupChildren(interp, oFilePtr->numPids, oFilePtr->pidPtr, oFilePtr->errorId, 0) != TCL_OK) { result = TCL_ERROR; } } ckfree((char *) oFilePtr); return result; } /* *---------------------------------------------------------------------- * * Tcl_EofCmd -- * * This procedure is invoked to process the "eof" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_EofCmd(notUsed, interp, argc, argv) ClientData notUsed; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { FILE *f; if (argc != 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " fileId\"", (char *) NULL); return TCL_ERROR; } if (Tcl_GetOpenFile(interp, argv[1], 0, 0, &f) != TCL_OK) { return TCL_ERROR; } if (feof(f)) { interp->result = "1"; } else { interp->result = "0"; } return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_ExecCmd -- * * This procedure is invoked to process the "exec" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_ExecCmd(dummy, interp, argc, argv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { int outputId; /* File id for output pipe. -1 * means command overrode. */ int errorId; /* File id for temporary file * containing error output. */ int *pidPtr; int numPids, result, keepNewline; int firstWord; /* * Check for a leading "-keepnewline" argument. */ keepNewline = 0; for (firstWord = 1; (firstWord < argc) && (argv[firstWord][0] == '-'); firstWord++) { if (strcmp(argv[firstWord], "-keepnewline") == 0) { keepNewline = 1; } else if (strcmp(argv[firstWord], "--") == 0) { firstWord++; break; } else { Tcl_AppendResult(interp, "bad switch \"", argv[firstWord], "\": must be -keepnewline or --", (char *) NULL); return TCL_ERROR; } } if (argc <= firstWord) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " ?switches? arg ?arg ...?\"", (char *) NULL); return TCL_ERROR; } /* * See if the command is to be run in background; if so, create * the command, detach it, and return a list of pids. */ if ((argv[argc-1][0] == '&') && (argv[argc-1][1] == 0)) { int i; char id[50]; argc--; argv[argc] = NULL; numPids = Tcl_CreatePipeline(interp, argc-firstWord, argv+firstWord, &pidPtr, (int *) NULL, (int *) NULL, (int *) NULL); if (numPids < 0) { return TCL_ERROR; } Tcl_DetachPids(numPids, pidPtr); for (i = 0; i < numPids; i++) { sprintf(id, "%d", pidPtr[i]); Tcl_AppendElement(interp, id); } ckfree((char *) pidPtr); return TCL_OK; } /* * Create the command's pipeline. */ numPids = Tcl_CreatePipeline(interp, argc-firstWord, argv+firstWord, &pidPtr, (int *) NULL, &outputId, &errorId); if (numPids < 0) { return TCL_ERROR; } /* * Read the child's output (if any) and put it into the result. */ result = TCL_OK; if (outputId != -1) { while (1) { # define BUFFER_SIZE 1000 char buffer[BUFFER_SIZE+1]; int count; count = read(outputId, buffer, (size_t) BUFFER_SIZE); if (count == 0) { break; } if (count < 0) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "error reading from output pipe: ", Tcl_PosixError(interp), (char *) NULL); result = TCL_ERROR; break; } buffer[count] = 0; Tcl_AppendResult(interp, buffer, (char *) NULL); } close(outputId); } if (CleanupChildren(interp, numPids, pidPtr, errorId, keepNewline) != TCL_OK) { result = TCL_ERROR; } return result; } /* *---------------------------------------------------------------------- * * Tcl_ExitCmd -- * * This procedure is invoked to process the "exit" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_ExitCmd(dummy, interp, argc, argv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { int value; if ((argc != 1) && (argc != 2)) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " ?returnCode?\"", (char *) NULL); return TCL_ERROR; } if (argc == 1) { exit(0); } if (Tcl_GetInt(interp, argv[1], &value) != TCL_OK) { return TCL_ERROR; } exit(value); /*NOTREACHED*/ return TCL_OK; /* Better not ever reach this! */ } /* *---------------------------------------------------------------------- * * Tcl_FileCmd -- * * This procedure is invoked to process the "file" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_FileCmd(dummy, interp, argc, argv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { char *p, *fileName; int c, statOp, result; size_t length; int mode = 0; /* Initialized only to prevent * compiler warning message. */ struct stat statBuf; Tcl_DString buffer; if (argc < 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " option name ?arg ...?\"", (char *) NULL); return TCL_ERROR; } c = argv[1][0]; length = strlen(argv[1]); result = TCL_OK; /* * First handle operations on the file name. */ fileName = Tcl_TildeSubst(interp, argv[2], &buffer); if (fileName == NULL) { result = TCL_ERROR; goto done; } if ((c == 'd') && (strncmp(argv[1], "dirname", length) == 0)) { if (argc != 3) { argv[1] = "dirname"; not3Args: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " ", argv[1], " name\"", (char *) NULL); result = TCL_ERROR; goto done; } p = strrchr(fileName, '/'); if (p == NULL) { interp->result = "."; } else if (p == fileName) { interp->result = "/"; } else { *p = 0; Tcl_SetResult(interp, fileName, TCL_VOLATILE); *p = '/'; } goto done; } else if ((c == 'r') && (strncmp(argv[1], "rootname", length) == 0) && (length >= 2)) { char *lastSlash; if (argc != 3) { argv[1] = "rootname"; goto not3Args; } p = strrchr(fileName, '.'); lastSlash = strrchr(fileName, '/'); if ((p == NULL) || ((lastSlash != NULL) && (lastSlash > p))) { Tcl_SetResult(interp, fileName, TCL_VOLATILE); } else { *p = 0; Tcl_SetResult(interp, fileName, TCL_VOLATILE); *p = '.'; } goto done; } else if ((c == 'e') && (strncmp(argv[1], "extension", length) == 0) && (length >= 3)) { char *lastSlash; if (argc != 3) { argv[1] = "extension"; goto not3Args; } p = strrchr(fileName, '.'); lastSlash = strrchr(fileName, '/'); if ((p != NULL) && ((lastSlash == NULL) || (lastSlash < p))) { Tcl_SetResult(interp, p, TCL_VOLATILE); } goto done; } else if ((c == 't') && (strncmp(argv[1], "tail", length) == 0) && (length >= 2)) { if (argc != 3) { argv[1] = "tail"; goto not3Args; } p = strrchr(fileName, '/'); if (p != NULL) { Tcl_SetResult(interp, p+1, TCL_VOLATILE); } else { Tcl_SetResult(interp, fileName, TCL_VOLATILE); } goto done; } /* * Next, handle operations that can be satisfied with the "access" * kernel call. */ if (fileName == NULL) { result = TCL_ERROR; goto done; } if ((c == 'r') && (strncmp(argv[1], "readable", length) == 0) && (length >= 5)) { if (argc != 3) { argv[1] = "readable"; goto not3Args; } mode = R_OK; checkAccess: if (access(fileName, mode) == -1) { interp->result = "0"; } else { interp->result = "1"; } goto done; } else if ((c == 'w') && (strncmp(argv[1], "writable", length) == 0)) { if (argc != 3) { argv[1] = "writable"; goto not3Args; } mode = W_OK; goto checkAccess; } else if ((c == 'e') && (strncmp(argv[1], "executable", length) == 0) && (length >= 3)) { if (argc != 3) { argv[1] = "executable"; goto not3Args; } mode = X_OK; goto checkAccess; } else if ((c == 'e') && (strncmp(argv[1], "exists", length) == 0) && (length >= 3)) { if (argc != 3) { argv[1] = "exists"; goto not3Args; } mode = F_OK; goto checkAccess; } /* * Lastly, check stuff that requires the file to be stat-ed. */ if ((c == 'a') && (strncmp(argv[1], "atime", length) == 0)) { if (argc != 3) { argv[1] = "atime"; goto not3Args; } if (stat(fileName, &statBuf) == -1) { goto badStat; } sprintf(interp->result, "%ld", statBuf.st_atime); goto done; } else if ((c == 'i') && (strncmp(argv[1], "isdirectory", length) == 0) && (length >= 3)) { if (argc != 3) { argv[1] = "isdirectory"; goto not3Args; } statOp = 2; } else if ((c == 'i') && (strncmp(argv[1], "isfile", length) == 0) && (length >= 3)) { if (argc != 3) { argv[1] = "isfile"; goto not3Args; } statOp = 1; } else if ((c == 'l') && (strncmp(argv[1], "lstat", length) == 0)) { if (argc != 4) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " lstat name varName\"", (char *) NULL); result = TCL_ERROR; goto done; } if (lstat(fileName, &statBuf) == -1) { Tcl_AppendResult(interp, "couldn't lstat \"", argv[2], "\": ", Tcl_PosixError(interp), (char *) NULL); result = TCL_ERROR; goto done; } result = StoreStatData(interp, argv[3], &statBuf); goto done; } else if ((c == 'm') && (strncmp(argv[1], "mtime", length) == 0)) { if (argc != 3) { argv[1] = "mtime"; goto not3Args; } if (stat(fileName, &statBuf) == -1) { goto badStat; } sprintf(interp->result, "%ld", statBuf.st_mtime); goto done; } else if ((c == 'o') && (strncmp(argv[1], "owned", length) == 0)) { if (argc != 3) { argv[1] = "owned"; goto not3Args; } statOp = 0; } else if ((c == 'r') && (strncmp(argv[1], "readlink", length) == 0) && (length >= 5)) { char linkValue[MAXPATHLEN+1]; int linkLength; if (argc != 3) { argv[1] = "readlink"; goto not3Args; } /* * If S_IFLNK isn't defined it means that the machine doesn't * support symbolic links, so the file can't possibly be a * symbolic link. Generate an EINVAL error, which is what * happens on machines that do support symbolic links when * you invoke readlink on a file that isn't a symbolic link. */ #ifndef S_IFLNK linkLength = -1; errno = EINVAL; #else linkLength = readlink(fileName, linkValue, sizeof(linkValue) - 1); #endif /* S_IFLNK */ if (linkLength == -1) { Tcl_AppendResult(interp, "couldn't readlink \"", argv[2], "\": ", Tcl_PosixError(interp), (char *) NULL); result = TCL_ERROR; goto done; } linkValue[linkLength] = 0; Tcl_SetResult(interp, linkValue, TCL_VOLATILE); goto done; } else if ((c == 's') && (strncmp(argv[1], "size", length) == 0) && (length >= 2)) { if (argc != 3) { argv[1] = "size"; goto not3Args; } if (stat(fileName, &statBuf) == -1) { goto badStat; } sprintf(interp->result, "%ld", statBuf.st_size); goto done; } else if ((c == 's') && (strncmp(argv[1], "stat", length) == 0) && (length >= 2)) { if (argc != 4) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " stat name varName\"", (char *) NULL); result = TCL_ERROR; goto done; } if (stat(fileName, &statBuf) == -1) { badStat: Tcl_AppendResult(interp, "couldn't stat \"", argv[2], "\": ", Tcl_PosixError(interp), (char *) NULL); result = TCL_ERROR; goto done; } result = StoreStatData(interp, argv[3], &statBuf); goto done; } else if ((c == 't') && (strncmp(argv[1], "type", length) == 0) && (length >= 2)) { if (argc != 3) { argv[1] = "type"; goto not3Args; } if (lstat(fileName, &statBuf) == -1) { goto badStat; } interp->result = GetFileType((int) statBuf.st_mode); goto done; } else { Tcl_AppendResult(interp, "bad option \"", argv[1], "\": should be atime, dirname, executable, exists, ", "extension, isdirectory, isfile, lstat, mtime, owned, ", "readable, readlink, ", "root, size, stat, tail, type, ", "or writable", (char *) NULL); result = TCL_ERROR; goto done; } if (stat(fileName, &statBuf) == -1) { interp->result = "0"; goto done; } switch (statOp) { case 0: mode = (geteuid() == statBuf.st_uid); break; case 1: mode = S_ISREG(statBuf.st_mode); break; case 2: mode = S_ISDIR(statBuf.st_mode); break; } if (mode) { interp->result = "1"; } else { interp->result = "0"; } done: Tcl_DStringFree(&buffer); return result; } /* *---------------------------------------------------------------------- * * StoreStatData -- * * This is a utility procedure that breaks out the fields of a * "stat" structure and stores them in textual form into the * elements of an associative array. * * Results: * Returns a standard Tcl return value. If an error occurs then * a message is left in interp->result. * * Side effects: * Elements of the associative array given by "varName" are modified. * *---------------------------------------------------------------------- */ static int StoreStatData(interp, varName, statPtr) Tcl_Interp *interp; /* Interpreter for error reports. */ char *varName; /* Name of associative array variable * in which to store stat results. */ struct stat *statPtr; /* Pointer to buffer containing * stat data to store in varName. */ { char string[30]; sprintf(string, "%ld", statPtr->st_dev); if (Tcl_SetVar2(interp, varName, "dev", string, TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } sprintf(string, "%ld", statPtr->st_ino); if (Tcl_SetVar2(interp, varName, "ino", string, TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } sprintf(string, "%ld", statPtr->st_mode); if (Tcl_SetVar2(interp, varName, "mode", string, TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } sprintf(string, "%ld", statPtr->st_nlink); if (Tcl_SetVar2(interp, varName, "nlink", string, TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } sprintf(string, "%ld", (long) statPtr->st_uid); if (Tcl_SetVar2(interp, varName, "uid", string, TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } sprintf(string, "%ld", (long) statPtr->st_gid); if (Tcl_SetVar2(interp, varName, "gid", string, TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } sprintf(string, "%ld", statPtr->st_size); if (Tcl_SetVar2(interp, varName, "size", string, TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } sprintf(string, "%ld", statPtr->st_atime); if (Tcl_SetVar2(interp, varName, "atime", string, TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } sprintf(string, "%ld", statPtr->st_mtime); if (Tcl_SetVar2(interp, varName, "mtime", string, TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } sprintf(string, "%ld", statPtr->st_ctime); if (Tcl_SetVar2(interp, varName, "ctime", string, TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } if (Tcl_SetVar2(interp, varName, "type", GetFileType((int) statPtr->st_mode), TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } return TCL_OK; } /* *---------------------------------------------------------------------- * * GetFileType -- * * Given a mode word, returns a string identifying the type of a * file. * * Results: * A static text string giving the file type from mode. * * Side effects: * None. * *---------------------------------------------------------------------- */ static char * GetFileType(mode) int mode; { if (S_ISREG(mode)) { return "file"; } else if (S_ISDIR(mode)) { return "directory"; } else if (S_ISCHR(mode)) { return "characterSpecial"; } else if (S_ISBLK(mode)) { return "blockSpecial"; } else if (S_ISFIFO(mode)) { return "fifo"; } else if (S_ISLNK(mode)) { return "link"; } else if (S_ISSOCK(mode)) { return "socket"; } return "unknown"; } /* *---------------------------------------------------------------------- * * Tcl_FlushCmd -- * * This procedure is invoked to process the "flush" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_FlushCmd(notUsed, interp, argc, argv) ClientData notUsed; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { FILE *f; if (argc != 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " fileId\"", (char *) NULL); return TCL_ERROR; } if (Tcl_GetOpenFile(interp, argv[1], 1, 1, &f) != TCL_OK) { return TCL_ERROR; } clearerr(f); if (fflush(f) == EOF) { Tcl_AppendResult(interp, "error flushing \"", argv[1], "\": ", Tcl_PosixError(interp), (char *) NULL); return TCL_ERROR; } return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_GetsCmd -- * * This procedure is invoked to process the "gets" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_GetsCmd(notUsed, interp, argc, argv) ClientData notUsed; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { # define BUF_SIZE 200 char buffer[BUF_SIZE+1]; int totalCount, done, flags; FILE *f; if ((argc != 2) && (argc != 3)) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " fileId ?varName?\"", (char *) NULL); return TCL_ERROR; } if (Tcl_GetOpenFile(interp, argv[1], 0, 1, &f) != TCL_OK) { return TCL_ERROR; } /* * We can't predict how large a line will be, so read it in * pieces, appending to the current result or to a variable. */ totalCount = 0; done = 0; flags = 0; clearerr(f); while (!done) { register int c, count; register char *p; for (p = buffer, count = 0; count < BUF_SIZE-1; count++, p++) { c = getc(f); if (c == EOF) { if (ferror(f)) { /* * If the file is in non-blocking mode, return any * bytes that were read before a block would occur. */ if (((errno == EWOULDBLOCK) || (errno == EAGAIN)) && ((count > 0 || totalCount > 0))) { done = 1; break; } Tcl_ResetResult(interp); Tcl_AppendResult(interp, "error reading \"", argv[1], "\": ", Tcl_PosixError(interp), (char *) NULL); return TCL_ERROR; } else if (feof(f)) { if ((totalCount == 0) && (count == 0)) { totalCount = -1; } done = 1; break; } } if (c == '\n') { done = 1; break; } *p = c; } *p = 0; if (argc == 2) { Tcl_AppendResult(interp, buffer, (char *) NULL); } else { if (Tcl_SetVar(interp, argv[2], buffer, flags|TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } flags = TCL_APPEND_VALUE; } totalCount += count; } if (argc == 3) { sprintf(interp->result, "%d", totalCount); } return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_OpenCmd -- * * This procedure is invoked to process the "open" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_OpenCmd(notUsed, interp, argc, argv) ClientData notUsed; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { int pipeline, fd, mode, prot, readWrite, permissions; char *access; FILE *f, *f2; if ((argc < 2) || (argc > 4)) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " filename ?access? ?permissions?\"", (char *) NULL); return TCL_ERROR; } prot = 0666; if (argc == 2) { mode = O_RDONLY; access = "r"; } else { access = GetOpenMode(interp, argv[2], &mode); if (access == NULL) { return TCL_ERROR; } if (argc == 4) { if (Tcl_GetInt(interp, argv[3], &prot) != TCL_OK) { return TCL_ERROR; } } } f = f2 = NULL; readWrite = mode & (O_RDWR|O_RDONLY|O_WRONLY); if (readWrite == O_RDONLY) { permissions = TCL_FILE_READABLE; } else if (readWrite == O_WRONLY) { permissions = TCL_FILE_WRITABLE; } else { permissions = TCL_FILE_READABLE|TCL_FILE_WRITABLE; } pipeline = 0; if (argv[1][0] == '|') { pipeline = 1; } /* * Open the file or create a process pipeline. */ if (!pipeline) { char *fileName; Tcl_DString buffer; fileName = Tcl_TildeSubst(interp, argv[1], &buffer); if (fileName == NULL) { return TCL_ERROR; } fd = open(fileName, mode, prot); Tcl_DStringFree(&buffer); if (fd < 0) { Tcl_AppendResult(interp, "couldn't open \"", argv[1], "\": ", Tcl_PosixError(interp), (char *) NULL); return TCL_ERROR; } f = fdopen(fd, access); if (f == NULL) { close(fd); return TCL_ERROR; } Tcl_EnterFile(interp, f, permissions); } else { int *inPipePtr, *outPipePtr; int cmdArgc, inPipe, outPipe, numPids, *pidPtr, errorId; char **cmdArgv; OpenFile *oFilePtr; if (Tcl_SplitList(interp, argv[1]+1, &cmdArgc, &cmdArgv) != TCL_OK) { return TCL_ERROR; } inPipePtr = (permissions & TCL_FILE_WRITABLE) ? &inPipe : NULL; outPipePtr = (permissions & TCL_FILE_READABLE) ? &outPipe : NULL; inPipe = outPipe = errorId = -1; numPids = Tcl_CreatePipeline(interp, cmdArgc, cmdArgv, &pidPtr, inPipePtr, outPipePtr, &errorId); ckfree((char *) cmdArgv); if (numPids < 0) { pipelineError: if (f != NULL) { fclose(f); } if (f2 != NULL) { fclose(f2); } if (numPids > 0) { Tcl_DetachPids(numPids, pidPtr); ckfree((char *) pidPtr); } if (errorId != -1) { close(errorId); } return TCL_ERROR; } if (permissions & TCL_FILE_READABLE) { if (outPipe == -1) { if (inPipe != -1) { close(inPipe); } Tcl_AppendResult(interp, "can't read output from command:", " standard output was redirected", (char *) NULL); goto pipelineError; } f = fdopen(outPipe, "r"); } if (permissions & TCL_FILE_WRITABLE) { if (inPipe == -1) { Tcl_AppendResult(interp, "can't write input to command:", " standard input was redirected", (char *) NULL); goto pipelineError; } if (f != NULL) { f2 = fdopen(inPipe, "w"); } else { f = fdopen(inPipe, "w"); } } Tcl_EnterFile(interp, f, permissions); oFilePtr = tclOpenFiles[fileno(f)]; oFilePtr->f2 = f2; oFilePtr->numPids = numPids; oFilePtr->pidPtr = pidPtr; oFilePtr->errorId = errorId; } return TCL_OK; } /* *---------------------------------------------------------------------- * * GetOpenMode -- * * description. * * Results: * Normally, sets *modePtr to an access mode for passing to "open", * and returns a string that can be used as the access mode in a * subsequent call to "fdopen". If an error occurs, then returns * NULL and sets interp->result to an error message. * * Side effects: * None. * * Special note: * This code is based on a prototype implementation contributed * by Mark Diekhans. * *---------------------------------------------------------------------- */ static char * GetOpenMode(interp, string, modePtr) Tcl_Interp *interp; /* Interpreter to use for error * reporting. */ char *string; /* Mode string, e.g. "r+" or * "RDONLY CREAT". */ int *modePtr; /* Where to store mode corresponding * to string. */ { int mode, modeArgc, c, i, gotRW; char **modeArgv, *flag; #define RW_MODES (O_RDONLY|O_WRONLY|O_RDWR) /* * Check for the simpler fopen-like access modes (e.g. "r"). They * are distinguished from the POSIX access modes by the presence * of a lower-case first letter. */ mode = 0; if (islower(UCHAR(string[0]))) { switch (string[0]) { case 'r': mode = O_RDONLY; break; case 'w': mode = O_WRONLY|O_CREAT|O_TRUNC; break; case 'a': mode = O_WRONLY|O_CREAT|O_APPEND; break; default: error: Tcl_AppendResult(interp, "illegal access mode \"", string, "\"", (char *) NULL); return NULL; } if (string[1] == '+') { mode &= ~(O_RDONLY|O_WRONLY); mode |= O_RDWR; if (string[2] != 0) { goto error; } } else if (string[1] != 0) { goto error; } *modePtr = mode; return string; } /* * The access modes are specified using a list of POSIX modes * such as O_CREAT. */ if (Tcl_SplitList(interp, string, &modeArgc, &modeArgv) != TCL_OK) { Tcl_AddErrorInfo(interp, "\n while processing open access modes \""); Tcl_AddErrorInfo(interp, string); Tcl_AddErrorInfo(interp, "\""); return NULL; } gotRW = 0; for (i = 0; i < modeArgc; i++) { flag = modeArgv[i]; c = flag[0]; if ((c == 'R') && (strcmp(flag, "RDONLY") == 0)) { mode = (mode & ~RW_MODES) | O_RDONLY; gotRW = 1; } else if ((c == 'W') && (strcmp(flag, "WRONLY") == 0)) { mode = (mode & ~RW_MODES) | O_WRONLY; gotRW = 1; } else if ((c == 'R') && (strcmp(flag, "RDWR") == 0)) { mode = (mode & ~RW_MODES) | O_RDWR; gotRW = 1; } else if ((c == 'A') && (strcmp(flag, "APPEND") == 0)) { mode |= O_APPEND; } else if ((c == 'C') && (strcmp(flag, "CREAT") == 0)) { mode |= O_CREAT; } else if ((c == 'E') && (strcmp(flag, "EXCL") == 0)) { mode |= O_EXCL; } else if ((c == 'N') && (strcmp(flag, "NOCTTY") == 0)) { #ifdef O_NOCTTY mode |= O_NOCTTY; #else Tcl_AppendResult(interp, "access mode \"", flag, "\" not supported by this system", (char *) NULL); ckfree((char *) modeArgv); return NULL; #endif } else if ((c == 'N') && (strcmp(flag, "NONBLOCK") == 0)) { #ifdef O_NONBLOCK mode |= O_NONBLOCK; #else mode |= O_NDELAY; #endif } else if ((c == 'T') && (strcmp(flag, "TRUNC") == 0)) { mode |= O_TRUNC; } else { Tcl_AppendResult(interp, "invalid access mode \"", flag, "\": must be RDONLY, WRONLY, RDWR, APPEND, CREAT", " EXCL, NOCTTY, NONBLOCK, or TRUNC", (char *) NULL); ckfree((char *) modeArgv); return NULL; } } ckfree((char *) modeArgv); if (!gotRW) { Tcl_AppendResult(interp, "access mode must include either", " RDONLY, WRONLY, or RDWR", (char *) NULL); return NULL; } *modePtr = mode; /* * The calculation of fdopen access mode below isn't really correct, * but it doesn't have to be. All it has to do is to disinguish * read and write permissions, plus indicate append mode. */ i = mode & RW_MODES; if (i == O_RDONLY) { return "r"; } if (mode & O_APPEND) { if (i == O_WRONLY) { return "a"; } else { return "a+"; } } if (i == O_WRONLY) { return "w"; } return "r+"; } /* *---------------------------------------------------------------------- * * Tcl_PidCmd -- * * This procedure is invoked to process the "pid" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_PidCmd(dummy, interp, argc, argv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { FILE *f; OpenFile *oFilePtr; int i; char string[50]; if (argc > 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " ?fileId?\"", (char *) NULL); return TCL_ERROR; } if (argc == 1) { sprintf(interp->result, "%ld", (long) getpid()); } else { if (Tcl_GetOpenFile(interp, argv[1], 0, 0, &f) != TCL_OK) { return TCL_ERROR; } oFilePtr = tclOpenFiles[fileno(f)]; for (i = 0; i < oFilePtr->numPids; i++) { sprintf(string, "%d", oFilePtr->pidPtr[i]); Tcl_AppendElement(interp, string); } } return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_PutsCmd -- * * This procedure is invoked to process the "puts" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_PutsCmd(dummy, interp, argc, argv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { FILE *f; int i, newline; char *fileId; i = 1; newline = 1; if ((argc >= 2) && (strcmp(argv[1], "-nonewline") == 0)) { newline = 0; i++; } if ((i < (argc-3)) || (i >= argc)) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " ?-nonewline? ?fileId? string\"", (char *) NULL); return TCL_ERROR; } /* * The code below provides backwards compatibility with an old * form of the command that is no longer recommended or documented. */ if (i == (argc-3)) { if (strncmp(argv[i+2], "nonewline", strlen(argv[i+2])) != 0) { Tcl_AppendResult(interp, "bad argument \"", argv[i+2], "\": should be \"nonewline\"", (char *) NULL); return TCL_ERROR; } newline = 0; } if (i == (argc-1)) { fileId = "stdout"; } else { fileId = argv[i]; i++; } if (Tcl_GetOpenFile(interp, fileId, 1, 1, &f) != TCL_OK) { return TCL_ERROR; } clearerr(f); fputs(argv[i], f); if (newline) { fputc('\n', f); } if (ferror(f)) { Tcl_AppendResult(interp, "error writing \"", fileId, "\": ", Tcl_PosixError(interp), (char *) NULL); return TCL_ERROR; } return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_PwdCmd -- * * This procedure is invoked to process the "pwd" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_PwdCmd(dummy, interp, argc, argv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { char buffer[MAXPATHLEN+1]; if (argc != 1) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], "\"", (char *) NULL); return TCL_ERROR; } if (currentDir == NULL) { if (getcwd(buffer, MAXPATHLEN+1) == NULL) { if (errno == ERANGE) { interp->result = "working directory name is too long"; } else { Tcl_AppendResult(interp, "error getting working directory name: ", Tcl_PosixError(interp), (char *) NULL); } return TCL_ERROR; } currentDir = (char *) ckalloc((unsigned) (strlen(buffer) + 1)); strcpy(currentDir, buffer); } interp->result = currentDir; return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_ReadCmd -- * * This procedure is invoked to process the "read" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_ReadCmd(dummy, interp, argc, argv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { int bytesLeft, bytesRead, askedFor, got; #define READ_BUF_SIZE 4096 char buffer[READ_BUF_SIZE+1]; int newline, i; FILE *f; if ((argc != 2) && (argc != 3)) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " fileId ?numBytes?\" or \"", argv[0], " ?-nonewline? fileId\"", (char *) NULL); return TCL_ERROR; } i = 1; newline = 1; if ((argc == 3) && (strcmp(argv[1], "-nonewline") == 0)) { newline = 0; i++; } if (Tcl_GetOpenFile(interp, argv[i], 0, 1, &f) != TCL_OK) { return TCL_ERROR; } /* * Compute how many bytes to read, and see whether the final * newline should be dropped. */ if ((argc >= (i + 2)) && isdigit(UCHAR(argv[i+1][0]))) { if (Tcl_GetInt(interp, argv[i+1], &bytesLeft) != TCL_OK) { return TCL_ERROR; } } else { bytesLeft = INT_MAX; /* * The code below provides backward compatibility for an * archaic earlier version of this command. */ if (argc >= (i + 2)) { if (strncmp(argv[i+1], "nonewline", strlen(argv[i+1])) == 0) { newline = 0; } else { Tcl_AppendResult(interp, "bad argument \"", argv[i+1], "\": should be \"nonewline\"", (char *) NULL); return TCL_ERROR; } } } /* * Read the file in one or more chunks. */ bytesRead = 0; clearerr(f); while (bytesLeft > 0) { askedFor = READ_BUF_SIZE; if (bytesLeft < READ_BUF_SIZE) { askedFor = bytesLeft; } got = fread(buffer, 1, (size_t) askedFor, f); if (ferror(f)) { /* * If the file is in non-blocking mode, break out of the * loop and return any bytes that were read. */ if (((errno == EWOULDBLOCK) || (errno == EAGAIN)) && ((got > 0) || (bytesRead > 0))) { clearerr(f); bytesLeft = got; } else { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "error reading \"", argv[i], "\": ", Tcl_PosixError(interp), (char *) NULL); return TCL_ERROR; } } if (got != 0) { buffer[got] = 0; Tcl_AppendResult(interp, buffer, (char *) NULL); bytesLeft -= got; bytesRead += got; } if (got < askedFor) { break; } } if ((newline == 0) && (bytesRead > 0) && (interp->result[bytesRead-1] == '\n')) { interp->result[bytesRead-1] = 0; } return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_SeekCmd -- * * This procedure is invoked to process the "seek" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_SeekCmd(notUsed, interp, argc, argv) ClientData notUsed; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { FILE *f; int offset, mode; if ((argc != 3) && (argc != 4)) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " fileId offset ?origin?\"", (char *) NULL); return TCL_ERROR; } if (Tcl_GetOpenFile(interp, argv[1], 0, 0, &f) != TCL_OK) { return TCL_ERROR; } if (Tcl_GetInt(interp, argv[2], &offset) != TCL_OK) { return TCL_ERROR; } mode = SEEK_SET; if (argc == 4) { size_t length; int c; length = strlen(argv[3]); c = argv[3][0]; if ((c == 's') && (strncmp(argv[3], "start", length) == 0)) { mode = SEEK_SET; } else if ((c == 'c') && (strncmp(argv[3], "current", length) == 0)) { mode = SEEK_CUR; } else if ((c == 'e') && (strncmp(argv[3], "end", length) == 0)) { mode = SEEK_END; } else { Tcl_AppendResult(interp, "bad origin \"", argv[3], "\": should be start, current, or end", (char *) NULL); return TCL_ERROR; } } clearerr(f); if (fseek(f, (long) offset, mode) == -1) { Tcl_AppendResult(interp, "error during seek: ", Tcl_PosixError(interp), (char *) NULL); return TCL_ERROR; } return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_SourceCmd -- * * This procedure is invoked to process the "source" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_SourceCmd(dummy, interp, argc, argv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { if (argc != 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " fileName\"", (char *) NULL); return TCL_ERROR; } return Tcl_EvalFile(interp, argv[1]); } /* *---------------------------------------------------------------------- * * Tcl_TellCmd -- * * This procedure is invoked to process the "tell" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_TellCmd(notUsed, interp, argc, argv) ClientData notUsed; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { FILE *f; if (argc != 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " fileId\"", (char *) NULL); return TCL_ERROR; } if (Tcl_GetOpenFile(interp, argv[1], 0, 0, &f) != TCL_OK) { return TCL_ERROR; } sprintf(interp->result, "%ld", (long int) ftell(f)); return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_TimeCmd -- * * This procedure is invoked to process the "time" Tcl command. * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_TimeCmd(dummy, interp, argc, argv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { int count, i, result; double timePer; #if NO_GETTOD struct tms dummy2; long start, stop; #else struct timeval start, stop; struct timezone tz; int micros; #endif if (argc == 2) { count = 1; } else if (argc == 3) { if (Tcl_GetInt(interp, argv[2], &count) != TCL_OK) { return TCL_ERROR; } } else { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " command ?count?\"", (char *) NULL); return TCL_ERROR; } #if NO_GETTOD start = times(&dummy2); #else gettimeofday(&start, &tz); #endif for (i = count ; i > 0; i--) { result = Tcl_Eval(interp, argv[1]); if (result != TCL_OK) { if (result == TCL_ERROR) { char msg[60]; sprintf(msg, "\n (\"time\" body line %d)", interp->errorLine); Tcl_AddErrorInfo(interp, msg); } return result; } } #if NO_GETTOD stop = times(&dummy2); timePer = (((double) (stop - start))*1000000.0)/CLK_TCK; #else gettimeofday(&stop, &tz); micros = (stop.tv_sec - start.tv_sec)*1000000 + (stop.tv_usec - start.tv_usec); timePer = micros; #endif Tcl_ResetResult(interp); sprintf(interp->result, "%.0f microseconds per iteration", (count <= 0) ? 0 : timePer/count); return TCL_OK; } /* *---------------------------------------------------------------------- * * CleanupChildren -- * * This is a utility procedure used to wait for child processes * to exit, record information about abnormal exits, and then * collect any stderr output generated by them. * * Results: * The return value is a standard Tcl result. If anything at * weird happened with the child processes, TCL_ERROR is returned * and a message is left in interp->result. * * Side effects: * If the last character of interp->result is a newline, then it * is removed unless keepNewline is non-zero. File errorId gets * closed, and pidPtr is freed back to the storage allocator. * *---------------------------------------------------------------------- */ static int CleanupChildren(interp, numPids, pidPtr, errorId, keepNewline) Tcl_Interp *interp; /* Used for error messages. */ int numPids; /* Number of entries in pidPtr array. */ int *pidPtr; /* Array of process ids of children. */ int errorId; /* File descriptor index for file containing * stderr output from pipeline. -1 means * there isn't any stderr output. */ int keepNewline; /* Non-zero means don't discard trailing * newline. */ { int result = TCL_OK; int i, pid, length, abnormalExit; WAIT_STATUS_TYPE waitStatus; abnormalExit = 0; for (i = 0; i < numPids; i++) { pid = waitpid(pidPtr[i], (int *) &waitStatus, 0); if (pid == -1) { Tcl_AppendResult(interp, "error waiting for process to exit: ", Tcl_PosixError(interp), (char *) NULL); continue; } /* * Create error messages for unusual process exits. An * extra newline gets appended to each error message, but * it gets removed below (in the same fashion that an * extra newline in the command's output is removed). */ if (!WIFEXITED(waitStatus) || (WEXITSTATUS(waitStatus) != 0)) { char msg1[20], msg2[20]; result = TCL_ERROR; sprintf(msg1, "%d", pid); if (WIFEXITED(waitStatus)) { sprintf(msg2, "%d", WEXITSTATUS(waitStatus)); Tcl_SetErrorCode(interp, "CHILDSTATUS", msg1, msg2, (char *) NULL); abnormalExit = 1; } else if (WIFSIGNALED(waitStatus)) { char *p; p = Tcl_SignalMsg((int) (WTERMSIG(waitStatus))); Tcl_SetErrorCode(interp, "CHILDKILLED", msg1, Tcl_SignalId((int) (WTERMSIG(waitStatus))), p, (char *) NULL); Tcl_AppendResult(interp, "child killed: ", p, "\n", (char *) NULL); } else if (WIFSTOPPED(waitStatus)) { char *p; p = Tcl_SignalMsg((int) (WSTOPSIG(waitStatus))); Tcl_SetErrorCode(interp, "CHILDSUSP", msg1, Tcl_SignalId((int) (WSTOPSIG(waitStatus))), p, (char *) NULL); Tcl_AppendResult(interp, "child suspended: ", p, "\n", (char *) NULL); } else { Tcl_AppendResult(interp, "child wait status didn't make sense\n", (char *) NULL); } } } ckfree((char *) pidPtr); /* * Read the standard error file. If there's anything there, * then return an error and add the file's contents to the result * string. */ if (errorId >= 0) { while (1) { # define BUFFER_SIZE 1000 char buffer[BUFFER_SIZE+1]; int count; count = read(errorId, buffer, (size_t) BUFFER_SIZE); if (count == 0) { break; } result = TCL_ERROR; if (count < 0) { Tcl_AppendResult(interp, "error reading stderr output file: ", Tcl_PosixError(interp), (char *) NULL); break; } buffer[count] = 0; Tcl_AppendResult(interp, buffer, (char *) NULL); } close(errorId); } /* * If a child exited abnormally but didn't output any error information * at all, generate an error message here. */ if (abnormalExit && (*interp->result == 0)) { Tcl_AppendResult(interp, "child process exited abnormally", (char *) NULL); } /* * If the last character of interp->result is a newline, then remove * the newline character (the newline would just confuse things). * Special hack: must replace the old terminating null character * as a signal to Tcl_AppendResult et al. that we've mucked with * the string. */ length = strlen(interp->result); if (!keepNewline && (length > 0) && (interp->result[length-1] == '\n')) { interp->result[length-1] = '\0'; interp->result[length] = 'x'; } return result; } ": ", Tcl_PosixError(interp), (char *) NULL); retcl7.4b4/tclUnixStr.c010044400630510000012000000366200573464741100153270ustar00ousterstaff00002300000001/* * tclUnixStr.c -- * * This file contains procedures that generate strings * corresponding to various UNIX-related codes, such * as errno and signals. * * Copyright (c) 1991-1994 The Regents of the University of California. * Copyright (c) 1994 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #ifndef lint static char sccsid[] = "@(#) tclUnixStr.c 1.21 95/03/24 15:00:25"; #endif /* not lint */ #include "tclInt.h" #include "tclPort.h" /* *---------------------------------------------------------------------- * * Tcl_ErrnoId -- * * Return a textual identifier for the current errno value. * * Results: * This procedure returns a machine-readable textual identifier * that corresponds to the current errno value (e.g. "EPERM"). * The identifier is the same as the #define name in errno.h. * * Side effects: * None. * *---------------------------------------------------------------------- */ char * Tcl_ErrnoId() { switch (errno) { #ifdef E2BIG case E2BIG: return "E2BIG"; #endif #ifdef EACCES case EACCES: return "EACCES"; #endif #ifdef EADDRINUSE case EADDRINUSE: return "EADDRINUSE"; #endif #ifdef EADDRNOTAVAIL case EADDRNOTAVAIL: return "EADDRNOTAVAIL"; #endif #ifdef EADV case EADV: return "EADV"; #endif #ifdef EAFNOSUPPORT case EAFNOSUPPORT: return "EAFNOSUPPORT"; #endif #ifdef EAGAIN case EAGAIN: return "EAGAIN"; #endif #ifdef EALIGN case EALIGN: return "EALIGN"; #endif #ifdef EALREADY case EALREADY: return "EALREADY"; #endif #ifdef EBADE case EBADE: return "EBADE"; #endif #ifdef EBADF case EBADF: return "EBADF"; #endif #ifdef EBADFD case EBADFD: return "EBADFD"; #endif #ifdef EBADMSG case EBADMSG: return "EBADMSG"; #endif #ifdef EBADR case EBADR: return "EBADR"; #endif #ifdef EBADRPC case EBADRPC: return "EBADRPC"; #endif #ifdef EBADRQC case EBADRQC: return "EBADRQC"; #endif #ifdef EBADSLT case EBADSLT: return "EBADSLT"; #endif #ifdef EBFONT case EBFONT: return "EBFONT"; #endif #ifdef EBUSY case EBUSY: return "EBUSY"; #endif #ifdef ECHILD case ECHILD: return "ECHILD"; #endif #ifdef ECHRNG case ECHRNG: return "ECHRNG"; #endif #ifdef ECOMM case ECOMM: return "ECOMM"; #endif #ifdef ECONNABORTED case ECONNABORTED: return "ECONNABORTED"; #endif #ifdef ECONNREFUSED case ECONNREFUSED: return "ECONNREFUSED"; #endif #ifdef ECONNRESET case ECONNRESET: return "ECONNRESET"; #endif #if defined(EDEADLK) && (!defined(EWOULDBLOCK) || (EDEADLK != EWOULDBLOCK)) case EDEADLK: return "EDEADLK"; #endif #ifdef EDEADLOCK case EDEADLOCK: return "EDEADLOCK"; #endif #ifdef EDESTADDRREQ case EDESTADDRREQ: return "EDESTADDRREQ"; #endif #ifdef EDIRTY case EDIRTY: return "EDIRTY"; #endif #ifdef EDOM case EDOM: return "EDOM"; #endif #ifdef EDOTDOT case EDOTDOT: return "EDOTDOT"; #endif #ifdef EDQUOT case EDQUOT: return "EDQUOT"; #endif #ifdef EDUPPKG case EDUPPKG: return "EDUPPKG"; #endif #ifdef EEXIST case EEXIST: return "EEXIST"; #endif #ifdef EFAULT case EFAULT: return "EFAULT"; #endif #ifdef EFBIG case EFBIG: return "EFBIG"; #endif #ifdef EHOSTDOWN case EHOSTDOWN: return "EHOSTDOWN"; #endif #ifdef EHOSTUNREACH case EHOSTUNREACH: return "EHOSTUNREACH"; #endif #if defined(EIDRM) && (!defined(EINPROGRESS) || (EIDRM != EINPROGRESS)) case EIDRM: return "EIDRM"; #endif #ifdef EINIT case EINIT: return "EINIT"; #endif #ifdef EINPROGRESS case EINPROGRESS: return "EINPROGRESS"; #endif #ifdef EINTR case EINTR: return "EINTR"; #endif #ifdef EINVAL case EINVAL: return "EINVAL"; #endif #ifdef EIO case EIO: return "EIO"; #endif #ifdef EISCONN case EISCONN: return "EISCONN"; #endif #ifdef EISDIR case EISDIR: return "EISDIR"; #endif #ifdef EISNAME case EISNAM: return "EISNAM"; #endif #ifdef ELBIN case ELBIN: return "ELBIN"; #endif #ifdef EL2HLT case EL2HLT: return "EL2HLT"; #endif #ifdef EL2NSYNC case EL2NSYNC: return "EL2NSYNC"; #endif #ifdef EL3HLT case EL3HLT: return "EL3HLT"; #endif #ifdef EL3RST case EL3RST: return "EL3RST"; #endif #ifdef ELIBACC case ELIBACC: return "ELIBACC"; #endif #ifdef ELIBBAD case ELIBBAD: return "ELIBBAD"; #endif #ifdef ELIBEXEC case ELIBEXEC: return "ELIBEXEC"; #endif #ifdef ELIBMAX case ELIBMAX: return "ELIBMAX"; #endif #ifdef ELIBSCN case ELIBSCN: return "ELIBSCN"; #endif #ifdef ELNRNG case ELNRNG: return "ELNRNG"; #endif #ifdef ELOOP case ELOOP: return "ELOOP"; #endif #ifdef EMFILE case EMFILE: return "EMFILE"; #endif #ifdef EMLINK case EMLINK: return "EMLINK"; #endif #ifdef EMSGSIZE case EMSGSIZE: return "EMSGSIZE"; #endif #ifdef EMULTIHOP case EMULTIHOP: return "EMULTIHOP"; #endif #ifdef ENAMETOOLONG case ENAMETOOLONG: return "ENAMETOOLONG"; #endif #ifdef ENAVAIL case ENAVAIL: return "ENAVAIL"; #endif #ifdef ENET case ENET: return "ENET"; #endif #ifdef ENETDOWN case ENETDOWN: return "ENETDOWN"; #endif #ifdef ENETRESET case ENETRESET: return "ENETRESET"; #endif #ifdef ENETUNREACH case ENETUNREACH: return "ENETUNREACH"; #endif #ifdef ENFILE case ENFILE: return "ENFILE"; #endif #ifdef ENOANO case ENOANO: return "ENOANO"; #endif #if defined(ENOBUFS) && (!defined(ENOSR) || (ENOBUFS != ENOSR)) case ENOBUFS: return "ENOBUFS"; #endif #ifdef ENOCSI case ENOCSI: return "ENOCSI"; #endif #if defined(ENODATA) && (!defined(ECONNREFUSED) || (ENODATA != ECONNREFUSED)) case ENODATA: return "ENODATA"; #endif #ifdef ENODEV case ENODEV: return "ENODEV"; #endif #ifdef ENOENT case ENOENT: return "ENOENT"; #endif #ifdef ENOEXEC case ENOEXEC: return "ENOEXEC"; #endif #ifdef ENOLCK case ENOLCK: return "ENOLCK"; #endif #ifdef ENOLINK case ENOLINK: return "ENOLINK"; #endif #ifdef ENOMEM case ENOMEM: return "ENOMEM"; #endif #ifdef ENOMSG case ENOMSG: return "ENOMSG"; #endif #ifdef ENONET case ENONET: return "ENONET"; #endif #ifdef ENOPKG case ENOPKG: return "ENOPKG"; #endif #ifdef ENOPROTOOPT case ENOPROTOOPT: return "ENOPROTOOPT"; #endif #ifdef ENOSPC case ENOSPC: return "ENOSPC"; #endif #if defined(ENOSR) && (!defined(ENAMETOOLONG) || (ENAMETOOLONG != ENOSR)) case ENOSR: return "ENOSR"; #endif #if defined(ENOSTR) && (!defined(ENOTTY) || (ENOTTY != ENOSTR)) case ENOSTR: return "ENOSTR"; #endif #ifdef ENOSYM case ENOSYM: return "ENOSYM"; #endif #ifdef ENOSYS case ENOSYS: return "ENOSYS"; #endif #ifdef ENOTBLK case ENOTBLK: return "ENOTBLK"; #endif #ifdef ENOTCONN case ENOTCONN: return "ENOTCONN"; #endif #ifdef ENOTDIR case ENOTDIR: return "ENOTDIR"; #endif #if defined(ENOTEMPTY) && (!defined(EEXIST) || (ENOTEMPTY != EEXIST)) case ENOTEMPTY: return "ENOTEMPTY"; #endif #ifdef ENOTNAM case ENOTNAM: return "ENOTNAM"; #endif #ifdef ENOTSOCK case ENOTSOCK: return "ENOTSOCK"; #endif #ifdef ENOTTY case ENOTTY: return "ENOTTY"; #endif #ifdef ENOTUNIQ case ENOTUNIQ: return "ENOTUNIQ"; #endif #ifdef ENXIO case ENXIO: return "ENXIO"; #endif #ifdef EOPNOTSUPP case EOPNOTSUPP: return "EOPNOTSUPP"; #endif #ifdef EPERM case EPERM: return "EPERM"; #endif #if defined(EPFNOSUPPORT) && (!defined(ENOLCK) || (ENOLCK != EPFNOSUPPORT)) case EPFNOSUPPORT: return "EPFNOSUPPORT"; #endif #ifdef EPIPE case EPIPE: return "EPIPE"; #endif #ifdef EPROCLIM case EPROCLIM: return "EPROCLIM"; #endif #ifdef EPROCUNAVAIL case EPROCUNAVAIL: return "EPROCUNAVAIL"; #endif #ifdef EPROGMISMATCH case EPROGMISMATCH: return "EPROGMISMATCH"; #endif #ifdef EPROGUNAVAIL case EPROGUNAVAIL: return "EPROGUNAVAIL"; #endif #ifdef EPROTO case EPROTO: return "EPROTO"; #endif #ifdef EPROTONOSUPPORT case EPROTONOSUPPORT: return "EPROTONOSUPPORT"; #endif #ifdef EPROTOTYPE case EPROTOTYPE: return "EPROTOTYPE"; #endif #ifdef ERANGE case ERANGE: return "ERANGE"; #endif #if defined(EREFUSED) && (!defined(ECONNREFUSED) || (EREFUSED != ECONNREFUSED)) case EREFUSED: return "EREFUSED"; #endif #ifdef EREMCHG case EREMCHG: return "EREMCHG"; #endif #ifdef EREMDEV case EREMDEV: return "EREMDEV"; #endif #ifdef EREMOTE case EREMOTE: return "EREMOTE"; #endif #ifdef EREMOTEIO case EREMOTEIO: return "EREMOTEIO"; #endif #ifdef EREMOTERELEASE case EREMOTERELEASE: return "EREMOTERELEASE"; #endif #ifdef EROFS case EROFS: return "EROFS"; #endif #ifdef ERPCMISMATCH case ERPCMISMATCH: return "ERPCMISMATCH"; #endif #ifdef ERREMOTE case ERREMOTE: return "ERREMOTE"; #endif #ifdef ESHUTDOWN case ESHUTDOWN: return "ESHUTDOWN"; #endif #ifdef ESOCKTNOSUPPORT case ESOCKTNOSUPPORT: return "ESOCKTNOSUPPORT"; #endif #ifdef ESPIPE case ESPIPE: return "ESPIPE"; #endif #ifdef ESRCH case ESRCH: return "ESRCH"; #endif #ifdef ESRMNT case ESRMNT: return "ESRMNT"; #endif #ifdef ESTALE case ESTALE: return "ESTALE"; #endif #ifdef ESUCCESS case ESUCCESS: return "ESUCCESS"; #endif #if defined(ETIME) && (!defined(ELOOP) || (ETIME != ELOOP)) case ETIME: return "ETIME"; #endif #if defined(ETIMEDOUT) && (!defined(ENOSTR) || (ETIMEDOUT != ENOSTR)) case ETIMEDOUT: return "ETIMEDOUT"; #endif #ifdef ETOOMANYREFS case ETOOMANYREFS: return "ETOOMANYREFS"; #endif #ifdef ETXTBSY case ETXTBSY: return "ETXTBSY"; #endif #ifdef EUCLEAN case EUCLEAN: return "EUCLEAN"; #endif #ifdef EUNATCH case EUNATCH: return "EUNATCH"; #endif #ifdef EUSERS case EUSERS: return "EUSERS"; #endif #ifdef EVERSION case EVERSION: return "EVERSION"; #endif #if defined(EWOULDBLOCK) && (!defined(EAGAIN) || (EWOULDBLOCK != EAGAIN)) case EWOULDBLOCK: return "EWOULDBLOCK"; #endif #ifdef EXDEV case EXDEV: return "EXDEV"; #endif #ifdef EXFULL case EXFULL: return "EXFULL"; #endif } return "unknown error"; } /* *---------------------------------------------------------------------- * * Tcl_SignalId -- * * Return a textual identifier for a signal number. * * Results: * This procedure returns a machine-readable textual identifier * that corresponds to sig. The identifier is the same as the * #define name in signal.h. * * Side effects: * None. * *---------------------------------------------------------------------- */ char * Tcl_SignalId(sig) int sig; /* Number of signal. */ { switch (sig) { #ifdef SIGABRT case SIGABRT: return "SIGABRT"; #endif #ifdef SIGALRM case SIGALRM: return "SIGALRM"; #endif #ifdef SIGBUS case SIGBUS: return "SIGBUS"; #endif #ifdef SIGCHLD case SIGCHLD: return "SIGCHLD"; #endif #if defined(SIGCLD) && (!defined(SIGCHLD) || (SIGCLD != SIGCHLD)) case SIGCLD: return "SIGCLD"; #endif #ifdef SIGCONT case SIGCONT: return "SIGCONT"; #endif #if defined(SIGEMT) && (!defined(SIGXCPU) || (SIGEMT != SIGXCPU)) case SIGEMT: return "SIGEMT"; #endif #ifdef SIGFPE case SIGFPE: return "SIGFPE"; #endif #ifdef SIGHUP case SIGHUP: return "SIGHUP"; #endif #ifdef SIGILL case SIGILL: return "SIGILL"; #endif #ifdef SIGINT case SIGINT: return "SIGINT"; #endif #ifdef SIGIO case SIGIO: return "SIGIO"; #endif #if defined(SIGIOT) && (!defined(SIGABRT) || (SIGIOT != SIGABRT)) case SIGIOT: return "SIGIOT"; #endif #ifdef SIGKILL case SIGKILL: return "SIGKILL"; #endif #if defined(SIGLOST) && (!defined(SIGIOT) || (SIGLOST != SIGIOT)) && (!defined(SIGURG) || (SIGLOST != SIGURG)) case SIGLOST: return "SIGLOST"; #endif #ifdef SIGPIPE case SIGPIPE: return "SIGPIPE"; #endif #if defined(SIGPOLL) && (!defined(SIGIO) || (SIGPOLL != SIGIO)) case SIGPOLL: return "SIGPOLL"; #endif #ifdef SIGPROF case SIGPROF: return "SIGPROF"; #endif #if defined(SIGPWR) && (!defined(SIGXFSZ) || (SIGPWR != SIGXFSZ)) case SIGPWR: return "SIGPWR"; #endif #ifdef SIGQUIT case SIGQUIT: return "SIGQUIT"; #endif #ifdef SIGSEGV case SIGSEGV: return "SIGSEGV"; #endif #ifdef SIGSTOP case SIGSTOP: return "SIGSTOP"; #endif #ifdef SIGSYS case SIGSYS: return "SIGSYS"; #endif #ifdef SIGTERM case SIGTERM: return "SIGTERM"; #endif #ifdef SIGTRAP case SIGTRAP: return "SIGTRAP"; #endif #ifdef SIGTSTP case SIGTSTP: return "SIGTSTP"; #endif #ifdef SIGTTIN case SIGTTIN: return "SIGTTIN"; #endif #ifdef SIGTTOU case SIGTTOU: return "SIGTTOU"; #endif #if defined(SIGURG) && (!defined(SIGIO) || (SIGURG != SIGIO)) case SIGURG: return "SIGURG"; #endif #if defined(SIGUSR1) && (!defined(SIGIO) || (SIGUSR1 != SIGIO)) case SIGUSR1: return "SIGUSR1"; #endif #if defined(SIGUSR2) && (!defined(SIGURG) || (SIGUSR2 != SIGURG)) case SIGUSR2: return "SIGUSR2"; #endif #ifdef SIGVTALRM case SIGVTALRM: return "SIGVTALRM"; #endif #ifdef SIGWINCH case SIGWINCH: return "SIGWINCH"; #endif #ifdef SIGXCPU case SIGXCPU: return "SIGXCPU"; #endif #ifdef SIGXFSZ case SIGXFSZ: return "SIGXFSZ"; #endif } return "unknown signal"; } /* *---------------------------------------------------------------------- * * Tcl_SignalMsg -- * * Return a human-readable message describing a signal. * * Results: * This procedure returns a string describing sig that should * make sense to a human. It may not be easy for a machine * to parse. * * Side effects: * None. * *---------------------------------------------------------------------- */ char * Tcl_SignalMsg(sig) int sig; /* Number of signal. */ { switch (sig) { #ifdef SIGABRT case SIGABRT: return "SIGABRT"; #endif #ifdef SIGALRM case SIGALRM: return "alarm clock"; #endif #ifdef SIGBUS case SIGBUS: return "bus error"; #endif #ifdef SIGCHLD case SIGCHLD: return "child status changed"; #endif #if defined(SIGCLD) && (!defined(SIGCHLD) || (SIGCLD != SIGCHLD)) case SIGCLD: return "child status changed"; #endif #ifdef SIGCONT case SIGCONT: return "continue after stop"; #endif #if defined(SIGEMT) && (!defined(SIGXCPU) || (SIGEMT != SIGXCPU)) case SIGEMT: return "EMT instruction"; #endif #ifdef SIGFPE case SIGFPE: return "floating-point exception"; #endif #ifdef SIGHUP case SIGHUP: return "hangup"; #endif #ifdef SIGILL case SIGILL: return "illegal instruction"; #endif #ifdef SIGINT case SIGINT: return "interrupt"; #endif #ifdef SIGIO case SIGIO: return "input/output possible on file"; #endif #if defined(SIGIOT) && (!defined(SIGABRT) || (SIGABRT != SIGIOT)) case SIGIOT: return "IOT instruction"; #endif #ifdef SIGKILL case SIGKILL: return "kill signal"; #endif #if defined(SIGLOST) && (!defined(SIGIOT) || (SIGLOST != SIGIOT)) && (!defined(SIGURG) || (SIGLOST != SIGURG)) case SIGLOST: return "resource lost"; #endif #ifdef SIGPIPE case SIGPIPE: return "write on pipe with no readers"; #endif #if defined(SIGPOLL) && (!defined(SIGIO) || (SIGPOLL != SIGIO)) case SIGPOLL: return "input/output possible on file"; #endif #ifdef SIGPROF case SIGPROF: return "profiling alarm"; #endif #if defined(SIGPWR) && (!defined(SIGXFSZ) || (SIGPWR != SIGXFSZ)) case SIGPWR: return "power-fail restart"; #endif #ifdef SIGQUIT case SIGQUIT: return "quit signal"; #endif #ifdef SIGSEGV case SIGSEGV: return "segmentation violation"; #endif #ifdef SIGSTOP case SIGSTOP: return "stop"; #endif #ifdef SIGSYS case SIGSYS: return "bad argument to system call"; #endif #ifdef SIGTERM case SIGTERM: return "software termination signal"; #endif #ifdef SIGTRAP case SIGTRAP: return "trace trap"; #endif #ifdef SIGTSTP case SIGTSTP: return "stop signal from tty"; #endif #ifdef SIGTTIN case SIGTTIN: return "background tty read"; #endif #ifdef SIGTTOU case SIGTTOU: return "background tty write"; #endif #if defined(SIGURG) && (!defined(SIGIO) || (SIGURG != SIGIO)) case SIGURG: return "urgent I/O condition"; #endif #if defined(SIGUSR1) && (!defined(SIGIO) || (SIGUSR1 != SIGIO)) case SIGUSR1: return "user-defined signal 1"; #endif #if defined(SIGUSR2) && (!defined(SIGURG) || (SIGUSR2 != SIGURG)) case SIGUSR2: return "user-defined signal 2"; #endif #ifdef SIGVTALRM case SIGVTALRM: return "virtual time alarm"; #endif #ifdef SIGWINCH case SIGWINCH: return "window changed"; #endif #ifdef SIGXCPU case SIGXCPU: return "exceeded CPU time limit"; #endif #ifdef SIGXFSZ case SIGXFSZ: return "exceeded file size limit"; #endif } return "unknown signal"; } G) || (ENAMETOOLONG != ENOSR)) case ENOSR: return "ENOSR"; #endif #if defined(ENOSTR) && (!defined(ENOTTY) || (tcl7.4b4/tclUnixUtil.c010044400630510000012000001141440573633175200154720ustar00ousterstaff00002300000001/* * tclUnixUtil.c -- * * This file contains a collection of utility procedures that * are present in the Tcl's UNIX core but not in the generic * core. For example, they do file manipulation and process * manipulation. * * Parts of this file are based on code contributed by Karl * Lehenbauer, Mark Diekhans and Peter da Silva. * * Copyright (c) 1991-1994 The Regents of the University of California. * Copyright (c) 1994 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #ifndef lint static char sccsid[] = "@(#) tclUnixUtil.c 1.55 95/03/29 11:24:23"; #endif /* not lint */ #include "tclInt.h" #include "tclPort.h" /* * A linked list of the following structures is used to keep track * of child processes that have been detached but haven't exited * yet, so we can make sure that they're properly "reaped" (officially * waited for) and don't lie around as zombies cluttering the * system. */ typedef struct Detached { int pid; /* Id of process that's been detached * but isn't known to have exited. */ struct Detached *nextPtr; /* Next in list of all detached * processes. */ } Detached; static Detached *detList = NULL; /* List of all detached proceses. */ /* * The following variables are used to keep track of all the open files * in the process. These files can be shared across interpreters, so the * information can't be put in the Interp structure. */ int tclNumFiles = 0; /* Number of entries in tclOpenFiles below. * 0 means array hasn't been created yet. */ OpenFile **tclOpenFiles; /* Pointer to malloc-ed array of pointers * to information about open files. Entry * N corresponds to the file with fileno N. * If an entry is NULL then the corresponding * file isn't open. If tclOpenFiles is NULL * it means no files have been used, so even * stdin/stdout/stderr entries haven't been * setup yet. */ /* * Declarations for local procedures defined in this file: */ static int FileForRedirect _ANSI_ARGS_((Tcl_Interp *interp, char *spec, int atOk, char *arg, int flags, char *nextArg, int *skipPtr, int *closePtr)); static void MakeFileTable _ANSI_ARGS_((Interp *iPtr, int index)); static void RestoreSignals _ANSI_ARGS_((void)); /* *---------------------------------------------------------------------- * * Tcl_EvalFile -- * * Read in a file and process the entire file as one gigantic * Tcl command. * * Results: * A standard Tcl result, which is either the result of executing * the file or an error indicating why the file couldn't be read. * * Side effects: * Depends on the commands in the file. * *---------------------------------------------------------------------- */ int Tcl_EvalFile(interp, fileName) Tcl_Interp *interp; /* Interpreter in which to process file. */ char *fileName; /* Name of file to process. Tilde-substitution * will be performed on this name. */ { int fileId, result; struct stat statBuf; char *cmdBuffer, *oldScriptFile; Interp *iPtr = (Interp *) interp; Tcl_DString buffer; Tcl_ResetResult(interp); oldScriptFile = iPtr->scriptFile; iPtr->scriptFile = fileName; fileName = Tcl_TildeSubst(interp, fileName, &buffer); if (fileName == NULL) { goto error; } fileId = open(fileName, O_RDONLY, 0); if (fileId < 0) { Tcl_AppendResult(interp, "couldn't read file \"", fileName, "\": ", Tcl_PosixError(interp), (char *) NULL); goto error; } if (fstat(fileId, &statBuf) == -1) { Tcl_AppendResult(interp, "couldn't stat file \"", fileName, "\": ", Tcl_PosixError(interp), (char *) NULL); close(fileId); goto error; } cmdBuffer = (char *) ckalloc((unsigned) statBuf.st_size+1); if (read(fileId, cmdBuffer, (size_t) statBuf.st_size) != statBuf.st_size) { Tcl_AppendResult(interp, "error in reading file \"", fileName, "\": ", Tcl_PosixError(interp), (char *) NULL); close(fileId); ckfree(cmdBuffer); goto error; } if (close(fileId) != 0) { Tcl_AppendResult(interp, "error closing file \"", fileName, "\": ", Tcl_PosixError(interp), (char *) NULL); ckfree(cmdBuffer); goto error; } cmdBuffer[statBuf.st_size] = 0; result = Tcl_Eval(interp, cmdBuffer); if (result == TCL_RETURN) { result = TclUpdateReturnInfo(iPtr); } else if (result == TCL_ERROR) { char msg[200]; /* * Record information telling where the error occurred. */ sprintf(msg, "\n (file \"%.150s\" line %d)", fileName, interp->errorLine); Tcl_AddErrorInfo(interp, msg); } ckfree(cmdBuffer); iPtr->scriptFile = oldScriptFile; Tcl_DStringFree(&buffer); return result; error: iPtr->scriptFile = oldScriptFile; Tcl_DStringFree(&buffer); return TCL_ERROR; } /* *---------------------------------------------------------------------- * * Tcl_DetachPids -- * * This procedure is called to indicate that one or more child * processes have been placed in background and will never be * waited for; they should eventually be reaped by * Tcl_ReapDetachedProcs. * * Results: * None. * * Side effects: * None. * *---------------------------------------------------------------------- */ void Tcl_DetachPids(numPids, pidPtr) int numPids; /* Number of pids to detach: gives size * of array pointed to by pidPtr. */ int *pidPtr; /* Array of pids to detach. */ { register Detached *detPtr; int i; for (i = 0; i < numPids; i++) { detPtr = (Detached *) ckalloc(sizeof(Detached)); detPtr->pid = pidPtr[i]; detPtr->nextPtr = detList; detList = detPtr; } } /* *---------------------------------------------------------------------- * * Tcl_ReapDetachedProcs -- * * This procedure checks to see if any detached processes have * exited and, if so, it "reaps" them by officially waiting on * them. It should be called "occasionally" to make sure that * all detached processes are eventually reaped. * * Results: * None. * * Side effects: * Processes are waited on, so that they can be reaped by the * system. * *---------------------------------------------------------------------- */ void Tcl_ReapDetachedProcs() { register Detached *detPtr; Detached *nextPtr, *prevPtr; int status, result; for (detPtr = detList, prevPtr = NULL; detPtr != NULL; ) { result = waitpid(detPtr->pid, &status, WNOHANG); if ((result == 0) || ((result == -1) && (errno != ECHILD))) { prevPtr = detPtr; detPtr = detPtr->nextPtr; continue; } nextPtr = detPtr->nextPtr; if (prevPtr == NULL) { detList = detPtr->nextPtr; } else { prevPtr->nextPtr = detPtr->nextPtr; } ckfree((char *) detPtr); detPtr = nextPtr; } } /* *---------------------------------------------------------------------- * * Tcl_CreatePipeline -- * * Given an argc/argv array, instantiate a pipeline of processes * as described by the argv. * * Results: * The return value is a count of the number of new processes * created, or -1 if an error occurred while creating the pipeline. * *pidArrayPtr is filled in with the address of a dynamically * allocated array giving the ids of all of the processes. It * is up to the caller to free this array when it isn't needed * anymore. If inPipePtr is non-NULL, *inPipePtr is filled in * with the file id for the input pipe for the pipeline (if any): * the caller must eventually close this file. If outPipePtr * isn't NULL, then *outPipePtr is filled in with the file id * for the output pipe from the pipeline: the caller must close * this file. If errFilePtr isn't NULL, then *errFilePtr is filled * with a file id that may be used to read error output after the * pipeline completes. * * Side effects: * Processes and pipes are created. * *---------------------------------------------------------------------- */ int Tcl_CreatePipeline(interp, argc, argv, pidArrayPtr, inPipePtr, outPipePtr, errFilePtr) Tcl_Interp *interp; /* Interpreter to use for error reporting. */ int argc; /* Number of entries in argv. */ char **argv; /* Array of strings describing commands in * pipeline plus I/O redirection with <, * <<, >, etc. Argv[argc] must be NULL. */ int **pidArrayPtr; /* Word at *pidArrayPtr gets filled in with * address of array of pids for processes * in pipeline (first pid is first process * in pipeline). */ int *inPipePtr; /* If non-NULL, input to the pipeline comes * from a pipe (unless overridden by * redirection in the command). The file * id with which to write to this pipe is * stored at *inPipePtr. -1 means command * specified its own input source. */ int *outPipePtr; /* If non-NULL, output to the pipeline goes * to a pipe, unless overriden by redirection * in the command. The file id with which to * read frome this pipe is stored at * *outPipePtr. -1 means command specified * its own output sink. */ int *errFilePtr; /* If non-NULL, all stderr output from the * pipeline will go to a temporary file * created here, and a descriptor to read * the file will be left at *errFilePtr. * The file will be removed already, so * closing this descriptor will be the end * of the file. If this is NULL, then * all stderr output goes to our stderr. * If the pipeline specifies redirection * then the fill will still be created * but it will never get any data. */ { int *pidPtr = NULL; /* Points to malloc-ed array holding all * the pids of child processes. */ int numPids = 0; /* Actual number of processes that exist * at *pidPtr right now. */ int cmdCount; /* Count of number of distinct commands * found in argc/argv. */ char *input = NULL; /* If non-null, then this points to a * string containing input data (specified * via <<) to be piped to the first process * in the pipeline. */ int inputId = -1; /* If >= 0, gives file id to use as input for * first process in pipeline (specified via * < or <@). */ int closeInput = 0; /* If non-zero, then must close inputId * when cleaning up (zero means the file needs * to stay open for some other reason). */ int outputId = -1; /* Writable file id for output from last * command in pipeline (could be file or pipe). * -1 means use stdout. */ int closeOutput = 0; /* Non-zero means must close outputId when * cleaning up (similar to closeInput). */ int errorId = -1; /* Writable file id for error output from * all commands in pipeline. -1 means use * stderr. */ int closeError = 0; /* Non-zero means must close errorId when * cleaning up. */ int pipeIds[2]; /* File ids for pipe that's being created. */ int firstArg, lastArg; /* Indexes of first and last arguments in * current command. */ int skip; /* Number of arguments to skip (because they * specify redirection). */ int maxFd; /* Highest known file descriptor (used to * close off extraneous file descriptors in * child process). */ int errPipeIds[2]; /* Used for communication between parent and * child processes. If child encounters * error during startup it returns error * message via pipe. If child starts up * OK, it closes pipe without anything in * it. */ int lastBar; char *execName; int i, j, pid, count; char *p; Tcl_DString buffer; char errSpace[200]; if (inPipePtr != NULL) { *inPipePtr = -1; } if (outPipePtr != NULL) { *outPipePtr = -1; } if (errFilePtr != NULL) { *errFilePtr = -1; } pipeIds[0] = pipeIds[1] = -1; errPipeIds[0] = errPipeIds[1] = -1; /* * First, scan through all the arguments to figure out the structure * of the pipeline. Process all of the input and output redirection * arguments and remove them from the argument list in the pipeline. * Count the number of distinct processes (it's the number of "|" * arguments plus one) but don't remove the "|" arguments. */ cmdCount = 1; lastBar = -1; for (i = 0; i < argc; i++) { if ((argv[i][0] == '|') && (((argv[i][1] == 0)) || ((argv[i][1] == '&') && (argv[i][2] == 0)))) { if ((i == (lastBar+1)) || (i == (argc-1))) { interp->result = "illegal use of | or |& in command"; return -1; } lastBar = i; cmdCount++; continue; } else if (argv[i][0] == '<') { if ((inputId >= 0) && closeInput) { close(inputId); } inputId = -1; skip = 1; if (argv[i][1] == '<') { input = argv[i]+2; if (*input == 0) { input = argv[i+1]; if (input == 0) { Tcl_AppendResult(interp, "can't specify \"", argv[i], "\" as last word in command", (char *) NULL); goto error; } skip = 2; } } else { input = 0; inputId = FileForRedirect(interp, argv[i]+1, 1, argv[i], O_RDONLY, argv[i+1], &skip, &closeInput); if (inputId < 0) { goto error; } } } else if (argv[i][0] == '>') { int append, useForStdErr, useForStdOut, mustClose, fd, atOk, flags; skip = atOk = 1; append = useForStdErr = 0; useForStdOut = 1; if (argv[i][1] == '>') { p = argv[i] + 2; append = 1; atOk = 0; flags = O_WRONLY|O_CREAT; } else { p = argv[i] + 1; flags = O_WRONLY|O_CREAT|O_TRUNC; } if (*p == '&') { useForStdErr = 1; p++; } fd = FileForRedirect(interp, p, atOk, argv[i], flags, argv[i+1], &skip, &mustClose); if (fd < 0) { goto error; } if (append) { lseek(fd, 0L, 2); } /* * Got the file descriptor. Now use it for standard output, * standard error, or both, depending on the redirection. */ if (useForStdOut) { if ((outputId > 0) && closeOutput) { close(outputId); } outputId = fd; closeOutput = mustClose; } if (useForStdErr) { if ((errorId > 0) && closeError) { close(errorId); } errorId = fd; closeError = (useForStdOut) ? 0 : mustClose; } } else if ((argv[i][0] == '2') && (argv[i][1] == '>')) { int append, atOk, flags; if ((errorId > 0) && closeError) { close(errorId); } skip = 1; p = argv[i] + 2; if (*p == '>') { p++; append = 1; atOk = 0; flags = O_WRONLY|O_CREAT; } else { append = 0; atOk = 1; flags = O_WRONLY|O_CREAT|O_TRUNC; } errorId = FileForRedirect(interp, p, atOk, argv[i], flags, argv[i+1], &skip, &closeError); if (errorId < 0) { goto error; } if (append) { lseek(errorId, 0L, 2); } } else { continue; } for (j = i+skip; j < argc; j++) { argv[j-skip] = argv[j]; } argc -= skip; i -= 1; /* Process next arg from same position. */ } if (argc == 0) { interp->result = "didn't specify command to execute"; return -1; } if (inputId < 0) { if (input != NULL) { char inName[L_tmpnam]; int length; /* * The input for the first process is immediate data coming from * Tcl. Create a temporary file for it and put the data into the * file. */ tmpnam(inName); inputId = open(inName, O_RDWR|O_CREAT|O_TRUNC, 0600); closeInput = 1; if (inputId < 0) { Tcl_AppendResult(interp, "couldn't create input file \"", inName, "\" for command: ", Tcl_PosixError(interp), (char *) NULL); goto error; } length = strlen(input); if (write(inputId, input, (size_t) length) != length) { Tcl_AppendResult(interp, "couldn't write file input for command: ", Tcl_PosixError(interp), (char *) NULL); goto error; } if ((lseek(inputId, 0L, 0) == -1) || (unlink(inName) == -1)) { Tcl_AppendResult(interp, "couldn't reset or remove input file for command: ", Tcl_PosixError(interp), (char *) NULL); goto error; } } else if (inPipePtr != NULL) { /* * The input for the first process in the pipeline is to * come from a pipe that can be written from this end. */ if (pipe(pipeIds) != 0) { Tcl_AppendResult(interp, "couldn't create input pipe for command: ", Tcl_PosixError(interp), (char *) NULL); goto error; } inputId = pipeIds[0]; closeInput = 1; *inPipePtr = pipeIds[1]; pipeIds[0] = pipeIds[1] = -1; } } /* * Set up a pipe to receive output from the pipeline, if no other * output sink has been specified. */ if ((outputId < 0) && (outPipePtr != NULL)) { if (pipe(pipeIds) != 0) { Tcl_AppendResult(interp, "couldn't create output pipe: ", Tcl_PosixError(interp), (char *) NULL); goto error; } outputId = pipeIds[1]; closeOutput = 1; *outPipePtr = pipeIds[0]; pipeIds[0] = pipeIds[1] = -1; } /* * Set up the standard error output sink for the pipeline, if * requested. Use a temporary file which is opened, then deleted. * Could potentially just use pipe, but if it filled up it could * cause the pipeline to deadlock: we'd be waiting for processes * to complete before reading stderr, and processes couldn't complete * because stderr was backed up. */ if (errFilePtr != NULL) { char errName[L_tmpnam]; tmpnam(errName); *errFilePtr = open(errName, O_RDONLY|O_CREAT|O_TRUNC, 0600); if (*errFilePtr < 0) { errFileError: Tcl_AppendResult(interp, "couldn't create error file \"", errName, "\" for command: ", Tcl_PosixError(interp), (char *) NULL); goto error; } if (errorId < 0) { errorId = open(errName, O_WRONLY|O_CREAT|O_TRUNC, 0600); if (errorId < 0) { goto errFileError; } closeError = 1; } if (unlink(errName) == -1) { Tcl_AppendResult(interp, "couldn't remove error file for command: ", Tcl_PosixError(interp), (char *) NULL); goto error; } } /* * Find the largest file descriptor used so far, so that we can * clean up all the extraneous file descriptors in the child * processes we create. */ maxFd = inputId; if (outputId > maxFd) { maxFd = outputId; } if (errorId > maxFd) { maxFd = errorId; } if ((inPipePtr != NULL) && (*inPipePtr > maxFd)) { maxFd = *inPipePtr; } if ((outPipePtr != NULL) && (*outPipePtr > maxFd)) { maxFd = *outPipePtr; } if ((errFilePtr != NULL) && (*errFilePtr > maxFd)) { maxFd = *errFilePtr; } /* * Scan through the argc array, forking off a process for each * group of arguments between "|" arguments. */ pidPtr = (int *) ckalloc((unsigned) (cmdCount * sizeof(int))); for (i = 0; i < numPids; i++) { pidPtr[i] = -1; } Tcl_ReapDetachedProcs(); for (firstArg = 0; firstArg < argc; numPids++, firstArg = lastArg+1) { int joinThisError; int curOutputId; joinThisError = 0; for (lastArg = firstArg; lastArg < argc; lastArg++) { if (argv[lastArg][0] == '|') { if (argv[lastArg][1] == 0) { break; } if ((argv[lastArg][1] == '&') && (argv[lastArg][2] == 0)) { joinThisError = 1; break; } } } argv[lastArg] = NULL; if (lastArg == argc) { curOutputId = outputId; } else { if (pipe(pipeIds) != 0) { Tcl_AppendResult(interp, "couldn't create pipe: ", Tcl_PosixError(interp), (char *) NULL); goto error; } curOutputId = pipeIds[1]; if (pipeIds[0] > maxFd) { maxFd = pipeIds[0]; } if (pipeIds[1] > maxFd) { maxFd = pipeIds[1]; } } /* * Create a pipe that the child can use to return error * information if anything goes wrong. Set the close-on-exec * flag for the write end of the pipe so that it will be * closed automatically if the child succesfully execs the * new subprocess. */ if (pipe(errPipeIds) != 0) { Tcl_AppendResult(interp, "couldn't create pipe: ", Tcl_PosixError(interp), (char *) NULL); goto error; } if (errPipeIds[0] > maxFd) { maxFd = errPipeIds[0]; } if (errPipeIds[1] > maxFd) { maxFd = errPipeIds[1]; } if (fcntl(errPipeIds[1], F_SETFD, FD_CLOEXEC) != 0) { Tcl_AppendResult(interp, "couldn't set close on exec for pipe: ", Tcl_PosixError(interp), (char *) NULL); goto error; } execName = Tcl_TildeSubst(interp, argv[firstArg], &buffer); pid = vfork(); if (pid == 0) { if (((inputId != -1) && (dup2(inputId, 0) == -1)) || ((curOutputId != -1) && (dup2(curOutputId, 1) == -1)) || (joinThisError && (dup2(1, 2) == -1)) || (!joinThisError && (errorId != -1) && (dup2(errorId, 2) == -1))) { sprintf(errSpace, "%dforked process couldn't set up input/output: ", errno); write(errPipeIds[1], errSpace, (size_t) strlen(errSpace)); _exit(1); } for (i = 3; i <= maxFd; i++) { if (i != errPipeIds[1]) { close(i); } } RestoreSignals(); execvp(execName, &argv[firstArg]); sprintf(errSpace, "%dcouldn't execute \"%.150s\": ", errno, argv[firstArg]); write(errPipeIds[1], errSpace, (size_t) strlen(errSpace)); _exit(1); } Tcl_DStringFree(&buffer); if (pid == -1) { Tcl_AppendResult(interp, "couldn't fork child process: ", Tcl_PosixError(interp), (char *) NULL); goto error; } /* * Read back from the error pipe to see if the child startup * up OK. The info in the pipe (if any) consists of a decimal * errno value followed by an error message. */ close(errPipeIds[1]); errPipeIds[1] = -1; count = read(errPipeIds[0], errSpace, (size_t) (sizeof(errSpace) - 1)); if (count > 0) { char *end; errSpace[count] = 0; errno = strtol(errSpace, &end, 10); Tcl_AppendResult(interp, end, Tcl_PosixError(interp), (char *) NULL); goto error; } close(errPipeIds[0]); errPipeIds[0] = -1; pidPtr[numPids] = pid; /* * Close off our copies of file descriptors that were set up for * this child, then set up the input for the next child. */ if ((inputId != -1) && closeInput) { close(inputId); } if ((curOutputId != -1) && (curOutputId != outputId)) { close(curOutputId); } inputId = pipeIds[0]; closeInput = 1; pipeIds[0] = pipeIds[1] = -1; } *pidArrayPtr = pidPtr; /* * All done. Cleanup open files lying around and then return. */ cleanup: if ((inputId != -1) && closeInput) { close(inputId); } if ((outputId != -1) && closeOutput) { close(outputId); } if ((errorId != -1) && closeError) { close(errorId); } return numPids; /* * An error occurred. There could have been extra files open, such * as pipes between children. Clean them all up. Detach any child * processes that have been created. */ error: if ((inPipePtr != NULL) && (*inPipePtr != -1)) { close(*inPipePtr); *inPipePtr = -1; } if ((outPipePtr != NULL) && (*outPipePtr != -1)) { close(*outPipePtr); *outPipePtr = -1; } if ((errFilePtr != NULL) && (*errFilePtr != -1)) { close(*errFilePtr); *errFilePtr = -1; } if (pipeIds[0] != -1) { close(pipeIds[0]); } if (pipeIds[1] != -1) { close(pipeIds[1]); } if (errPipeIds[0] != -1) { close(errPipeIds[0]); } if (errPipeIds[1] != -1) { close(errPipeIds[1]); } if (pidPtr != NULL) { for (i = 0; i < numPids; i++) { if (pidPtr[i] != -1) { Tcl_DetachPids(1, &pidPtr[i]); } } ckfree((char *) pidPtr); } numPids = -1; goto cleanup; } /* *---------------------------------------------------------------------- * * FileForRedirect -- * * This procedure does much of the work of parsing redirection * operators. It handles "@" if specified and allowed, and a file * name, and opens the file if necessary. * * Results: * The return value is the descriptor number for the file. If an * error occurs then -1 is returned and an error message is left * in interp->result. Several arguments are side-effected; see * the argument list below for details. * * Side effects: * None. * *---------------------------------------------------------------------- */ static int FileForRedirect(interp, spec, atOk, arg, flags, nextArg, skipPtr, closePtr) Tcl_Interp *interp; /* Intepreter to use for error * reporting. */ register char *spec; /* Points to character just after * redirection character. */ int atOk; /* Non-zero means '@' notation is * OK, zero means it isn't. */ char *arg; /* Pointer to entire argument * containing spec: used for error * reporting. */ int flags; /* Flags to use for opening file. */ char *nextArg; /* Next argument in argc/argv * array, if needed for file name. * May be NULL. */ int *skipPtr; /* This value is incremented if * nextArg is used for redirection * spec. */ int *closePtr; /* This value is set to 1 if the file * that's returned must be closed, 0 * if it was specified with "@" so * it must be left open. */ { int writing = (flags & O_WRONLY); FILE *f; int fd; if (atOk && (*spec == '@')) { spec++; if (*spec == 0) { spec = nextArg; if (spec == NULL) { goto badLastArg; } *skipPtr += 1; } if (Tcl_GetOpenFile(interp, spec, writing, 1, &f) != TCL_OK) { return -1; } *closePtr = 0; fd = fileno(f); if (writing) { /* * Be sure to flush output to the file, so that anything * written by the child appears after stuff we've already * written. */ fflush(f); } } else { if (*spec == 0) { spec = nextArg; if (spec == NULL) { goto badLastArg; } *skipPtr += 1; } fd = open(spec, flags, 0666); if (fd < 0) { Tcl_AppendResult(interp, "couldn't ", (writing) ? "write" : "read", " file \"", spec, "\": ", Tcl_PosixError(interp), (char *) NULL); return -1; } *closePtr = 1; } return fd; badLastArg: Tcl_AppendResult(interp, "can't specify \"", arg, "\" as last word in command", (char *) NULL); return -1; } /* *---------------------------------------------------------------------- * * RestoreSignals -- * * This procedure is invoked in a forked child process just before * exec-ing a new program to restore all signals to their default * settings. * * Results: * None. * * Side effects: * Signal settings get changed. * *---------------------------------------------------------------------- */ static void RestoreSignals() { #ifdef SIGABRT signal(SIGABRT, SIG_DFL); #endif #ifdef SIGALRM signal(SIGALRM, SIG_DFL); #endif #ifdef SIGFPE signal(SIGFPE, SIG_DFL); #endif #ifdef SIGHUP signal(SIGHUP, SIG_DFL); #endif #ifdef SIGILL signal(SIGILL, SIG_DFL); #endif #ifdef SIGINT signal(SIGINT, SIG_DFL); #endif #ifdef SIGPIPE signal(SIGPIPE, SIG_DFL); #endif #ifdef SIGQUIT signal(SIGQUIT, SIG_DFL); #endif #ifdef SIGSEGV signal(SIGSEGV, SIG_DFL); #endif #ifdef SIGTERM signal(SIGTERM, SIG_DFL); #endif #ifdef SIGUSR1 signal(SIGUSR1, SIG_DFL); #endif #ifdef SIGUSR2 signal(SIGUSR2, SIG_DFL); #endif #ifdef SIGCHLD signal(SIGCHLD, SIG_DFL); #endif #ifdef SIGCONT signal(SIGCONT, SIG_DFL); #endif #ifdef SIGTSTP signal(SIGTSTP, SIG_DFL); #endif #ifdef SIGTTIN signal(SIGTTIN, SIG_DFL); #endif #ifdef SIGTTOU signal(SIGTTOU, SIG_DFL); #endif } /* *---------------------------------------------------------------------- * * Tcl_PosixError -- * * This procedure is typically called after UNIX kernel calls * return errors. It stores machine-readable information about * the error in $errorCode returns an information string for * the caller's use. * * Results: * The return value is a human-readable string describing the * error, as returned by strerror. * * Side effects: * The global variable $errorCode is reset. * *---------------------------------------------------------------------- */ char * Tcl_PosixError(interp) Tcl_Interp *interp; /* Interpreter whose $errorCode variable * is to be changed. */ { char *id, *msg; id = Tcl_ErrnoId(); msg = strerror(errno); Tcl_SetErrorCode(interp, "POSIX", id, msg, (char *) NULL); return msg; } /* *---------------------------------------------------------------------- * * MakeFileTable -- * * Create or enlarge the file table for the interpreter, so that * there is room for a given index. * * Results: * None. * * Side effects: * The file table for iPtr will be created if it doesn't exist * (and entries will be added for stdin, stdout, and stderr). * If it already exists, then it will be grown if necessary. * *---------------------------------------------------------------------- */ /* ARGSUSED */ static void MakeFileTable(iPtr, index) Interp *iPtr; /* Interpreter whose table of files is * to be manipulated. */ int index; /* Make sure table is large enough to * hold at least this index. */ { /* * If the table doesn't even exist, then create it and initialize * entries for standard files. */ if (tclNumFiles == 0) { OpenFile *oFilePtr; int i; if (index < 2) { tclNumFiles = 3; } else { tclNumFiles = index+1; } tclOpenFiles = (OpenFile **) ckalloc((unsigned) ((tclNumFiles)*sizeof(OpenFile *))); for (i = tclNumFiles-1; i >= 0; i--) { tclOpenFiles[i] = NULL; } oFilePtr = (OpenFile *) ckalloc(sizeof(OpenFile)); oFilePtr->f = stdin; oFilePtr->f2 = NULL; oFilePtr->permissions = TCL_FILE_READABLE; oFilePtr->numPids = 0; oFilePtr->pidPtr = NULL; oFilePtr->errorId = -1; tclOpenFiles[0] = oFilePtr; oFilePtr = (OpenFile *) ckalloc(sizeof(OpenFile)); oFilePtr->f = stdout; oFilePtr->f2 = NULL; oFilePtr->permissions = TCL_FILE_WRITABLE; oFilePtr->numPids = 0; oFilePtr->pidPtr = NULL; oFilePtr->errorId = -1; tclOpenFiles[1] = oFilePtr; oFilePtr = (OpenFile *) ckalloc(sizeof(OpenFile)); oFilePtr->f = stderr; oFilePtr->f2 = NULL; oFilePtr->permissions = TCL_FILE_WRITABLE; oFilePtr->numPids = 0; oFilePtr->pidPtr = NULL; oFilePtr->errorId = -1; tclOpenFiles[2] = oFilePtr; } else if (index >= tclNumFiles) { int newSize; OpenFile **newPtrArray; int i; newSize = index+1; newPtrArray = (OpenFile **) ckalloc((unsigned) ((newSize)*sizeof(OpenFile *))); memcpy((VOID *) newPtrArray, (VOID *) tclOpenFiles, tclNumFiles*sizeof(OpenFile *)); for (i = tclNumFiles; i < newSize; i++) { newPtrArray[i] = NULL; } ckfree((char *) tclOpenFiles); tclNumFiles = newSize; tclOpenFiles = newPtrArray; } } /* *---------------------------------------------------------------------- * * Tcl_EnterFile -- * * This procedure is used to enter an already-open file into the * file table for an interpreter so that the file can be read * and written with Tcl commands. * * Results: * There is no return value, but interp->result is set to * hold Tcl's id for the open file, such as "file4". * * Side effects: * "File" is added to the files accessible from interp. * *---------------------------------------------------------------------- */ void Tcl_EnterFile(interp, file, permissions) Tcl_Interp *interp; /* Interpreter in which to make file * available. */ FILE *file; /* File to make available in interp. */ int permissions; /* Ops that may be done on file: OR-ed * combinination of TCL_FILE_READABLE and * TCL_FILE_WRITABLE. */ { Interp *iPtr = (Interp *) interp; int fd; register OpenFile *oFilePtr; fd = fileno(file); if (fd >= tclNumFiles) { MakeFileTable(iPtr, fd); } oFilePtr = tclOpenFiles[fd]; /* * It's possible that there already appears to be a file open in * the slot. This could happen, for example, if the application * closes a file behind our back so that we don't have a chance * to clean up. This is probably a bad idea, but if it happens * just discard the information in the old record (hopefully the * application is smart enough to have really cleaned everything * up right). */ if (oFilePtr == NULL) { oFilePtr = (OpenFile *) ckalloc(sizeof(OpenFile)); tclOpenFiles[fd] = oFilePtr; } oFilePtr->f = file; oFilePtr->f2 = NULL; oFilePtr->permissions = permissions; oFilePtr->numPids = 0; oFilePtr->pidPtr = NULL; oFilePtr->errorId = -1; if (fd <= 2) { if (fd == 0) { interp->result = "stdin"; } else if (fd == 1) { interp->result = "stdout"; } else { interp->result = "stderr"; } } else { sprintf(interp->result, "file%d", fd); } } /* *---------------------------------------------------------------------- * * Tcl_GetOpenFile -- * * Given a string identifier for an open file, find the corresponding * open file structure, if there is one. * * Results: * A standard Tcl return value. If the open file is successfully * located and meets any usage check requested by checkUsage, TCL_OK * is returned and *filePtr is modified to hold a pointer to its * FILE structure. If an error occurs then TCL_ERROR is returned * and interp->result contains an error message. * * Side effects: * None. * *---------------------------------------------------------------------- */ int Tcl_GetOpenFile(interp, string, forWriting, checkUsage, filePtr) Tcl_Interp *interp; /* Interpreter in which to find file. */ char *string; /* String that identifies file. */ int forWriting; /* 1 means the file is going to be used * for writing, 0 means for reading. */ int checkUsage; /* 1 means verify that the file was opened * in a mode that allows the access specified * by "forWriting". */ FILE **filePtr; /* Store pointer to FILE structure here. */ { OpenFile *oFilePtr; int fd = 0; /* Initial value needed only to stop compiler * warnings. */ Interp *iPtr = (Interp *) interp; if ((string[0] == 'f') && (string[1] == 'i') && (string[2] == 'l') & (string[3] == 'e')) { char *end; fd = strtoul(string+4, &end, 10); if ((end == string+4) || (*end != 0)) { goto badId; } } else if ((string[0] == 's') && (string[1] == 't') && (string[2] == 'd')) { if (strcmp(string+3, "in") == 0) { fd = 0; } else if (strcmp(string+3, "out") == 0) { fd = 1; } else if (strcmp(string+3, "err") == 0) { fd = 2; } else { goto badId; } } else { badId: Tcl_AppendResult(interp, "bad file identifier \"", string, "\"", (char *) NULL); return TCL_ERROR; } if (fd >= tclNumFiles) { if ((tclNumFiles == 0) && (fd <= 2)) { MakeFileTable(iPtr, fd); } else { notOpen: Tcl_AppendResult(interp, "file \"", string, "\" isn't open", (char *) NULL); return TCL_ERROR; } } oFilePtr = tclOpenFiles[fd]; if (oFilePtr == NULL) { goto notOpen; } if (forWriting) { if (checkUsage && !(oFilePtr->permissions & TCL_FILE_WRITABLE)) { Tcl_AppendResult(interp, "\"", string, "\" wasn't opened for writing", (char *) NULL); return TCL_ERROR; } if (oFilePtr->f2 != NULL) { *filePtr = oFilePtr->f2; } else { *filePtr = oFilePtr->f; } } else { if (checkUsage && !(oFilePtr->permissions & TCL_FILE_READABLE)) { Tcl_AppendResult(interp, "\"", string, "\" wasn't opened for reading", (char *) NULL); return TCL_ERROR; } *filePtr = oFilePtr->f; } return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_FilePermissions -- * * Given a FILE * pointer, return the read/write permissions * associated with the open file. * * Results: * If file is currently open, the return value is an OR-ed * combination of TCL_FILE_READABLE and TCL_FILE_WRITABLE, * which indicates the operations permitted on the open file. * If the file isn't open then the return value is -1. * * Side effects: * None. * *---------------------------------------------------------------------- */ int Tcl_FilePermissions(file) FILE *file; /* File for which permissions are wanted. */ { register OpenFile *oFilePtr; int i, fd; /* * First try the entry in tclOpenFiles given by the file descriptor * for the file. If that doesn't match then search all the entries * in tclOpenFiles. */ if (file != NULL) { fd = fileno(file); if (fd < tclNumFiles) { oFilePtr = tclOpenFiles[fd]; if ((oFilePtr != NULL) && (oFilePtr->f == file)) { return oFilePtr->permissions; } } } for (i = 0; i < tclNumFiles; i++) { oFilePtr = tclOpenFiles[i]; if (oFilePtr == NULL) { continue; } if ((oFilePtr->f == file) || (oFilePtr->f2 == file)) { return oFilePtr->permissions; } } return -1; } /* *---------------------------------------------------------------------- * * TclOpen, etc. -- * * Below are a bunch of procedures that are used by Tcl instead * of system calls. Each of the procedures executes the * corresponding system call and retries automatically * if the system call was interrupted by a signal. * * Results: * Whatever the system call would normally return. * * Side effects: * Whatever the system call would normally do. * * NOTE: * This should be the last page of this file, since it undefines * the macros that redirect read etc. to the procedures below. * *---------------------------------------------------------------------- */ #undef open int TclOpen(path, oflag, mode) char *path; int oflag; int mode; { int result; while (1) { result = open(path, oflag, mode); if ((result != -1) || (errno != EINTR)) { return result; } } } #undef read int TclRead(fd, buf, numBytes) int fd; VOID *buf; size_t numBytes; { int result; while (1) { result = read(fd, buf, (size_t) numBytes); if ((result != -1) || (errno != EINTR)) { return result; } } } #undef waitpid extern pid_t waitpid _ANSI_ARGS_((pid_t pid, int *stat_loc, int options)); /* * Note: the #ifdef below is needed to avoid compiler errors on systems * that have ANSI compilers and also define pid_t to be short. The * problem is a complex one having to do with argument type promotion. */ #ifdef _USING_PROTOTYPES_ int TclWaitpid _ANSI_ARGS_((pid_t pid, int *statPtr, int options)) #else int TclWaitpid(pid, statPtr, options) pid_t pid; int *statPtr; int options; #endif /* _USING_PROTOTYPES_ */ { int result; while (1) { result = waitpid(pid, statPtr, options); if ((result != -1) || (errno != EINTR)) { return result; } } } #undef write int TclWrite(fd, buf, numBytes) int fd; VOID *buf; size_t numBytes; { int result; while (1) { result = write(fd, buf, (size_t) numBytes); if ((result != -1) || (errno != EINTR)) { return result; } } } y exists, then it will be grown if necessary. * *---------------------------------------------------------------------- */ /* ARGSUSED */ static void MakeFileTable(iPtr, index) Interp *iPtr; /* Interpreter whose table of files is * to be manipulated. */ int index; /* Make sure table is large enough to * hold at least this index. */ { /* * If the table doesn't even exist, thetcl7.4b4/tclTest.c010044400630510000012000000650510576563465500146440ustar00ousterstaff00002300000001/* * tclTest.c -- * * This file contains C command procedures for a bunch of additional * Tcl commands that are used for testing out Tcl's C interfaces. * These commands are not normally included in Tcl applications; * they're only used for testing. * * Copyright (c) 1993-1994 The Regents of the University of California. * Copyright (c) 1994-1995 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #ifndef lint static char sccsid[] = "@(#) tclTest.c 1.25 95/06/08 10:55:56"; #endif /* not lint */ #include "tclInt.h" #include "tclPort.h" /* * The following variable is a special hack that is needed in order for * Sun shared libraries to be used for Tcl. */ extern int matherr(); int *tclDummyMathPtr = (int *) matherr; /* * Dynamic string shared by TestdcallCmd and DelCallbackProc; used * to collect the results of the various deletion callbacks. */ static Tcl_DString delString; static Tcl_Interp *delInterp; /* * One of the following structures exists for each asynchronous * handler created by the "testasync" command". */ typedef struct TestAsyncHandler { int id; /* Identifier for this handler. */ Tcl_AsyncHandler handler; /* Tcl's token for the handler. */ char *command; /* Command to invoke when the * handler is invoked. */ struct TestAsyncHandler *nextPtr; /* Next is list of handlers. */ } TestAsyncHandler; static TestAsyncHandler *firstHandler = NULL; /* * The variable below is a token for an asynchronous handler for * interrupt signals, or NULL if none exists. */ static Tcl_AsyncHandler intHandler; /* * The dynamic string below is used by the "testdstring" command * to test the dynamic string facilities. */ static Tcl_DString dstring; /* * Forward declarations for procedures defined later in this file: */ static int AsyncHandlerProc _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int code)); static void CmdDelProc1 _ANSI_ARGS_((ClientData clientData)); static void CmdDelProc2 _ANSI_ARGS_((ClientData clientData)); static int CmdProc1 _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); static int CmdProc2 _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); static void DelCallbackProc _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp)); static int IntHandlerProc _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int code)); static void IntProc(); static void SpecialFree _ANSI_ARGS_((char *blockPtr)); static int TestasyncCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, char **argv)); static int TestcmdinfoCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, char **argv)); static int TestcmdtokenCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, char **argv)); static int TestdcallCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, char **argv)); static int TestdstringCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, char **argv)); static int TestlinkCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, char **argv)); static int TestMathFunc _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, Tcl_Value *args, Tcl_Value *resultPtr)); static int TestupvarCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, char **argv)); /* *---------------------------------------------------------------------- * * main -- * * This is the main program for the application. * * Results: * None: Tcl_Main never returns here, so this procedure never * returns either. * * Side effects: * Whatever the application does. * *---------------------------------------------------------------------- */ int main(argc, argv) int argc; /* Number of command-line arguments. */ char **argv; /* Values of command-line arguments. */ { Tcl_Main(argc, argv, Tcl_AppInit); return 0; /* Needed only to prevent compiler warning. */ } /* *---------------------------------------------------------------------- * * Tcl_AppInit -- * * This procedure performs application-specific initialization. * Most applications, especially those that incorporate additional * packages, will have their own version of this procedure. * * Results: * Returns a standard Tcl completion code, and leaves an error * message in interp->result if an error occurs. * * Side effects: * Depends on the startup script. * *---------------------------------------------------------------------- */ int Tcl_AppInit(interp) Tcl_Interp *interp; /* Interpreter for application. */ { /* * Call the init procedures for included packages. Each call should * look like this: * * if (Mod_Init(interp) == TCL_ERROR) { * return TCL_ERROR; * } * * where "Mod" is the name of the module. */ if (Tcl_Init(interp) == TCL_ERROR) { return TCL_ERROR; } /* * Create additional commands and math functions for testing Tcl. */ Tcl_CreateCommand(interp, "testasync", TestasyncCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateCommand(interp, "testcmdtoken", TestcmdtokenCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateCommand(interp, "testcmdinfo", TestcmdinfoCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateCommand(interp, "testdcall", TestdcallCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_DStringInit(&dstring); Tcl_CreateCommand(interp, "testdstring", TestdstringCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateCommand(interp, "testlink", TestlinkCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateCommand(interp, "testupvar", TestupvarCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateMathFunc(interp, "T1", 0, (Tcl_ValueType *) NULL, TestMathFunc, (ClientData) 123); Tcl_CreateMathFunc(interp, "T2", 0, (Tcl_ValueType *) NULL, TestMathFunc, (ClientData) 345); /* * Specify a user-specific startup file to invoke if the application * is run interactively. If this line is deleted then no user-specific * startup file will be run under any conditions. */ tcl_RcFileName = "~/.tclshrc"; return TCL_OK; } /* *---------------------------------------------------------------------- * * TestasyncCmd -- * * This procedure implements the "testasync" command. It is used * to test the asynchronous handler facilities of Tcl. * * Results: * A standard Tcl result. * * Side effects: * Creates, deletes, and invokes handlers. * *---------------------------------------------------------------------- */ /* ARGSUSED */ static int TestasyncCmd(dummy, interp, argc, argv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { TestAsyncHandler *asyncPtr, *prevPtr; int id, code; static int nextId = 1; if (argc < 2) { wrongNumArgs: interp->result = "wrong # args"; return TCL_ERROR; } if (strcmp(argv[1], "create") == 0) { if (argc != 3) { goto wrongNumArgs; } asyncPtr = (TestAsyncHandler *) ckalloc(sizeof(TestAsyncHandler)); asyncPtr->id = nextId; nextId++; asyncPtr->handler = Tcl_AsyncCreate(AsyncHandlerProc, (ClientData) asyncPtr); asyncPtr->command = ckalloc((unsigned) (strlen(argv[2]) + 1)); strcpy(asyncPtr->command, argv[2]); asyncPtr->nextPtr = firstHandler; firstHandler = asyncPtr; sprintf(interp->result, "%d", asyncPtr->id); } else if (strcmp(argv[1], "delete") == 0) { if (argc == 2) { while (firstHandler != NULL) { asyncPtr = firstHandler; firstHandler = asyncPtr->nextPtr; Tcl_AsyncDelete(asyncPtr->handler); ckfree(asyncPtr->command); ckfree((char *) asyncPtr); } return TCL_OK; } if (argc != 3) { goto wrongNumArgs; } if (Tcl_GetInt(interp, argv[2], &id) != TCL_OK) { return TCL_ERROR; } for (prevPtr = NULL, asyncPtr = firstHandler; asyncPtr != NULL; prevPtr = asyncPtr, asyncPtr = asyncPtr->nextPtr) { if (asyncPtr->id != id) { continue; } if (prevPtr == NULL) { firstHandler = asyncPtr->nextPtr; } else { prevPtr->nextPtr = asyncPtr->nextPtr; } Tcl_AsyncDelete(asyncPtr->handler); ckfree(asyncPtr->command); ckfree((char *) asyncPtr); break; } } else if (strcmp(argv[1], "int") == 0) { if (argc != 2) { goto wrongNumArgs; } intHandler = Tcl_AsyncCreate(IntHandlerProc, (ClientData) interp); signal(SIGINT, IntProc); } else if (strcmp(argv[1], "mark") == 0) { if (argc != 5) { goto wrongNumArgs; } if ((Tcl_GetInt(interp, argv[2], &id) != TCL_OK) || (Tcl_GetInt(interp, argv[4], &code) != TCL_OK)) { return TCL_ERROR; } for (asyncPtr = firstHandler; asyncPtr != NULL; asyncPtr = asyncPtr->nextPtr) { if (asyncPtr->id == id) { Tcl_AsyncMark(asyncPtr->handler); break; } } Tcl_SetResult(interp, argv[3], TCL_VOLATILE); return code; } else { Tcl_AppendResult(interp, "bad option \"", argv[1], "\": must be create, delete, int, or mark", (char *) NULL); return TCL_ERROR; } return TCL_OK; } static int AsyncHandlerProc(clientData, interp, code) ClientData clientData; /* Pointer to TestAsyncHandler structure. */ Tcl_Interp *interp; /* Interpreter in which command was * executed, or NULL. */ int code; /* Current return code from command. */ { TestAsyncHandler *asyncPtr = (TestAsyncHandler *) clientData; char *listArgv[4]; char string[20], *cmd; sprintf(string, "%d", code); listArgv[0] = asyncPtr->command; listArgv[1] = interp->result; listArgv[2] = string; listArgv[3] = NULL; cmd = Tcl_Merge(3, listArgv); code = Tcl_Eval(interp, cmd); ckfree(cmd); return code; } static void IntProc() { Tcl_AsyncMark(intHandler); } static int IntHandlerProc(clientData, interp, code) ClientData clientData; /* Interpreter in which to invoke command. */ Tcl_Interp *interp; /* Interpreter in which command was * executed, or NULL. */ int code; /* Current return code from command. */ { char *listArgv[4]; char string[20], *cmd; interp = (Tcl_Interp *) clientData; listArgv[0] = Tcl_GetVar(interp, "sigIntCmd", TCL_GLOBAL_ONLY); if (listArgv[0] == NULL) { return code; } listArgv[1] = interp->result; sprintf(string, "%d", code); listArgv[2] = string; listArgv[3] = NULL; cmd = Tcl_Merge(3, listArgv); code = Tcl_Eval(interp, cmd); ckfree(cmd); return code; } /* *---------------------------------------------------------------------- * * TestdcallCmd -- * * This procedure implements the "testdcall" command. It is used * to test Tcl_CallWhenDeleted. * * Results: * A standard Tcl result. * * Side effects: * Creates and deletes interpreters. * *---------------------------------------------------------------------- */ /* ARGSUSED */ static int TestdcallCmd(dummy, interp, argc, argv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { int i, id; delInterp = Tcl_CreateInterp(); Tcl_DStringInit(&delString); for (i = 1; i < argc; i++) { if (Tcl_GetInt(interp, argv[i], &id) != TCL_OK) { return TCL_ERROR; } if (id < 0) { Tcl_DontCallWhenDeleted(delInterp, DelCallbackProc, (ClientData) (-id)); } else { Tcl_CallWhenDeleted(delInterp, DelCallbackProc, (ClientData) id); } } Tcl_DeleteInterp(delInterp); Tcl_DStringResult(interp, &delString); return TCL_OK; } /* * The deletion callback used by TestdcallCmd: */ static void DelCallbackProc(clientData, interp) ClientData clientData; /* Numerical value to append to * delString. */ Tcl_Interp *interp; /* Interpreter being deleted. */ { int id = (int) clientData; char buffer[10]; sprintf(buffer, "%d", id); Tcl_DStringAppendElement(&delString, buffer); if (interp != delInterp) { Tcl_DStringAppendElement(&delString, "bogus interpreter argument!"); } } /* *---------------------------------------------------------------------- * * TestcmdinfoCmd -- * * This procedure implements the "testcmdinfo" command. It is used * to test Tcl_GetCommandInfo, Tcl_SetCommandInfo, and command creation * and deletion. * * Results: * A standard Tcl result. * * Side effects: * Creates and deletes various commands and modifies their data. * *---------------------------------------------------------------------- */ /* ARGSUSED */ static int TestcmdinfoCmd(dummy, interp, argc, argv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { Tcl_CmdInfo info; if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " option cmdName\"", (char *) NULL); return TCL_ERROR; } if (strcmp(argv[1], "create") == 0) { Tcl_CreateCommand(interp, argv[2], CmdProc1, (ClientData) "original", CmdDelProc1); } else if (strcmp(argv[1], "delete") == 0) { Tcl_DStringInit(&delString); Tcl_DeleteCommand(interp, argv[2]); Tcl_DStringResult(interp, &delString); } else if (strcmp(argv[1], "get") == 0) { if (Tcl_GetCommandInfo(interp, argv[2], &info) ==0) { interp->result = "??"; return TCL_OK; } if (info.proc == CmdProc1) { Tcl_AppendResult(interp, "CmdProc1", " ", (char *) info.clientData, (char *) NULL); } else if (info.proc == CmdProc2) { Tcl_AppendResult(interp, "CmdProc2", " ", (char *) info.clientData, (char *) NULL); } else { Tcl_AppendResult(interp, "unknown", (char *) NULL); } if (info.deleteProc == CmdDelProc1) { Tcl_AppendResult(interp, " CmdDelProc1", " ", (char *) info.deleteData, (char *) NULL); } else if (info.deleteProc == CmdDelProc2) { Tcl_AppendResult(interp, " CmdDelProc2", " ", (char *) info.deleteData, (char *) NULL); } else { Tcl_AppendResult(interp, " unknown", (char *) NULL); } } else if (strcmp(argv[1], "modify") == 0) { info.proc = CmdProc2; info.clientData = (ClientData) "new_command_data"; info.deleteProc = CmdDelProc2; info.deleteData = (ClientData) "new_delete_data"; if (Tcl_SetCommandInfo(interp, argv[2], &info) == 0) { interp->result = "0"; } else { interp->result = "1"; } } else { Tcl_AppendResult(interp, "bad option \"", argv[1], "\": must be create, delete, get, or modify", (char *) NULL); return TCL_ERROR; } return TCL_OK; } /*ARGSUSED*/ static int CmdProc1(clientData, interp, argc, argv) ClientData clientData; /* String to return. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { Tcl_AppendResult(interp, "CmdProc1 ", (char *) clientData, (char *) NULL); return TCL_OK; } /*ARGSUSED*/ static int CmdProc2(clientData, interp, argc, argv) ClientData clientData; /* String to return. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { Tcl_AppendResult(interp, "CmdProc2 ", (char *) clientData, (char *) NULL); return TCL_OK; } static void CmdDelProc1(clientData) ClientData clientData; /* String to save. */ { Tcl_DStringInit(&delString); Tcl_DStringAppend(&delString, "CmdDelProc1 ", -1); Tcl_DStringAppend(&delString, (char *) clientData, -1); } static void CmdDelProc2(clientData) ClientData clientData; /* String to save. */ { Tcl_DStringInit(&delString); Tcl_DStringAppend(&delString, "CmdDelProc2 ", -1); Tcl_DStringAppend(&delString, (char *) clientData, -1); } /* *---------------------------------------------------------------------- * * TestcmdtokenCmd -- * * This procedure implements the "testcmdtoken" command. It is used * to test Tcl_Command tokens and Tcl_GetCommandName. * * Results: * A standard Tcl result. * * Side effects: * Creates and deletes various commands and modifies their data. * *---------------------------------------------------------------------- */ /* ARGSUSED */ static int TestcmdtokenCmd(dummy, interp, argc, argv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { Tcl_Command token; long int l; if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " option arg\"", (char *) NULL); return TCL_ERROR; } if (strcmp(argv[1], "create") == 0) { token = Tcl_CreateCommand(interp, argv[2], CmdProc1, (ClientData) "original", (Tcl_CmdDeleteProc *) NULL); sprintf(interp->result, "%lx", (long int) token); } else if (strcmp(argv[1], "name") == 0) { if (sscanf(argv[2], "%lx", &l) != 1) { Tcl_AppendResult(interp, "bad command token \"", argv[2], "\"", (char *) NULL); return TCL_ERROR; } interp->result = Tcl_GetCommandName(interp, (Tcl_Command) l); } else { Tcl_AppendResult(interp, "bad option \"", argv[1], "\": must be create or name", (char *) NULL); return TCL_ERROR; } return TCL_OK; } /* *---------------------------------------------------------------------- * * TestdstringCmd -- * * This procedure implements the "testdstring" command. It is used * to test the dynamic string facilities of Tcl. * * Results: * A standard Tcl result. * * Side effects: * Creates, deletes, and invokes handlers. * *---------------------------------------------------------------------- */ /* ARGSUSED */ static int TestdstringCmd(dummy, interp, argc, argv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { int count; if (argc < 2) { wrongNumArgs: interp->result = "wrong # args"; return TCL_ERROR; } if (strcmp(argv[1], "append") == 0) { if (argc != 4) { goto wrongNumArgs; } if (Tcl_GetInt(interp, argv[3], &count) != TCL_OK) { return TCL_ERROR; } Tcl_DStringAppend(&dstring, argv[2], count); } else if (strcmp(argv[1], "element") == 0) { if (argc != 3) { goto wrongNumArgs; } Tcl_DStringAppendElement(&dstring, argv[2]); } else if (strcmp(argv[1], "end") == 0) { if (argc != 2) { goto wrongNumArgs; } Tcl_DStringEndSublist(&dstring); } else if (strcmp(argv[1], "free") == 0) { if (argc != 2) { goto wrongNumArgs; } Tcl_DStringFree(&dstring); } else if (strcmp(argv[1], "get") == 0) { if (argc != 2) { goto wrongNumArgs; } interp->result = Tcl_DStringValue(&dstring); } else if (strcmp(argv[1], "gresult") == 0) { if (argc != 3) { goto wrongNumArgs; } if (strcmp(argv[2], "staticsmall") == 0) { interp->result = "short"; } else if (strcmp(argv[2], "staticlarge") == 0) { interp->result = "first0 first1 first2 first3 first4 first5 first6 first7 first8 first9\nsecond0 second1 second2 second3 second4 second5 second6 second7 second8 second9\nthird0 third1 third2 third3 third4 third5 third6 third7 third8 third9\nfourth0 fourth1 fourth2 fourth3 fourth4 fourth5 fourth6 fourth7 fourth8 fourth9\nfifth0 fifth1 fifth2 fifth3 fifth4 fifth5 fifth6 fifth7 fifth8 fifth9\nsixth0 sixth1 sixth2 sixth3 sixth4 sixth5 sixth6 sixth7 sixth8 sixth9\nseventh0 seventh1 seventh2 seventh3 seventh4 seventh5 seventh6 seventh7 seventh8 seventh9\n"; } else if (strcmp(argv[2], "free") == 0) { interp->result = ckalloc(100); interp->freeProc = (Tcl_FreeProc *) free; strcpy(interp->result, "This is a malloc-ed string"); } else if (strcmp(argv[2], "special") == 0) { interp->result = ckalloc(100); interp->result += 4; interp->freeProc = SpecialFree; strcpy(interp->result, "This is a specially-allocated string"); } else { Tcl_AppendResult(interp, "bad gresult option \"", argv[2], "\": must be staticsmall, staticlarge, free, or special", (char *) NULL); return TCL_ERROR; } Tcl_DStringGetResult(interp, &dstring); } else if (strcmp(argv[1], "length") == 0) { if (argc != 2) { goto wrongNumArgs; } sprintf(interp->result, "%d", Tcl_DStringLength(&dstring)); } else if (strcmp(argv[1], "result") == 0) { if (argc != 2) { goto wrongNumArgs; } Tcl_DStringResult(interp, &dstring); } else if (strcmp(argv[1], "trunc") == 0) { if (argc != 3) { goto wrongNumArgs; } if (Tcl_GetInt(interp, argv[2], &count) != TCL_OK) { return TCL_ERROR; } Tcl_DStringTrunc(&dstring, count); } else if (strcmp(argv[1], "start") == 0) { if (argc != 2) { goto wrongNumArgs; } Tcl_DStringStartSublist(&dstring); } else { Tcl_AppendResult(interp, "bad option \"", argv[1], "\": must be append, element, end, free, get, length, ", "result, trunc, or start", (char *) NULL); return TCL_ERROR; } return TCL_OK; } /* * The procedure below is used as a special freeProc to test how well * Tcl_DStringGetResult handles freeProc's other than free. */ static void SpecialFree(blockPtr) char *blockPtr; /* Block to free. */ { ckfree(blockPtr - 4); } /* *---------------------------------------------------------------------- * * TestlinkCmd -- * * This procedure implements the "testlink" command. It is used * to test Tcl_LinkVar and related library procedures. * * Results: * A standard Tcl result. * * Side effects: * Creates and deletes various variable links, plus returns * values of the linked variables. * *---------------------------------------------------------------------- */ /* ARGSUSED */ static int TestlinkCmd(dummy, interp, argc, argv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { static int intVar = 43; static int boolVar = 4; static double realVar = 1.23; static char *stringVar = NULL; char buffer[TCL_DOUBLE_SPACE]; int writable, flag; if (argc < 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " option ?arg arg arg?\"", (char *) NULL); return TCL_ERROR; } if (strcmp(argv[1], "create") == 0) { if (Tcl_GetBoolean(interp, argv[2], &writable) != TCL_OK) { return TCL_ERROR; } flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; if (Tcl_LinkVar(interp, "int", (char *) &intVar, TCL_LINK_INT | flag) != TCL_OK) { return TCL_ERROR; } if (Tcl_GetBoolean(interp, argv[3], &writable) != TCL_OK) { return TCL_ERROR; } flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; if (Tcl_LinkVar(interp, "real", (char *) &realVar, TCL_LINK_DOUBLE | flag) != TCL_OK) { return TCL_ERROR; } if (Tcl_GetBoolean(interp, argv[4], &writable) != TCL_OK) { return TCL_ERROR; } flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; if (Tcl_LinkVar(interp, "bool", (char *) &boolVar, TCL_LINK_BOOLEAN | flag) != TCL_OK) { return TCL_ERROR; } if (Tcl_GetBoolean(interp, argv[5], &writable) != TCL_OK) { return TCL_ERROR; } flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; if (Tcl_LinkVar(interp, "string", (char *) &stringVar, TCL_LINK_STRING | flag) != TCL_OK) { return TCL_ERROR; } } else if (strcmp(argv[1], "delete") == 0) { Tcl_UnlinkVar(interp, "int"); Tcl_UnlinkVar(interp, "real"); Tcl_UnlinkVar(interp, "bool"); Tcl_UnlinkVar(interp, "string"); } else if (strcmp(argv[1], "get") == 0) { sprintf(buffer, "%d", intVar); Tcl_AppendElement(interp, buffer); Tcl_PrintDouble(interp, realVar, buffer); Tcl_AppendElement(interp, buffer); sprintf(buffer, "%d", boolVar); Tcl_AppendElement(interp, buffer); Tcl_AppendElement(interp, (stringVar == NULL) ? "-" : stringVar); } else if (strcmp(argv[1], "set") == 0) { if (argc != 6) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " ", argv[1], "intValue realValue boolValue stringValue\"", (char *) NULL); return TCL_ERROR; } if (argv[2][0] != 0) { if (Tcl_GetInt(interp, argv[2], &intVar) != TCL_OK) { return TCL_ERROR; } } if (argv[3][0] != 0) { if (Tcl_GetDouble(interp, argv[3], &realVar) != TCL_OK) { return TCL_ERROR; } } if (argv[4][0] != 0) { if (Tcl_GetInt(interp, argv[4], &boolVar) != TCL_OK) { return TCL_ERROR; } } if (argv[5][0] != 0) { if (stringVar != NULL) { ckfree(stringVar); } if (strcmp(argv[5], "-") == 0) { stringVar = NULL; } else { stringVar = ckalloc((unsigned) (strlen(argv[5]) + 1)); strcpy(stringVar, argv[5]); } } } else { Tcl_AppendResult(interp, "bad option \"", argv[1], "\": should be create, delete, get, or set", (char *) NULL); return TCL_ERROR; } return TCL_OK; } /* *---------------------------------------------------------------------- * * TestMathFunc -- * * This is a user-defined math procedure to test out math procedures * with no arguments. * * Results: * A normal Tcl completion code. * * Side effects: * None. * *---------------------------------------------------------------------- */ /* ARGSUSED */ static int TestMathFunc(clientData, interp, args, resultPtr) ClientData clientData; /* Integer value to return. */ Tcl_Interp *interp; /* Not used. */ Tcl_Value *args; /* Not used. */ Tcl_Value *resultPtr; /* Where to store result. */ { resultPtr->type = TCL_INT; resultPtr->intValue = (int) clientData; return TCL_OK; } /* *---------------------------------------------------------------------- * * TestupvarCmd -- * * This procedure implements the "testupvar2" command. It is used * to test Tcl_UpVar and Tcl_UpVar2. * * Results: * A standard Tcl result. * * Side effects: * Creates or modifies an "upvar" reference. * *---------------------------------------------------------------------- */ /* ARGSUSED */ static int TestupvarCmd(dummy, interp, argc, argv) ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int argc; /* Number of arguments. */ char **argv; /* Argument strings. */ { if ((argc != 5) && (argc != 6)) { Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], " level name ?name2? dest global\"", (char *) NULL); return TCL_ERROR; } if (argc == 5) { return Tcl_UpVar(interp, argv[1], argv[2], argv[3], (strcmp(argv[4], "global") == 0) ? TCL_GLOBAL_ONLY : 0); } else { return Tcl_UpVar2(interp, argv[1], argv[2], (argv[3][0] == 0) ? (char *) NULL : argv[3], argv[4], (strcmp(argv[5], "global") == 0) ? TCL_GLOBAL_ONLY : 0); } } endResult(interp, "wrong # args: should be \"", argv[0], " option arg\"", (char *) NULL); return TCL_ERROR; } if (strcmp(argv[1], "create") == 0) { token = Tcl_CreateCommand(interp, argv[2], CmdProc1, (ClientData) "original", (Tcl_CmdDeleteProc *) NULL); sprintf(interp->result, "%lx", (long int) token); } else if (strcmp(argv[1], "name") == 0) { if (sscanf(argv[2], "%lx", &l) != 1) { Tcl_AppendResult(interp, "bad command token \"", argv[2], tcl7.4b4/tclAppInit.c010044400630510000012000000053300576563465500152630ustar00ousterstaff00002300000001/* * tclAppInit.c -- * * Provides a default version of the main program and Tcl_AppInit * procedure for Tcl applications (without Tk). * * Copyright (c) 1993 The Regents of the University of California. * Copyright (c) 1994-1995 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ static char sccsid[] = "@(#) tclAppInit.c 1.13 95/06/08 10:55:54"; #include "tcl.h" /* * The following variable is a special hack that is needed in order for * Sun shared libraries to be used for Tcl. */ extern int matherr(); int *tclDummyMathPtr = (int *) matherr; /* *---------------------------------------------------------------------- * * main -- * * This is the main program for the application. * * Results: * None: Tcl_Main never returns here, so this procedure never * returns either. * * Side effects: * Whatever the application does. * *---------------------------------------------------------------------- */ int main(argc, argv) int argc; /* Number of command-line arguments. */ char **argv; /* Values of command-line arguments. */ { Tcl_Main(argc, argv, Tcl_AppInit); return 0; /* Needed only to prevent compiler warning. */ } /* *---------------------------------------------------------------------- * * Tcl_AppInit -- * * This procedure performs application-specific initialization. * Most applications, especially those that incorporate additional * packages, will have their own version of this procedure. * * Results: * Returns a standard Tcl completion code, and leaves an error * message in interp->result if an error occurs. * * Side effects: * Depends on the startup script. * *---------------------------------------------------------------------- */ int Tcl_AppInit(interp) Tcl_Interp *interp; /* Interpreter for application. */ { if (Tcl_Init(interp) == TCL_ERROR) { return TCL_ERROR; } /* * Call the init procedures for included packages. Each call should * look like this: * * if (Mod_Init(interp) == TCL_ERROR) { * return TCL_ERROR; * } * * where "Mod" is the name of the module. */ /* * Call Tcl_CreateCommand for application-specific commands, if * they weren't already created by the init procedures called above. */ /* * Specify a user-specific startup file to invoke if the application * is run interactively. Typically the startup file is "~/.apprc" * where "app" is the name of the application. If this line is deleted * then no user-specific startup file will be run under any conditions. */ tcl_RcFileName = "~/.tclshrc"; return TCL_OK; } tcl7.4b4/tclRegexp.h010044400630510000012000000016360575201526300151430ustar00ousterstaff00002300000001/* * Definitions etc. for regexp(3) routines. * * Caveat: this is V8 regexp(3) [actually, a reimplementation thereof], * not the System V one. * * @(#) tclRegexp.h 1.4 95/05/03 17:07:16 */ #ifndef _REGEXP #define _REGEXP 1 #ifndef _TCL #include "tcl.h" #endif #define NSUBEXP 50 typedef struct regexp { char *startp[NSUBEXP]; char *endp[NSUBEXP]; char regstart; /* Internal use only. */ char reganch; /* Internal use only. */ char *regmust; /* Internal use only. */ int regmlen; /* Internal use only. */ char program[1]; /* Unwarranted chumminess with compiler. */ } regexp; EXTERN regexp *TclRegComp _ANSI_ARGS_((char *exp)); EXTERN int TclRegExec _ANSI_ARGS_((regexp *prog, char *string, char *start)); EXTERN void TclRegSub _ANSI_ARGS_((regexp *prog, char *source, char *dest)); EXTERN void TclRegError _ANSI_ARGS_((char *msg)); EXTERN char *TclGetRegError _ANSI_ARGS_((void)); #endif /* REGEXP */ tcl7.4b4/tcl.h010044400630510000012000000536510576563465500140140ustar00ousterstaff00002300000001/* * tcl.h -- * * This header file describes the externally-visible facilities * of the Tcl interpreter. * * Copyright (c) 1987-1994 The Regents of the University of California. * Copyright (c) 1994-1995 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * @(#) tcl.h 1.150 95/06/08 10:55:57 */ #ifndef _TCL #define _TCL #ifndef BUFSIZ #include #endif #define TCL_VERSION "7.4" #define TCL_MAJOR_VERSION 7 #define TCL_MINOR_VERSION 4 /* * Definitions that allow this header file to be used either with or * without ANSI C features like function prototypes. */ #undef _ANSI_ARGS_ #undef CONST #if ((defined(__STDC__) || defined(SABER)) && !defined(NO_PROTOTYPE)) || defined(__cplusplus) # define _USING_PROTOTYPES_ 1 # define _ANSI_ARGS_(x) x # define CONST const # ifdef __cplusplus # define VARARGS (...) # else # define VARARGS () # endif #else # define _ANSI_ARGS_(x) () # define CONST #endif #ifdef __cplusplus # define EXTERN extern "C" #else # define EXTERN extern #endif /* * Macro to use instead of "void" for arguments that must have * type "void *" in ANSI C; maps them to type "char *" in * non-ANSI systems. */ #ifndef VOID # ifdef __STDC__ # define VOID void # else # define VOID char # endif #endif /* * Miscellaneous declarations (to allow Tcl to be used stand-alone, * without the rest of Sprite). */ #ifndef NULL #define NULL 0 #endif #ifndef _CLIENTDATA # if defined(__STDC__) || defined(__cplusplus) typedef void *ClientData; # else typedef int *ClientData; # endif /* __STDC__ */ #define _CLIENTDATA #endif /* * Data structures defined opaquely in this module. The definitions * below just provide dummy types. A few fields are made visible in * Tcl_Interp structures, namely those for returning string values. * Note: any change to the Tcl_Interp definition below must be mirrored * in the "real" definition in tclInt.h. */ typedef struct Tcl_Interp{ char *result; /* Points to result string returned by last * command. */ void (*freeProc) _ANSI_ARGS_((char *blockPtr)); /* Zero means result is statically allocated. * If non-zero, gives address of procedure * to invoke to free the result. Must be * freed by Tcl_Eval before executing next * command. */ int errorLine; /* When TCL_ERROR is returned, this gives * the line number within the command where * the error occurred (1 means first line). */ } Tcl_Interp; typedef int *Tcl_Trace; typedef int *Tcl_Command; typedef struct Tcl_AsyncHandler_ *Tcl_AsyncHandler; typedef struct Tcl_RegExp_ *Tcl_RegExp; /* * When a TCL command returns, the string pointer interp->result points to * a string containing return information from the command. In addition, * the command procedure returns an integer value, which is one of the * following: * * TCL_OK Command completed normally; interp->result contains * the command's result. * TCL_ERROR The command couldn't be completed successfully; * interp->result describes what went wrong. * TCL_RETURN The command requests that the current procedure * return; interp->result contains the procedure's * return value. * TCL_BREAK The command requests that the innermost loop * be exited; interp->result is meaningless. * TCL_CONTINUE Go on to the next iteration of the current loop; * interp->result is meaningless. */ #define TCL_OK 0 #define TCL_ERROR 1 #define TCL_RETURN 2 #define TCL_BREAK 3 #define TCL_CONTINUE 4 #define TCL_RESULT_SIZE 200 /* * Argument descriptors for math function callbacks in expressions: */ typedef enum {TCL_INT, TCL_DOUBLE, TCL_EITHER} Tcl_ValueType; typedef struct Tcl_Value { Tcl_ValueType type; /* Indicates intValue or doubleValue is * valid, or both. */ long intValue; /* Integer value. */ double doubleValue; /* Double-precision floating value. */ } Tcl_Value; /* * Procedure types defined by Tcl: */ typedef int (Tcl_AppInitProc) _ANSI_ARGS_((Tcl_Interp *interp)); typedef int (Tcl_AsyncProc) _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int code)); typedef void (Tcl_CmdDeleteProc) _ANSI_ARGS_((ClientData clientData)); typedef int (Tcl_CmdProc) _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char *argv[])); typedef void (Tcl_CmdTraceProc) _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int level, char *command, Tcl_CmdProc *proc, ClientData cmdClientData, int argc, char *argv[])); typedef void (Tcl_FreeProc) _ANSI_ARGS_((char *blockPtr)); typedef void (Tcl_InterpDeleteProc) _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp)); typedef int (Tcl_MathProc) _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, Tcl_Value *args, Tcl_Value *resultPtr)); typedef char *(Tcl_VarTraceProc) _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, char *part1, char *part2, int flags)); /* * The structure returned by Tcl_GetCmdInfo and passed into * Tcl_SetCmdInfo: */ typedef struct Tcl_CmdInfo { Tcl_CmdProc *proc; /* Procedure that implements command. */ ClientData clientData; /* ClientData passed to proc. */ Tcl_CmdDeleteProc *deleteProc; /* Procedure to call when command * is deleted. */ ClientData deleteData; /* Value to pass to deleteProc (usually * the same as clientData). */ } Tcl_CmdInfo; /* * The structure defined below is used to hold dynamic strings. The only * field that clients should use is the string field, and they should * never modify it. */ #define TCL_DSTRING_STATIC_SIZE 200 typedef struct Tcl_DString { char *string; /* Points to beginning of string: either * staticSpace below or a malloc'ed array. */ int length; /* Number of non-NULL characters in the * string. */ int spaceAvl; /* Total number of bytes available for the * string and its terminating NULL char. */ char staticSpace[TCL_DSTRING_STATIC_SIZE]; /* Space to use in common case where string * is small. */ } Tcl_DString; #define Tcl_DStringLength(dsPtr) ((dsPtr)->length) #define Tcl_DStringValue(dsPtr) ((dsPtr)->string) #define Tcl_DStringTrunc Tcl_DStringSetLength /* * Definitions for the maximum number of digits of precision that may * be specified in the "tcl_precision" variable, and the number of * characters of buffer space required by Tcl_PrintDouble. */ #define TCL_MAX_PREC 17 #define TCL_DOUBLE_SPACE (TCL_MAX_PREC+10) /* * Flag that may be passed to Tcl_ConvertElement to force it not to * output braces (careful! if you change this flag be sure to change * the definitions at the front of tclUtil.c). */ #define TCL_DONT_USE_BRACES 1 /* * Flag values passed to Tcl_RecordAndEval. * WARNING: these bit choices must not conflict with the bit choices * for evalFlag bits in tclInt.h!! */ #define TCL_NO_EVAL 0x10000 #define TCL_EVAL_GLOBAL 0x20000 /* * Special freeProc values that may be passed to Tcl_SetResult (see * the man page for details): */ #define TCL_VOLATILE ((Tcl_FreeProc *) 1) #define TCL_STATIC ((Tcl_FreeProc *) 0) #define TCL_DYNAMIC ((Tcl_FreeProc *) 3) /* * Flag values passed to variable-related procedures. */ #define TCL_GLOBAL_ONLY 1 #define TCL_APPEND_VALUE 2 #define TCL_LIST_ELEMENT 4 #define TCL_TRACE_READS 0x10 #define TCL_TRACE_WRITES 0x20 #define TCL_TRACE_UNSETS 0x40 #define TCL_TRACE_DESTROYED 0x80 #define TCL_INTERP_DESTROYED 0x100 #define TCL_LEAVE_ERR_MSG 0x200 /* * Types for linked variables: */ #define TCL_LINK_INT 1 #define TCL_LINK_DOUBLE 2 #define TCL_LINK_BOOLEAN 3 #define TCL_LINK_STRING 4 #define TCL_LINK_READ_ONLY 0x80 /* * Permission flags for files: */ #define TCL_FILE_READABLE 1 #define TCL_FILE_WRITABLE 2 /* * The following declarations either map ckalloc and ckfree to * malloc and free, or they map them to procedures with all sorts * of debugging hooks defined in tclCkalloc.c. */ #ifdef TCL_MEM_DEBUG EXTERN char * Tcl_DbCkalloc _ANSI_ARGS_((unsigned int size, char *file, int line)); EXTERN int Tcl_DbCkfree _ANSI_ARGS_((char *ptr, char *file, int line)); EXTERN char * Tcl_DbCkrealloc _ANSI_ARGS_((char *ptr, unsigned int size, char *file, int line)); EXTERN int Tcl_DumpActiveMemory _ANSI_ARGS_((char *fileName)); EXTERN void Tcl_ValidateAllMemory _ANSI_ARGS_((char *file, int line)); # define ckalloc(x) Tcl_DbCkalloc(x, __FILE__, __LINE__) # define ckfree(x) Tcl_DbCkfree(x, __FILE__, __LINE__) # define ckrealloc(x,y) Tcl_DbCkrealloc((x), (y),__FILE__, __LINE__) #else # define ckalloc(x) malloc(x) # define ckfree(x) free(x) # define ckrealloc(x,y) realloc(x,y) # define Tcl_DumpActiveMemory(x) # define Tcl_ValidateAllMemory(x,y) #endif /* TCL_MEM_DEBUG */ /* * Macro to free up result of interpreter. */ #define Tcl_FreeResult(interp) \ if ((interp)->freeProc != 0) { \ if ((interp)->freeProc == (Tcl_FreeProc *) free) { \ ckfree((interp)->result); \ } else { \ (*(interp)->freeProc)((interp)->result); \ } \ (interp)->freeProc = 0; \ } /* * Forward declaration of Tcl_HashTable. Needed by some C++ compilers * to prevent errors when the forward reference to Tcl_HashTable is * encountered in the Tcl_HashEntry structure. */ #ifdef __cplusplus struct Tcl_HashTable; #endif /* * Structure definition for an entry in a hash table. No-one outside * Tcl should access any of these fields directly; use the macros * defined below. */ typedef struct Tcl_HashEntry { struct Tcl_HashEntry *nextPtr; /* Pointer to next entry in this * hash bucket, or NULL for end of * chain. */ struct Tcl_HashTable *tablePtr; /* Pointer to table containing entry. */ struct Tcl_HashEntry **bucketPtr; /* Pointer to bucket that points to * first entry in this entry's chain: * used for deleting the entry. */ ClientData clientData; /* Application stores something here * with Tcl_SetHashValue. */ union { /* Key has one of these forms: */ char *oneWordValue; /* One-word value for key. */ int words[1]; /* Multiple integer words for key. * The actual size will be as large * as necessary for this table's * keys. */ char string[4]; /* String for key. The actual size * will be as large as needed to hold * the key. */ } key; /* MUST BE LAST FIELD IN RECORD!! */ } Tcl_HashEntry; /* * Structure definition for a hash table. Must be in tcl.h so clients * can allocate space for these structures, but clients should never * access any fields in this structure. */ #define TCL_SMALL_HASH_TABLE 4 typedef struct Tcl_HashTable { Tcl_HashEntry **buckets; /* Pointer to bucket array. Each * element points to first entry in * bucket's hash chain, or NULL. */ Tcl_HashEntry *staticBuckets[TCL_SMALL_HASH_TABLE]; /* Bucket array used for small tables * (to avoid mallocs and frees). */ int numBuckets; /* Total number of buckets allocated * at **bucketPtr. */ int numEntries; /* Total number of entries present * in table. */ int rebuildSize; /* Enlarge table when numEntries gets * to be this large. */ int downShift; /* Shift count used in hashing * function. Designed to use high- * order bits of randomized keys. */ int mask; /* Mask value used in hashing * function. */ int keyType; /* Type of keys used in this table. * It's either TCL_STRING_KEYS, * TCL_ONE_WORD_KEYS, or an integer * giving the number of ints in a */ Tcl_HashEntry *(*findProc) _ANSI_ARGS_((struct Tcl_HashTable *tablePtr, char *key)); Tcl_HashEntry *(*createProc) _ANSI_ARGS_((struct Tcl_HashTable *tablePtr, char *key, int *newPtr)); } Tcl_HashTable; /* * Structure definition for information used to keep track of searches * through hash tables: */ typedef struct Tcl_HashSearch { Tcl_HashTable *tablePtr; /* Table being searched. */ int nextIndex; /* Index of next bucket to be * enumerated after present one. */ Tcl_HashEntry *nextEntryPtr; /* Next entry to be enumerated in the * the current bucket. */ } Tcl_HashSearch; /* * Acceptable key types for hash tables: */ #define TCL_STRING_KEYS 0 #define TCL_ONE_WORD_KEYS 1 /* * Macros for clients to use to access fields of hash entries: */ #define Tcl_GetHashValue(h) ((h)->clientData) #define Tcl_SetHashValue(h, value) ((h)->clientData = (ClientData) (value)) #define Tcl_GetHashKey(tablePtr, h) \ ((char *) (((tablePtr)->keyType == TCL_ONE_WORD_KEYS) ? (h)->key.oneWordValue \ : (h)->key.string)) /* * Macros to use for clients to use to invoke find and create procedures * for hash tables: */ #define Tcl_FindHashEntry(tablePtr, key) \ (*((tablePtr)->findProc))(tablePtr, key) #define Tcl_CreateHashEntry(tablePtr, key, newPtr) \ (*((tablePtr)->createProc))(tablePtr, key, newPtr) /* * Exported Tcl variables: */ EXTERN int tcl_AsyncReady; EXTERN void (*tcl_FileCloseProc) _ANSI_ARGS_((FILE *f)); EXTERN char * tcl_RcFileName; /* * Exported Tcl procedures: */ EXTERN void Tcl_AddErrorInfo _ANSI_ARGS_((Tcl_Interp *interp, char *message)); EXTERN void Tcl_AllowExceptions _ANSI_ARGS_((Tcl_Interp *interp)); EXTERN void Tcl_AppendElement _ANSI_ARGS_((Tcl_Interp *interp, char *string)); EXTERN void Tcl_AppendResult _ANSI_ARGS_(VARARGS); EXTERN int Tcl_AppInit _ANSI_ARGS_((Tcl_Interp *interp)); EXTERN void Tcl_AsyncMark _ANSI_ARGS_((Tcl_AsyncHandler async)); EXTERN Tcl_AsyncHandler Tcl_AsyncCreate _ANSI_ARGS_((Tcl_AsyncProc *proc, ClientData clientData)); EXTERN void Tcl_AsyncDelete _ANSI_ARGS_((Tcl_AsyncHandler async)); EXTERN int Tcl_AsyncInvoke _ANSI_ARGS_((Tcl_Interp *interp, int code)); EXTERN char Tcl_Backslash _ANSI_ARGS_((char *src, int *readPtr)); EXTERN void Tcl_CallWhenDeleted _ANSI_ARGS_((Tcl_Interp *interp, Tcl_InterpDeleteProc *proc, ClientData clientData)); EXTERN int Tcl_CommandComplete _ANSI_ARGS_((char *cmd)); EXTERN char * Tcl_Concat _ANSI_ARGS_((int argc, char **argv)); EXTERN int Tcl_ConvertElement _ANSI_ARGS_((char *src, char *dst, int flags)); EXTERN Tcl_Command Tcl_CreateCommand _ANSI_ARGS_((Tcl_Interp *interp, char *cmdName, Tcl_CmdProc *proc, ClientData clientData, Tcl_CmdDeleteProc *deleteProc)); EXTERN Tcl_Interp * Tcl_CreateInterp _ANSI_ARGS_((void)); EXTERN void Tcl_CreateMathFunc _ANSI_ARGS_((Tcl_Interp *interp, char *name, int numArgs, Tcl_ValueType *argTypes, Tcl_MathProc *proc, ClientData clientData)); EXTERN int Tcl_CreatePipeline _ANSI_ARGS_((Tcl_Interp *interp, int argc, char **argv, int **pidArrayPtr, int *inPipePtr, int *outPipePtr, int *errFilePtr)); EXTERN Tcl_Trace Tcl_CreateTrace _ANSI_ARGS_((Tcl_Interp *interp, int level, Tcl_CmdTraceProc *proc, ClientData clientData)); EXTERN int Tcl_DeleteCommand _ANSI_ARGS_((Tcl_Interp *interp, char *cmdName)); EXTERN void Tcl_DeleteHashEntry _ANSI_ARGS_(( Tcl_HashEntry *entryPtr)); EXTERN void Tcl_DeleteHashTable _ANSI_ARGS_(( Tcl_HashTable *tablePtr)); EXTERN void Tcl_DeleteInterp _ANSI_ARGS_((Tcl_Interp *interp)); EXTERN void Tcl_DeleteTrace _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Trace trace)); EXTERN void Tcl_DetachPids _ANSI_ARGS_((int numPids, int *pidPtr)); EXTERN void Tcl_DontCallWhenDeleted _ANSI_ARGS_(( Tcl_Interp *interp, Tcl_InterpDeleteProc *proc, ClientData clientData)); EXTERN char * Tcl_DStringAppend _ANSI_ARGS_((Tcl_DString *dsPtr, char *string, int length)); EXTERN char * Tcl_DStringAppendElement _ANSI_ARGS_(( Tcl_DString *dsPtr, char *string)); EXTERN void Tcl_DStringEndSublist _ANSI_ARGS_((Tcl_DString *dsPtr)); EXTERN void Tcl_DStringFree _ANSI_ARGS_((Tcl_DString *dsPtr)); EXTERN void Tcl_DStringGetResult _ANSI_ARGS_((Tcl_Interp *interp, Tcl_DString *dsPtr)); EXTERN void Tcl_DStringInit _ANSI_ARGS_((Tcl_DString *dsPtr)); EXTERN void Tcl_DStringResult _ANSI_ARGS_((Tcl_Interp *interp, Tcl_DString *dsPtr)); EXTERN void Tcl_DStringSetLength _ANSI_ARGS_((Tcl_DString *dsPtr, int length)); EXTERN void Tcl_DStringStartSublist _ANSI_ARGS_(( Tcl_DString *dsPtr)); EXTERN void Tcl_EnterFile _ANSI_ARGS_((Tcl_Interp *interp, FILE *file, int permissions)); EXTERN char * Tcl_ErrnoId _ANSI_ARGS_((void)); EXTERN int Tcl_Eval _ANSI_ARGS_((Tcl_Interp *interp, char *cmd)); EXTERN int Tcl_EvalFile _ANSI_ARGS_((Tcl_Interp *interp, char *fileName)); EXTERN int Tcl_ExprBoolean _ANSI_ARGS_((Tcl_Interp *interp, char *string, int *ptr)); EXTERN int Tcl_ExprDouble _ANSI_ARGS_((Tcl_Interp *interp, char *string, double *ptr)); EXTERN int Tcl_ExprLong _ANSI_ARGS_((Tcl_Interp *interp, char *string, long *ptr)); EXTERN int Tcl_ExprString _ANSI_ARGS_((Tcl_Interp *interp, char *string)); EXTERN int Tcl_FilePermissions _ANSI_ARGS_((FILE *file)); EXTERN Tcl_HashEntry * Tcl_FirstHashEntry _ANSI_ARGS_(( Tcl_HashTable *tablePtr, Tcl_HashSearch *searchPtr)); EXTERN int Tcl_GetBoolean _ANSI_ARGS_((Tcl_Interp *interp, char *string, int *boolPtr)); EXTERN int Tcl_GetCommandInfo _ANSI_ARGS_((Tcl_Interp *interp, char *cmdName, Tcl_CmdInfo *infoPtr)); EXTERN char * Tcl_GetCommandName _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Command command)); EXTERN int Tcl_GetDouble _ANSI_ARGS_((Tcl_Interp *interp, char *string, double *doublePtr)); EXTERN int Tcl_GetInt _ANSI_ARGS_((Tcl_Interp *interp, char *string, int *intPtr)); EXTERN int Tcl_GetOpenFile _ANSI_ARGS_((Tcl_Interp *interp, char *string, int write, int checkUsage, FILE **filePtr)); EXTERN char * Tcl_GetVar _ANSI_ARGS_((Tcl_Interp *interp, char *varName, int flags)); EXTERN char * Tcl_GetVar2 _ANSI_ARGS_((Tcl_Interp *interp, char *part1, char *part2, int flags)); EXTERN int Tcl_GlobalEval _ANSI_ARGS_((Tcl_Interp *interp, char *command)); EXTERN char * Tcl_HashStats _ANSI_ARGS_((Tcl_HashTable *tablePtr)); EXTERN int Tcl_Init _ANSI_ARGS_((Tcl_Interp *interp)); EXTERN void Tcl_InitHashTable _ANSI_ARGS_((Tcl_HashTable *tablePtr, int keyType)); EXTERN void Tcl_InitMemory _ANSI_ARGS_((Tcl_Interp *interp)); EXTERN int Tcl_LinkVar _ANSI_ARGS_((Tcl_Interp *interp, char *varName, char *addr, int type)); EXTERN void Tcl_Main _ANSI_ARGS_((int argc, char **argv, Tcl_AppInitProc *appInitProc)); EXTERN char * Tcl_Merge _ANSI_ARGS_((int argc, char **argv)); EXTERN Tcl_HashEntry * Tcl_NextHashEntry _ANSI_ARGS_(( Tcl_HashSearch *searchPtr)); EXTERN char * Tcl_ParseVar _ANSI_ARGS_((Tcl_Interp *interp, char *string, char **termPtr)); EXTERN char * Tcl_PosixError _ANSI_ARGS_((Tcl_Interp *interp)); EXTERN void Tcl_PrintDouble _ANSI_ARGS_((Tcl_Interp *interp, double value, char *dst)); EXTERN void Tcl_ReapDetachedProcs _ANSI_ARGS_((void)); EXTERN int Tcl_RecordAndEval _ANSI_ARGS_((Tcl_Interp *interp, char *cmd, int flags)); EXTERN Tcl_RegExp Tcl_RegExpCompile _ANSI_ARGS_((Tcl_Interp *interp, char *string)); EXTERN int Tcl_RegExpExec _ANSI_ARGS_((Tcl_Interp *interp, Tcl_RegExp regexp, char *string, char *start)); EXTERN int Tcl_RegExpMatch _ANSI_ARGS_((Tcl_Interp *interp, char *string, char *pattern)); EXTERN void Tcl_RegExpRange _ANSI_ARGS_((Tcl_RegExp regexp, int index, char **startPtr, char **endPtr)); EXTERN void Tcl_ResetResult _ANSI_ARGS_((Tcl_Interp *interp)); #define Tcl_Return Tcl_SetResult EXTERN int Tcl_ScanElement _ANSI_ARGS_((char *string, int *flagPtr)); EXTERN int Tcl_SetCommandInfo _ANSI_ARGS_((Tcl_Interp *interp, char *cmdName, Tcl_CmdInfo *infoPtr)); EXTERN void Tcl_SetErrorCode _ANSI_ARGS_(VARARGS); EXTERN int Tcl_SetRecursionLimit _ANSI_ARGS_((Tcl_Interp *interp, int depth)); EXTERN void Tcl_SetResult _ANSI_ARGS_((Tcl_Interp *interp, char *string, Tcl_FreeProc *freeProc)); EXTERN char * Tcl_SetVar _ANSI_ARGS_((Tcl_Interp *interp, char *varName, char *newValue, int flags)); EXTERN char * Tcl_SetVar2 _ANSI_ARGS_((Tcl_Interp *interp, char *part1, char *part2, char *newValue, int flags)); EXTERN char * Tcl_SignalId _ANSI_ARGS_((int sig)); EXTERN char * Tcl_SignalMsg _ANSI_ARGS_((int sig)); EXTERN int Tcl_SplitList _ANSI_ARGS_((Tcl_Interp *interp, char *list, int *argcPtr, char ***argvPtr)); EXTERN int Tcl_StringMatch _ANSI_ARGS_((char *string, char *pattern)); EXTERN char * Tcl_TildeSubst _ANSI_ARGS_((Tcl_Interp *interp, char *name, Tcl_DString *bufferPtr)); EXTERN int Tcl_TraceVar _ANSI_ARGS_((Tcl_Interp *interp, char *varName, int flags, Tcl_VarTraceProc *proc, ClientData clientData)); EXTERN int Tcl_TraceVar2 _ANSI_ARGS_((Tcl_Interp *interp, char *part1, char *part2, int flags, Tcl_VarTraceProc *proc, ClientData clientData)); EXTERN void Tcl_UnlinkVar _ANSI_ARGS_((Tcl_Interp *interp, char *varName)); EXTERN int Tcl_UnsetVar _ANSI_ARGS_((Tcl_Interp *interp, char *varName, int flags)); EXTERN int Tcl_UnsetVar2 _ANSI_ARGS_((Tcl_Interp *interp, char *part1, char *part2, int flags)); EXTERN void Tcl_UntraceVar _ANSI_ARGS_((Tcl_Interp *interp, char *varName, int flags, Tcl_VarTraceProc *proc, ClientData clientData)); EXTERN void Tcl_UntraceVar2 _ANSI_ARGS_((Tcl_Interp *interp, char *part1, char *part2, int flags, Tcl_VarTraceProc *proc, ClientData clientData)); EXTERN int Tcl_UpVar _ANSI_ARGS_((Tcl_Interp *interp, char *frameName, char *varName, char *localName, int flags)); EXTERN int Tcl_UpVar2 _ANSI_ARGS_((Tcl_Interp *interp, char *frameName, char *part1, char *part2, char *localName, int flags)); EXTERN int Tcl_VarEval _ANSI_ARGS_(VARARGS); EXTERN ClientData Tcl_VarTraceInfo _ANSI_ARGS_((Tcl_Interp *interp, char *varName, int flags, Tcl_VarTraceProc *procPtr, ClientData prevClientData)); EXTERN ClientData Tcl_VarTraceInfo2 _ANSI_ARGS_((Tcl_Interp *interp, char *part1, char *part2, int flags, Tcl_VarTraceProc *procPtr, ClientData prevClientData)); #endif /* _TCL */ fter present one. */ Tcl_HashEntry *nextEntryPtr; /* Next entry to be enumerated intcl7.4b4/tclInt.h010044400630510000012000001065200573633175200144470ustar00ousterstaff00002300000001/* * tclInt.h -- * * Declarations of things used internally by the Tcl interpreter. * * Copyright (c) 1987-1993 The Regents of the University of California. * Copyright (c) 1994-1995 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * @(#) tclInt.h 1.103 95/03/29 11:24:24 */ #ifndef _TCLINT #define _TCLINT /* * Common include files needed by most of the Tcl source files are * included here, so that system-dependent personalizations for the * include files only have to be made in once place. This results * in a few extra includes, but greater modularity. The order of * the three groups of #includes is important. For example, stdio.h * is needed by tcl.h, and the _ANSI_ARGS_ declaration in tcl.h is * needed by stdlib.h in some configurations. */ #include #ifndef _TCL #include "tcl.h" #endif #ifndef _REGEXP #include "tclRegexp.h" #endif #include #ifdef NO_LIMITS_H # include "compat/limits.h" #else # include #endif #ifdef NO_STDLIB_H # include "compat/stdlib.h" #else # include #endif #ifdef NO_STRING_H #include "compat/string.h" #else #include #endif #include /* * At present (12/91) not all stdlib.h implementations declare strtod. * The declaration below is here to ensure that it's declared, so that * the compiler won't take the default approach of assuming it returns * an int. There's no ANSI prototype for it because there would end * up being too many conflicts with slightly-different prototypes. */ extern double strtod(); /* *---------------------------------------------------------------- * Data structures related to variables. These are used primarily * in tclVar.c *---------------------------------------------------------------- */ /* * The following structure defines a variable trace, which is used to * invoke a specific C procedure whenever certain operations are performed * on a variable. */ typedef struct VarTrace { Tcl_VarTraceProc *traceProc;/* Procedure to call when operations given * by flags are performed on variable. */ ClientData clientData; /* Argument to pass to proc. */ int flags; /* What events the trace procedure is * interested in: OR-ed combination of * TCL_TRACE_READS, TCL_TRACE_WRITES, and * TCL_TRACE_UNSETS. */ struct VarTrace *nextPtr; /* Next in list of traces associated with * a particular variable. */ } VarTrace; /* * When a variable trace is active (i.e. its associated procedure is * executing), one of the following structures is linked into a list * associated with the variable's interpreter. The information in * the structure is needed in order for Tcl to behave reasonably * if traces are deleted while traces are active. */ typedef struct ActiveVarTrace { struct Var *varPtr; /* Variable that's being traced. */ struct ActiveVarTrace *nextPtr; /* Next in list of all active variable * traces for the interpreter, or NULL * if no more. */ VarTrace *nextTracePtr; /* Next trace to check after current * trace procedure returns; if this * trace gets deleted, must update pointer * to avoid using free'd memory. */ } ActiveVarTrace; /* * The following structure describes an enumerative search in progress on * an array variable; this are invoked with options to the "array" * command. */ typedef struct ArraySearch { int id; /* Integer id used to distinguish among * multiple concurrent searches for the * same array. */ struct Var *varPtr; /* Pointer to array variable that's being * searched. */ Tcl_HashSearch search; /* Info kept by the hash module about * progress through the array. */ Tcl_HashEntry *nextEntry; /* Non-null means this is the next element * to be enumerated (it's leftover from * the Tcl_FirstHashEntry call or from * an "array anymore" command). NULL * means must call Tcl_NextHashEntry * to get value to return. */ struct ArraySearch *nextPtr;/* Next in list of all active searches * for this variable, or NULL if this is * the last one. */ } ArraySearch; /* * The structure below defines a variable, which associates a string name * with a string value. Pointers to these structures are kept as the * values of hash table entries, and the name of each variable is stored * in the hash entry. */ typedef struct Var { int valueLength; /* Holds the number of non-null bytes * actually occupied by the variable's * current value in value.string (extra * space is sometimes left for expansion). * For array and global variables this is * meaningless. */ int valueSpace; /* Total number of bytes of space allocated * at value.string. 0 means there is no * space allocated. */ union { char *string; /* String value of variable, used for scalar * variables and array elements. Malloc-ed. */ Tcl_HashTable *tablePtr;/* For array variables, this points to * information about the hash table used * to implement the associative array. * Points to malloc-ed data. */ struct Var *upvarPtr; /* If this is a global variable being * referred to in a procedure, or a variable * created by "upvar", this field points to * the record for the higher-level variable. */ } value; Tcl_HashEntry *hPtr; /* Hash table entry that refers to this * variable, or NULL if the variable has * been detached from its hash table (e.g. * an array is deleted, but some of its * elements are still referred to in upvars). */ int refCount; /* Counts number of active uses of this * variable, not including its main hash * table entry: 1 for each additional variable * whose upVarPtr points here, 1 for each * nested trace active on variable. This * record can't be deleted until refCount * becomes 0. */ VarTrace *tracePtr; /* First in list of all traces set for this * variable. */ ArraySearch *searchPtr; /* First in list of all searches active * for this variable, or NULL if none. */ int flags; /* Miscellaneous bits of information about * variable. See below for definitions. */ } Var; /* * Flag bits for variables: * * VAR_ARRAY - 1 means this is an array variable rather * than a scalar variable. * VAR_UPVAR - 1 means this variable just contains a * pointer to another variable that has the * real value. Variables like this come * about through the "upvar" and "global" * commands. * VAR_UNDEFINED - 1 means that the variable is currently * undefined. Undefined variables usually * go away completely, but if an undefined * variable has a trace on it, or if it is * a global variable being used by a procedure, * then it stays around even when undefined. * VAR_TRACE_ACTIVE - 1 means that trace processing is currently * underway for a read or write access, so * new read or write accesses should not cause * trace procedures to be called and the * variable can't be deleted. */ #define VAR_ARRAY 1 #define VAR_UPVAR 2 #define VAR_UNDEFINED 4 #define VAR_TRACE_ACTIVE 0x10 /* *---------------------------------------------------------------- * Data structures related to procedures. These are used primarily * in tclProc.c *---------------------------------------------------------------- */ /* * The structure below defines an argument to a procedure, which * consists of a name and an (optional) default value. */ typedef struct Arg { struct Arg *nextPtr; /* Next argument for this procedure, * or NULL if this is the last argument. */ char *defValue; /* Pointer to arg's default value, or NULL * if no default value. */ char name[4]; /* Name of argument starts here. The name * is followed by space for the default, * if there is one. The actual size of this * field will be as large as necessary to * hold both name and default value. THIS * MUST BE THE LAST FIELD IN THE STRUCTURE!! */ } Arg; /* * The structure below defines a command procedure, which consists of * a collection of Tcl commands plus information about arguments and * variables. */ typedef struct Proc { struct Interp *iPtr; /* Interpreter for which this command * is defined. */ int refCount; /* Reference count: 1 if still present * in command table plus 1 for each call * to the procedure that is currently * active. This structure can be freed * when refCount becomes zero. */ char *command; /* Command that constitutes the body of * the procedure (dynamically allocated). */ Arg *argPtr; /* Pointer to first of procedure's formal * arguments, or NULL if none. */ } Proc; /* * The structure below defines a command trace. This is used to allow Tcl * clients to find out whenever a command is about to be executed. */ typedef struct Trace { int level; /* Only trace commands at nesting level * less than or equal to this. */ Tcl_CmdTraceProc *proc; /* Procedure to call to trace command. */ ClientData clientData; /* Arbitrary value to pass to proc. */ struct Trace *nextPtr; /* Next in list of traces for this interp. */ } Trace; /* * The stucture below defines a deletion callback, which is * a procedure to invoke just before an interpreter is deleted. */ typedef struct DeleteCallback { Tcl_InterpDeleteProc *proc; /* Procedure to call. */ ClientData clientData; /* Value to pass to procedure. */ struct DeleteCallback *nextPtr; /* Next in list of callbacks for this * interpreter (or NULL for end of list). */ } DeleteCallback; /* * The structure below defines a frame, which is a procedure invocation. * These structures exist only while procedures are being executed, and * provide a sort of call stack. */ typedef struct CallFrame { Tcl_HashTable varTable; /* Hash table containing all of procedure's * local variables. */ int level; /* Level of this procedure, for "uplevel" * purposes (i.e. corresponds to nesting of * callerVarPtr's, not callerPtr's). 1 means * outer-most procedure, 0 means top-level. */ int argc; /* This and argv below describe name and * arguments for this procedure invocation. */ char **argv; /* Array of arguments. */ struct CallFrame *callerPtr; /* Value of interp->framePtr when this * procedure was invoked (i.e. next in * stack of all active procedures). */ struct CallFrame *callerVarPtr; /* Value of interp->varFramePtr when this * procedure was invoked (i.e. determines * variable scoping within caller; same * as callerPtr unless an "uplevel" command * or something equivalent was active in * the caller). */ } CallFrame; /* * The structure below defines one history event (a previously-executed * command that can be re-executed in whole or in part). */ typedef struct { char *command; /* String containing previously-executed * command. */ int bytesAvl; /* Total # of bytes available at *event (not * all are necessarily in use now). */ } HistoryEvent; /* *---------------------------------------------------------------- * Data structures related to history. These are used primarily * in tclHistory.c *---------------------------------------------------------------- */ /* * The structure below defines a pending revision to the most recent * history event. Changes are linked together into a list and applied * during the next call to Tcl_RecordHistory. See the comments at the * beginning of tclHistory.c for information on revisions. */ typedef struct HistoryRev { int firstIndex; /* Index of the first byte to replace in * current history event. */ int lastIndex; /* Index of last byte to replace in * current history event. */ int newSize; /* Number of bytes in newBytes. */ char *newBytes; /* Replacement for the range given by * firstIndex and lastIndex. */ struct HistoryRev *nextPtr; /* Next in chain of revisions to apply, or * NULL for end of list. */ } HistoryRev; /* *---------------------------------------------------------------- * Data structures related to files. These are used primarily in * tclUnixUtil.c and tclUnixAZ.c. *---------------------------------------------------------------- */ /* * The data structure below defines an open file (or connection to * a process pipeline) as returned by the "open" command. */ typedef struct OpenFile { FILE *f; /* Stdio file to use for reading and/or * writing. */ FILE *f2; /* Normally NULL. In the special case of * a command pipeline with pipes for both * input and output, this is a stdio file * to use for writing to the pipeline. */ int permissions; /* OR-ed combination of TCL_FILE_READABLE * and TCL_FILE_WRITABLE. */ int numPids; /* If this is a connection to a process * pipeline, gives number of processes * in pidPtr array below; otherwise it * is 0. */ int *pidPtr; /* Pointer to malloc-ed array of child * process ids (numPids of them), or NULL * if this isn't a connection to a process * pipeline. */ int errorId; /* File id of file that receives error * output from pipeline. -1 means not * used (i.e. this is a normal file). */ } OpenFile; /* *---------------------------------------------------------------- * Data structures related to expressions. These are used only in * tclExpr.c. *---------------------------------------------------------------- */ /* * The data structure below defines a math function (e.g. sin or hypot) * for use in Tcl expressions. */ #define MAX_MATH_ARGS 5 typedef struct MathFunc { int numArgs; /* Number of arguments for function. */ Tcl_ValueType argTypes[MAX_MATH_ARGS]; /* Acceptable types for each argument. */ Tcl_MathProc *proc; /* Procedure that implements this function. */ ClientData clientData; /* Additional argument to pass to the function * when invoking it. */ } MathFunc; /* *---------------------------------------------------------------- * One of the following structures exists for each command in * an interpreter. The Tcl_Command opaque type actually refers * to these structures. *---------------------------------------------------------------- */ typedef struct Command { Tcl_HashEntry *hPtr; /* Pointer to the hash table entry in * interp->commandTable that refers to * this command. Used to get a command's * name from its Tcl_Command handle. */ Tcl_CmdProc *proc; /* Procedure to process command. */ ClientData clientData; /* Arbitrary value to pass to proc. */ Tcl_CmdDeleteProc *deleteProc; /* Procedure to invoke when deleting * command. */ ClientData deleteData; /* Arbitrary value to pass to deleteProc * (usually the same as clientData). */ } Command; /* *---------------------------------------------------------------- * This structure defines an interpreter, which is a collection of * commands plus other state information related to interpreting * commands, such as variable storage. Primary responsibility for * this data structure is in tclBasic.c, but almost every Tcl * source file uses something in here. *---------------------------------------------------------------- */ typedef struct Interp { /* * Note: the first three fields must match exactly the fields in * a Tcl_Interp struct (see tcl.h). If you change one, be sure to * change the other. */ char *result; /* Points to result returned by last * command. */ Tcl_FreeProc *freeProc; /* Zero means result is statically allocated. * If non-zero, gives address of procedure * to invoke to free the result. Must be * freed by Tcl_Eval before executing next * command. */ int errorLine; /* When TCL_ERROR is returned, this gives * the line number within the command where * the error occurred (1 means first line). */ Tcl_HashTable commandTable; /* Contains all of the commands currently * registered in this interpreter. Indexed * by strings; values have type (Command *). */ Tcl_HashTable mathFuncTable;/* Contains all of the math functions currently * defined for the interpreter. Indexed by * strings (function names); values have * type (MathFunc *). */ /* * Information related to procedures and variables. See tclProc.c * and tclvar.c for usage. */ Tcl_HashTable globalTable; /* Contains all global variables for * interpreter. */ int numLevels; /* Keeps track of how many nested calls to * Tcl_Eval are in progress for this * interpreter. It's used to delay deletion * of the table until all Tcl_Eval invocations * are completed. */ int maxNestingDepth; /* If numLevels exceeds this value then Tcl * assumes that infinite recursion has * occurred and it generates an error. */ CallFrame *framePtr; /* Points to top-most in stack of all nested * procedure invocations. NULL means there * are no active procedures. */ CallFrame *varFramePtr; /* Points to the call frame whose variables * are currently in use (same as framePtr * unless an "uplevel" command is being * executed). NULL means no procedure is * active or "uplevel 0" is being exec'ed. */ ActiveVarTrace *activeTracePtr; /* First in list of active traces for interp, * or NULL if no active traces. */ int returnCode; /* Completion code to return if current * procedure exits with a TCL_RETURN code. */ char *errorInfo; /* Value to store in errorInfo if returnCode * is TCL_ERROR. Malloc'ed, may be NULL */ char *errorCode; /* Value to store in errorCode if returnCode * is TCL_ERROR. Malloc'ed, may be NULL */ /* * Information related to history: */ int numEvents; /* Number of previously-executed commands * to retain. */ HistoryEvent *events; /* Array containing numEvents entries * (dynamically allocated). */ int curEvent; /* Index into events of place where current * (or most recent) command is recorded. */ int curEventNum; /* Event number associated with the slot * given by curEvent. */ HistoryRev *revPtr; /* First in list of pending revisions. */ char *historyFirst; /* First char. of current command executed * from history module or NULL if none. */ int revDisables; /* 0 means history revision OK; > 0 gives * a count of number of times revision has * been disabled. */ char *evalFirst; /* If TCL_RECORD_BOUNDS flag set, Tcl_Eval * sets this field to point to the first * char. of text from which the current * command came. Otherwise Tcl_Eval sets * this to NULL. */ char *evalLast; /* Similar to evalFirst, except points to * last character of current command. */ /* * Information used by Tcl_AppendResult to keep track of partial * results. See Tcl_AppendResult code for details. */ char *appendResult; /* Storage space for results generated * by Tcl_AppendResult. Malloc-ed. NULL * means not yet allocated. */ int appendAvl; /* Total amount of space available at * partialResult. */ int appendUsed; /* Number of non-null bytes currently * stored at partialResult. */ /* * A cache of compiled regular expressions. See Tcl_RegExpCompile * in tclUtil.c for details. */ #define NUM_REGEXPS 5 char *patterns[NUM_REGEXPS];/* Strings corresponding to compiled * regular expression patterns. NULL * means that this slot isn't used. * Malloc-ed. */ int patLengths[NUM_REGEXPS];/* Number of non-null characters in * corresponding entry in patterns. * -1 means entry isn't used. */ regexp *regexps[NUM_REGEXPS]; /* Compiled forms of above strings. Also * malloc-ed, or NULL if not in use yet. */ /* * Information used by Tcl_PrintDouble: */ char pdFormat[10]; /* Format string used by Tcl_PrintDouble. */ int pdPrec; /* Current precision (used to restore the * the tcl_precision variable after a bogus * value has been put into it). */ /* * Miscellaneous information: */ int cmdCount; /* Total number of times a command procedure * has been called for this interpreter. */ int noEval; /* Non-zero means no commands should actually * be executed: just parse only. Used in * expressions when the result is already * determined. */ int evalFlags; /* Flags to control next call to Tcl_Eval. * Normally zero, but may be set before * calling Tcl_Eval. See below for valid * values. */ char *termPtr; /* Character just after the last one in * a command. Set by Tcl_Eval before * returning. */ char *scriptFile; /* NULL means there is no nested source * command active; otherwise this points to * the name of the file being sourced (it's * not malloc-ed: it points to an argument * to Tcl_EvalFile. */ int flags; /* Various flag bits. See below. */ Trace *tracePtr; /* List of traces for this interpreter. */ DeleteCallback *deleteCallbackPtr; /* First in list of callbacks to invoke when * interpreter is deleted. */ char resultSpace[TCL_RESULT_SIZE+1]; /* Static space for storing small results. */ } Interp; /* * EvalFlag bits for Interp structures: * * TCL_BRACKET_TERM 1 means that the current script is terminated by * a close bracket rather than the end of the string. * TCL_RECORD_BOUNDS Tells Tcl_Eval to record information in the * evalFirst and evalLast fields for each command * executed directly from the string (top-level * commands and those from command substitution). * TCL_ALLOW_EXCEPTIONS 1 means it's OK for the script to terminate with * a code other than TCL_OK or TCL_ERROR; 0 means * codes other than these should be turned into errors. */ #define TCL_BRACKET_TERM 1 #define TCL_RECORD_BOUNDS 2 #define TCL_ALLOW_EXCEPTIONS 4 /* * Flag bits for Interp structures: * * DELETED: Non-zero means the interpreter has been deleted: * don't process any more commands for it, and destroy * the structure as soon as all nested invocations of * Tcl_Eval are done. * ERR_IN_PROGRESS: Non-zero means an error unwind is already in progress. * Zero means a command proc has been invoked since last * error occured. * ERR_ALREADY_LOGGED: Non-zero means information has already been logged * in $errorInfo for the current Tcl_Eval instance, * so Tcl_Eval needn't log it (used to implement the * "error message log" command). * ERROR_CODE_SET: Non-zero means that Tcl_SetErrorCode has been * called to record information for the current * error. Zero means Tcl_Eval must clear the * errorCode variable if an error is returned. * EXPR_INITIALIZED: 1 means initialization specific to expressions has * been carried out. */ #define DELETED 1 #define ERR_IN_PROGRESS 2 #define ERR_ALREADY_LOGGED 4 #define ERROR_CODE_SET 8 #define EXPR_INITIALIZED 0x10 /* * Default value for the pdPrec and pdFormat fields of interpreters: */ #define DEFAULT_PD_PREC 6 #define DEFAULT_PD_FORMAT "%g" /* *---------------------------------------------------------------- * Data structures related to command parsing. These are used in * tclParse.c and its clients. *---------------------------------------------------------------- */ /* * The following data structure is used by various parsing procedures * to hold information about where to store the results of parsing * (e.g. the substituted contents of a quoted argument, or the result * of a nested command). At any given time, the space available * for output is fixed, but a procedure may be called to expand the * space available if the current space runs out. */ typedef struct ParseValue { char *buffer; /* Address of first character in * output buffer. */ char *next; /* Place to store next character in * output buffer. */ char *end; /* Address of the last usable character * in the buffer. */ void (*expandProc) _ANSI_ARGS_((struct ParseValue *pvPtr, int needed)); /* Procedure to call when space runs out; * it will make more space. */ ClientData clientData; /* Arbitrary information for use of * expandProc. */ } ParseValue; /* * A table used to classify input characters to assist in parsing * Tcl commands. The table should be indexed with a signed character * using the CHAR_TYPE macro. The character may have a negative * value. */ extern char tclTypeTable[]; #define CHAR_TYPE(c) (tclTypeTable+128)[c] /* * Possible values returned by CHAR_TYPE: * * TCL_NORMAL - All characters that don't have special significance * to the Tcl language. * TCL_SPACE - Character is space, tab, or return. * TCL_COMMAND_END - Character is newline or null or semicolon or * close-bracket. * TCL_QUOTE - Character is a double-quote. * TCL_OPEN_BRACKET - Character is a "[". * TCL_OPEN_BRACE - Character is a "{". * TCL_CLOSE_BRACE - Character is a "}". * TCL_BACKSLASH - Character is a "\". * TCL_DOLLAR - Character is a "$". */ #define TCL_NORMAL 0 #define TCL_SPACE 1 #define TCL_COMMAND_END 2 #define TCL_QUOTE 3 #define TCL_OPEN_BRACKET 4 #define TCL_OPEN_BRACE 5 #define TCL_CLOSE_BRACE 6 #define TCL_BACKSLASH 7 #define TCL_DOLLAR 8 /* * Maximum number of levels of nesting permitted in Tcl commands (used * to catch infinite recursion). */ #define MAX_NESTING_DEPTH 1000 /* * The macro below is used to modify a "char" value (e.g. by casting * it to an unsigned character) so that it can be used safely with * macros such as isspace. */ #define UCHAR(c) ((unsigned char) (c)) /* * Given a size or address, the macro below "aligns" it to the machine's * memory unit size (e.g. an 8-byte boundary) so that anything can be * placed at the aligned address without fear of an alignment error. */ #define TCL_ALIGN(x) ((x + 7) & ~7) /* * Variables shared among Tcl modules but not used by the outside * world: */ extern int tclNumFiles; extern OpenFile ** tclOpenFiles; extern char * tclRegexpError; /* *---------------------------------------------------------------- * Procedures shared among Tcl modules but not used by the outside * world: *---------------------------------------------------------------- */ extern void panic(); extern void TclCopyAndCollapse _ANSI_ARGS_((int count, char *src, char *dst)); extern void TclDeleteVars _ANSI_ARGS_((Interp *iPtr, Tcl_HashTable *tablePtr)); extern void TclExpandParseValue _ANSI_ARGS_((ParseValue *pvPtr, int needed)); extern void TclExprFloatError _ANSI_ARGS_((Tcl_Interp *interp, double value)); extern int TclFindElement _ANSI_ARGS_((Tcl_Interp *interp, char *list, char **elementPtr, char **nextPtr, int *sizePtr, int *bracePtr)); extern Proc * TclFindProc _ANSI_ARGS_((Interp *iPtr, char *procName)); extern int TclGetFrame _ANSI_ARGS_((Tcl_Interp *interp, char *string, CallFrame **framePtrPtr)); extern int TclGetListIndex _ANSI_ARGS_((Tcl_Interp *interp, char *string, int *indexPtr)); extern Proc * TclIsProc _ANSI_ARGS_((Command *cmdPtr)); extern int TclNeedSpace _ANSI_ARGS_((char *start, char *end)); extern int TclParseBraces _ANSI_ARGS_((Tcl_Interp *interp, char *string, char **termPtr, ParseValue *pvPtr)); extern int TclParseNestedCmd _ANSI_ARGS_((Tcl_Interp *interp, char *string, int flags, char **termPtr, ParseValue *pvPtr)); extern int TclParseQuotes _ANSI_ARGS_((Tcl_Interp *interp, char *string, int termChar, int flags, char **termPtr, ParseValue *pvPtr)); extern int TclParseWords _ANSI_ARGS_((Tcl_Interp *interp, char *string, int flags, int maxWords, char **termPtr, int *argcPtr, char **argv, ParseValue *pvPtr)); extern char * TclPrecTraceProc _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, char *name1, char *name2, int flags)); extern void TclSetupEnv _ANSI_ARGS_((Tcl_Interp *interp)); extern int TclUpdateReturnInfo _ANSI_ARGS_((Interp *iPtr)); extern char * TclWordEnd _ANSI_ARGS_((char *start, int nested, int *semiPtr)); /* *---------------------------------------------------------------- * Command procedures in the generic core: *---------------------------------------------------------------- */ extern int Tcl_AppendCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); extern int Tcl_ArrayCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); extern int Tcl_BreakCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); extern int Tcl_CaseCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); extern int Tcl_CatchCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); extern int Tcl_ConcatCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); extern int Tcl_ContinueCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); extern int Tcl_ErrorCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); extern int Tcl_EvalCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); extern int Tcl_ExprCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); extern int Tcl_ForCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); extern int Tcl_ForeachCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); extern int Tcl_FormatCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); extern int Tcl_GlobalCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); extern int Tcl_HistoryCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); extern int Tcl_IfCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); extern int Tcl_IncrCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); extern int Tcl_InfoCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); extern int Tcl_JoinCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); extern int Tcl_LappendCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); extern int Tcl_LindexCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); extern int Tcl_LinsertCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); extern int Tcl_LlengthCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); extern int Tcl_ListCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); extern int Tcl_LrangeCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); extern int Tcl_LreplaceCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); extern int Tcl_LsearchCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); extern int Tcl_LsortCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); extern int Tcl_ProcCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); extern int Tcl_RegexpCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); extern int Tcl_RegsubCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); extern int Tcl_RenameCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); extern int Tcl_ReturnCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); extern int Tcl_ScanCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); extern int Tcl_SetCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); extern int Tcl_SplitCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); extern int Tcl_StringCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); extern int Tcl_SubstCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); extern int Tcl_SwitchCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); extern int Tcl_TraceCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); extern int Tcl_UnsetCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); extern int Tcl_UplevelCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); extern int Tcl_UpvarCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); extern int Tcl_WhileCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); extern int Tcl_Cmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); extern int Tcl_Cmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); /* *---------------------------------------------------------------- * Command procedures in the UNIX core: *---------------------------------------------------------------- */ extern int Tcl_CdCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); extern int Tcl_CloseCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); extern int Tcl_EofCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); extern int Tcl_ExecCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); extern int Tcl_ExitCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); extern int Tcl_FileCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); extern int Tcl_FlushCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); extern int Tcl_GetsCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); extern int Tcl_GlobCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); extern int Tcl_OpenCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); extern int Tcl_PutsCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); extern int Tcl_PidCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); extern int Tcl_PwdCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); extern int Tcl_ReadCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); extern int Tcl_SeekCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); extern int Tcl_SourceCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); extern int Tcl_TellCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); extern int Tcl_TimeCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, char **argv)); #endif /* _TCLINT */ #define MAX_NESTING_DEPTH 1000 /* * The macro below is used to modify a "char" value (e.g. by casting * it to an unsigned character) so that it can be used safely with * matcl7.4b4/tclPort.h010044400630510000012000000146220575444660000146410ustar00ousterstaff00002300000001/* * tclPort.h -- * * This header file handles porting issues that occur because * of differences between systems. It reads in UNIX-related * header files and sets up UNIX-related macros for Tcl's UNIX * core. It should be the only file that contains #ifdefs to * handle different flavors of UNIX. This file sets up the * union of all UNIX-related things needed by any of the Tcl * core files. This file depends on configuration #defines such * as NO_DIRENT_H that are set up by the "configure" script. * * Much of the material in this file was originally contributed * by Karl Lehenbauer, Mark Diekhans and Peter da Silva. * * Copyright (c) 1991-1994 The Regents of the University of California. * Copyright (c) 1994 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * @(#) tclPort.h 1.6 95/05/11 10:46:38 */ #ifndef _TCLPORT #define _TCLPORT #include #include #include #include #include #include #ifdef USE_DIRENT2_H # include "compat/dirent2.h" #else # ifdef NO_DIRENT_H # include "compat/dirent.h" # else # include # endif #endif #include #include #ifndef NO_SYS_TIME_H # include #else # include #endif #ifndef NO_SYS_WAIT_H # include #endif #ifdef HAVE_UNISTD_H # include #else # include "compat/unistd.h" #endif /* * Not all systems declare the errno variable in errno.h. so this * file does it explicitly. The list of system error messages also * isn't generally declared in a header file anywhere. */ extern int errno; /* * The type of the status returned by wait varies from UNIX system * to UNIX system. The macro below defines it: */ #ifdef AIX # define WAIT_STATUS_TYPE pid_t #else #ifndef NO_UNION_WAIT # define WAIT_STATUS_TYPE union wait #else # define WAIT_STATUS_TYPE int #endif #endif /* * Supply definitions for macros to query wait status, if not already * defined in header files above. */ #ifndef WIFEXITED # define WIFEXITED(stat) (((*((int *) &(stat))) & 0xff) == 0) #endif #ifndef WEXITSTATUS # define WEXITSTATUS(stat) (((*((int *) &(stat))) >> 8) & 0xff) #endif #ifndef WIFSIGNALED # define WIFSIGNALED(stat) (((*((int *) &(stat)))) && ((*((int *) &(stat))) == ((*((int *) &(stat))) & 0x00ff))) #endif #ifndef WTERMSIG # define WTERMSIG(stat) ((*((int *) &(stat))) & 0x7f) #endif #ifndef WIFSTOPPED # define WIFSTOPPED(stat) (((*((int *) &(stat))) & 0xff) == 0177) #endif #ifndef WSTOPSIG # define WSTOPSIG(stat) (((*((int *) &(stat))) >> 8) & 0xff) #endif /* * Define constants for waitpid() system call if they aren't defined * by a system header file. */ #ifndef WNOHANG # define WNOHANG 1 #endif #ifndef WUNTRACED # define WUNTRACED 2 #endif /* * Supply macros for seek offsets, if they're not already provided by * an include file. */ #ifndef SEEK_SET # define SEEK_SET 0 #endif #ifndef SEEK_CUR # define SEEK_CUR 1 #endif #ifndef SEEK_END # define SEEK_END 2 #endif /* * The stuff below is needed by the "time" command. If this * system has no gettimeofday call, then must use times and the * CLK_TCK #define (from sys/param.h) to compute elapsed time. * Unfortunately, some systems only have HZ and no CLK_TCK, and * some might not even have HZ. */ #ifdef NO_GETTOD # include # include # ifndef CLK_TCK # ifdef HZ # define CLK_TCK HZ # else # define CLK_TCK 60 # endif # endif #else # ifdef HAVE_BSDGETTIMEOFDAY # define gettimeofday BSDgettimeofday # endif #endif #ifdef GETTOD_NOT_DECLARED EXTERN int gettimeofday _ANSI_ARGS_((struct timeval *tp, struct timezone *tzp)); #endif /* * Define access mode constants if they aren't already defined. */ #ifndef F_OK # define F_OK 00 #endif #ifndef X_OK # define X_OK 01 #endif #ifndef W_OK # define W_OK 02 #endif #ifndef R_OK # define R_OK 04 #endif /* * Define FD_CLOEEXEC (the close-on-exec flag bit) if it isn't * already defined. */ #ifndef FD_CLOEXEC # define FD_CLOEXEC 1 #endif /* * On systems without symbolic links (i.e. S_IFLNK isn't defined) * define "lstat" to use "stat" instead. */ #ifndef S_IFLNK # define lstat stat #endif /* * Define macros to query file type bits, if they're not already * defined. */ #ifndef S_ISREG # ifdef S_IFREG # define S_ISREG(m) (((m) & S_IFMT) == S_IFREG) # else # define S_ISREG(m) 0 # endif # endif #ifndef S_ISDIR # ifdef S_IFDIR # define S_ISDIR(m) (((m) & S_IFMT) == S_IFDIR) # else # define S_ISDIR(m) 0 # endif # endif #ifndef S_ISCHR # ifdef S_IFCHR # define S_ISCHR(m) (((m) & S_IFMT) == S_IFCHR) # else # define S_ISCHR(m) 0 # endif # endif #ifndef S_ISBLK # ifdef S_IFBLK # define S_ISBLK(m) (((m) & S_IFMT) == S_IFBLK) # else # define S_ISBLK(m) 0 # endif # endif #ifndef S_ISFIFO # ifdef S_IFIFO # define S_ISFIFO(m) (((m) & S_IFMT) == S_IFIFO) # else # define S_ISFIFO(m) 0 # endif # endif #ifndef S_ISLNK # ifdef S_IFLNK # define S_ISLNK(m) (((m) & S_IFMT) == S_IFLNK) # else # define S_ISLNK(m) 0 # endif # endif #ifndef S_ISSOCK # ifdef S_IFSOCK # define S_ISSOCK(m) (((m) & S_IFMT) == S_IFSOCK) # else # define S_ISSOCK(m) 0 # endif # endif /* * Make sure that MAXPATHLEN is defined. */ #ifndef MAXPATHLEN # ifdef PATH_MAX # define MAXPATHLEN PATH_MAX # else # define MAXPATHLEN 2048 # endif #endif /* * Make sure that L_tmpnam is defined. */ #ifndef L_tmpnam # define L_tmpnam 100 #endif /* * Substitute Tcl's own versions for several system calls. The * Tcl versions retry automatically if interrupted by signals. * (see tclUnixUtil.c). */ #define open(a,b,c) TclOpen(a,b,c) #define read(a,b,c) TclRead(a,b,c) #define waitpid(a,b,c) TclWaitpid(a,b,c) #define write(a,b,c) TclWrite(a,b,c) EXTERN int TclOpen _ANSI_ARGS_((char *path, int oflag, int mode)); EXTERN int TclRead _ANSI_ARGS_((int fd, VOID *buf, size_t numBytes)); EXTERN int TclWaitpid _ANSI_ARGS_((pid_t pid, int *statPtr, int options)); EXTERN int TclWrite _ANSI_ARGS_((int fd, VOID *buf, size_t numBytes)); /* * Variables provided by the C library: */ #if defined(_sgi) || defined(__sgi) #define environ _environ #endif extern char **environ; #endif /* _TCLPORT */ ek offsets, if they're not already provided by * an include file. */ #ifndef SEEK_SET # define SEEK_SET 0tcl7.4b4/patchlevel.h010044400630510000012000000016070574502012000153210ustar00ousterstaff00002300000001/* * patchlevel.h -- * * This file does nothing except define a "patch level" for Tcl. * The patch level has the form "X.YpZ" where X.Y is the base * release, and Z is a serial number that is used to sequence * patches for a given release. Thus 7.4p1 is the first patch * to release 7.4, 7.4p2 is the patch that follows 7.4p1, and * so on. The "pZ" is omitted in an original new release, and * it is replaced with "bZ" for beta releases. The patch level * ensures that patches are applied in the correct order and only * to appropriate sources. * * Copyright (c) 1993-1994 The Regents of the University of California. * Copyright (c) 1994-1995 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * @(#) patchlevel.h 1.8 95/04/18 13:25:51 */ #define TCL_PATCH_LEVEL "7.4b4" tcl7.4b4/configure010077500630510000012000002007260577032342400147520ustar00ousterstaff00002300000001#! /bin/sh # Guess values for system-dependent variables and create Makefiles. # Generated automatically using autoconf version 2.2 # Copyright (C) 1992, 1993, 1994 Free Software Foundation, Inc. # # This configure script is free software; the Free Software Foundation # gives unlimited permission to copy, distribute and modify it. # Defaults: ac_help= ac_default_prefix=/usr/local # Any additions from configure.in: # Initialize some variables set by options. # The variables have the same names as the options, with # dashes changed to underlines. build=NONE cache_file=./config.cache exec_prefix=NONE host=NONE no_create= nonopt=NONE no_recursion= prefix=NONE program_prefix=NONE program_suffix=NONE program_transform_name=s,x,x, silent= site= srcdir= target=NONE verbose= x_includes=NONE x_libraries=NONE # Initialize some other variables. subdirs= ac_prev= for ac_option do # If the previous option needs an argument, assign it. if test -n "$ac_prev"; then eval "$ac_prev=\$ac_option" ac_prev= continue fi case "$ac_option" in -*=*) ac_optarg=`echo "$ac_option" | sed 's/[-_a-zA-Z0-9]*=//'` ;; *) ac_optarg= ;; esac # Accept the important Cygnus configure options, so we can diagnose typos. case "$ac_option" in -build | --build | --buil | --bui | --bu | --b) ac_prev=build ;; -build=* | --build=* | --buil=* | --bui=* | --bu=* | --b=*) build="$ac_optarg" ;; -cache-file | --cache-file | --cache-fil | --cache-fi \ | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c) ac_prev=cache_file ;; -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \ | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*) cache_file="$ac_optarg" ;; -disable-* | --disable-*) ac_feature=`echo $ac_option|sed -e 's/-*disable-//'` # Reject names that are not valid shell variable names. if test -n "`echo $ac_feature| sed 's/[-a-zA-Z0-9_]//g'`"; then { echo "configure: error: $ac_feature: invalid feature name" 1>&2; exit 1; } fi ac_feature=`echo $ac_feature| sed 's/-/_/g'` eval "enable_${ac_feature}=no" ;; -enable-* | --enable-*) ac_feature=`echo $ac_option|sed -e 's/-*enable-//' -e 's/=.*//'` # Reject names that are not valid shell variable names. if test -n "`echo $ac_feature| sed 's/[-_a-zA-Z0-9]//g'`"; then { echo "configure: error: $ac_feature: invalid feature name" 1>&2; exit 1; } fi ac_feature=`echo $ac_feature| sed 's/-/_/g'` case "$ac_option" in *=*) ;; *) ac_optarg=yes ;; esac eval "enable_${ac_feature}='$ac_optarg'" ;; -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \ | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \ | --exec | --exe | --ex) ac_prev=exec_prefix ;; -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \ | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \ | --exec=* | --exe=* | --ex=*) exec_prefix="$ac_optarg" ;; -gas | --gas | --ga | --g) # Obsolete; use --with-gas. with_gas=yes ;; -help | --help | --hel | --he) # Omit some internal or obsolete options to make the list less imposing. # This message is too long to be a string in the A/UX 3.1 sh. cat << EOF Usage: configure [options] [host] Options: [defaults in brackets after descriptions] Configuration: --cache-file=FILE cache test results in FILE --help print this message --no-create do not create output files --quiet, --silent do not print \`checking...' messages --version print the version of autoconf that created configure Directory and file names: --prefix=PREFIX install architecture-independent files in PREFIX [$ac_default_prefix] --exec-prefix=PREFIX install architecture-dependent files in PREFIX [same as prefix] --srcdir=DIR find the sources in DIR [configure dir or ..] --program-prefix=PREFIX prepend PREFIX to installed program names --program-suffix=SUFFIX append SUFFIX to installed program names --program-transform-name=PROGRAM run sed PROGRAM on installed program names Host type: --build=BUILD configure for building on BUILD [BUILD=HOST] --host=HOST configure for HOST [guessed] --target=TARGET configure for TARGET [TARGET=HOST] Features and packages: --disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no) --enable-FEATURE[=ARG] include FEATURE [ARG=yes] --with-PACKAGE[=ARG] use PACKAGE [ARG=yes] --without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no) --x-includes=DIR X include files are in DIR --x-libraries=DIR X library files are in DIR --enable and --with options recognized:$ac_help EOF exit 0 ;; -host | --host | --hos | --ho) ac_prev=host ;; -host=* | --host=* | --hos=* | --ho=*) host="$ac_optarg" ;; -nfp | --nfp | --nf) # Obsolete; use --without-fp. with_fp=no ;; -no-create | --no-create | --no-creat | --no-crea | --no-cre \ | --no-cr | --no-c) no_create=yes ;; -no-recursion | --no-recursion | --no-recursio | --no-recursi \ | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) no_recursion=yes ;; -prefix | --prefix | --prefi | --pref | --pre | --pr | --p) ac_prev=prefix ;; -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*) prefix="$ac_optarg" ;; -program-prefix | --program-prefix | --program-prefi | --program-pref \ | --program-pre | --program-pr | --program-p) ac_prev=program_prefix ;; -program-prefix=* | --program-prefix=* | --program-prefi=* \ | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*) program_prefix="$ac_optarg" ;; -program-suffix | --program-suffix | --program-suffi | --program-suff \ | --program-suf | --program-su | --program-s) ac_prev=program_suffix ;; -program-suffix=* | --program-suffix=* | --program-suffi=* \ | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*) program_suffix="$ac_optarg" ;; -program-transform-name | --program-transform-name \ | --program-transform-nam | --program-transform-na \ | --program-transform-n | --program-transform- \ | --program-transform | --program-transfor \ | --program-transfo | --program-transf \ | --program-trans | --program-tran \ | --progr-tra | --program-tr | --program-t) ac_prev=program_transform_name ;; -program-transform-name=* | --program-transform-name=* \ | --program-transform-nam=* | --program-transform-na=* \ | --program-transform-n=* | --program-transform-=* \ | --program-transform=* | --program-transfor=* \ | --program-transfo=* | --program-transf=* \ | --program-trans=* | --program-tran=* \ | --progr-tra=* | --program-tr=* | --program-t=*) program_transform_name="$ac_optarg" ;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil) silent=yes ;; -site | --site | --sit) ac_prev=site ;; -site=* | --site=* | --sit=*) site="$ac_optarg" ;; -srcdir | --srcdir | --srcdi | --srcd | --src | --sr) ac_prev=srcdir ;; -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*) srcdir="$ac_optarg" ;; -target | --target | --targe | --targ | --tar | --ta | --t) ac_prev=target ;; -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*) target="$ac_optarg" ;; -v | -verbose | --verbose | --verbos | --verbo | --verb) verbose=yes ;; -version | --version | --versio | --versi | --vers) echo "configure generated by autoconf version 2.2" exit 0 ;; -with-* | --with-*) ac_package=`echo $ac_option|sed -e 's/-*with-//' -e 's/=.*//'` # Reject names that are not valid shell variable names. if test -n "`echo $ac_package| sed 's/[-_a-zA-Z0-9]//g'`"; then { echo "configure: error: $ac_package: invalid package name" 1>&2; exit 1; } fi ac_package=`echo $ac_package| sed 's/-/_/g'` case "$ac_option" in *=*) ;; *) ac_optarg=yes ;; esac eval "with_${ac_package}='$ac_optarg'" ;; -without-* | --without-*) ac_package=`echo $ac_option|sed -e 's/-*without-//'` # Reject names that are not valid shell variable names. if test -n "`echo $ac_package| sed 's/[-a-zA-Z0-9_]//g'`"; then { echo "configure: error: $ac_package: invalid package name" 1>&2; exit 1; } fi ac_package=`echo $ac_package| sed 's/-/_/g'` eval "with_${ac_package}=no" ;; --x) # Obsolete; use --with-x. with_x=yes ;; -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \ | --x-incl | --x-inc | --x-in | --x-i) ac_prev=x_includes ;; -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \ | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*) x_includes="$ac_optarg" ;; -x-libraries | --x-libraries | --x-librarie | --x-librari \ | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l) ac_prev=x_libraries ;; -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \ | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*) x_libraries="$ac_optarg" ;; -*) { echo "configure: error: $ac_option: invalid option; use --help to show usage" 1>&2; exit 1; } ;; *) if test -n "`echo $ac_option| sed 's/[-a-z0-9.]//g'`"; then echo "configure: warning: $ac_option: invalid host type" 1>&2 fi if test "x$nonopt" != xNONE; then { echo "configure: error: can only configure for one host and one target at a time" 1>&2; exit 1; } fi nonopt="$ac_option" ;; esac done if test -n "$ac_prev"; then { echo "configure: error: missing argument to --`echo $ac_prev | sed 's/_/-/g'`" 1>&2; exit 1; } fi trap 'rm -fr conftest* confdefs* core core.* *.core $ac_clean_files; exit 1' 1 2 15 # File descriptor usage: # 0 standard input # 1 file creation # 2 errors and warnings # 3 some systems may open it to /dev/tty # 4 used on the Kubota Titan # 6 checking for... messages and results # 5 compiler messages saved in config.log if test "$silent" = yes; then exec 6>/dev/null else exec 6>&1 fi exec 5>./config.log echo "\ This file contains any messages produced by compilers while running configure, to aid debugging if configure makes a mistake. " 1>&5 # Strip out --no-create and --no-recursion so they do not pile up. # Also quote any args containing shell metacharacters. ac_configure_args= for ac_arg do case "$ac_arg" in -no-create | --no-create | --no-creat | --no-crea | --no-cre \ | --no-cr | --no-c) ;; -no-recursion | --no-recursion | --no-recursio | --no-recursi \ | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) ;; *" "*|*" "*|*[\[\]\~\#\$\^\&\*\(\)\{\}\\\|\;\<\>\?]*) ac_configure_args="$ac_configure_args '$ac_arg'" ;; *) ac_configure_args="$ac_configure_args $ac_arg" ;; esac done # NLS nuisances. # Only set LANG and LC_ALL to C if already set. # These must not be set unconditionally because not all systems understand # e.g. LANG=C (notably SCO). if test "${LC_ALL+set}" = set; then LC_ALL=C; export LC_ALL; fi if test "${LANG+set}" = set; then LANG=C; export LANG; fi # confdefs.h avoids OS command line length limits that DEFS can exceed. rm -rf conftest* confdefs.h # AIX cpp loses on an empty file, so make sure it contains at least a newline. echo > confdefs.h # A filename unique to this package, relative to the directory that # configure is in, which we can look for to find out if srcdir is correct. ac_unique_file=tcl.h # Find the source files, if location was not specified. if test -z "$srcdir"; then ac_srcdir_defaulted=yes # Try the directory containing this script, then its parent. ac_prog=$0 ac_confdir=`echo $ac_prog|sed 's%/[^/][^/]*$%%'` test "x$ac_confdir" = "x$ac_prog" && ac_confdir=. srcdir=$ac_confdir if test ! -r $srcdir/$ac_unique_file; then srcdir=.. fi else ac_srcdir_defaulted=no fi if test ! -r $srcdir/$ac_unique_file; then if test "$ac_srcdir_defaulted" = yes; then { echo "configure: error: can not find sources in $ac_confdir or .." 1>&2; exit 1; } else { echo "configure: error: can not find sources in $srcdir" 1>&2; exit 1; } fi fi srcdir=`echo "${srcdir}" | sed 's%\([^/]\)/*$%\1%'` # Prefer explicitly selected file to automatically selected ones. if test -z "$CONFIG_SITE"; then if test "x$prefix" != xNONE; then CONFIG_SITE="$prefix/share/config.site $prefix/etc/config.site" else CONFIG_SITE="$ac_default_prefix/share/config.site $ac_default_prefix/etc/config.site" fi fi for ac_site_file in $CONFIG_SITE; do if test -r "$ac_site_file"; then echo "loading site script $ac_site_file" . "$ac_site_file" fi done if test -r "$cache_file"; then echo "loading cache $cache_file" . $cache_file else echo "creating cache $cache_file" > $cache_file fi ac_ext=c # CFLAGS is not in ac_cpp because -g, -O, etc. are not valid cpp options. ac_cpp='$CPP $CPPFLAGS' ac_compile='${CC-cc} conftest.$ac_ext $CFLAGS $CPPFLAGS -c 1>&5 2>&5' ac_link='${CC-cc} conftest.$ac_ext $CFLAGS $CPPFLAGS $LDFLAGS -o conftest $LIBS 1>&5 2>&5' if (echo "testing\c"; echo 1,2,3) | grep c >/dev/null; then # Stardent Vistra SVR4 grep lacks -e, says ghazi@caip.rutgers.edu. if (echo -n testing; echo 1,2,3) | sed s/-n/xn/ | grep xn >/dev/null; then ac_n= ac_c=' ' ac_t=' ' else ac_n=-n ac_c= ac_t= fi else ac_n= ac_c='\c' ac_t= fi # @(#) configure.in 1.14 95/05/22 08:01:27 ac_aux_dir= for ac_dir in $srcdir $srcdir/.. $srcdir/../..; do if test -f $ac_dir/install-sh; then ac_aux_dir=$ac_dir ac_install_sh="$ac_aux_dir/install-sh -c" break elif test -f $ac_dir/install.sh; then ac_aux_dir=$ac_dir ac_install_sh="$ac_aux_dir/install.sh -c" break fi done if test -z "$ac_aux_dir"; then { echo "configure: error: can not find install-sh or install.sh in $srcdir $srcdir/.. $srcdir/../.." 1>&2; exit 1; } fi ac_config_guess=$ac_aux_dir/config.guess ac_config_sub=$ac_aux_dir/config.sub ac_configure=$ac_aux_dir/configure # This should be Cygnus configure. # Find a good install program. We prefer a C program (faster), # so one script is as good as another. But avoid the broken or # incompatible versions: # SysV /etc/install, /usr/sbin/install # SunOS /usr/etc/install # IRIX /sbin/install # AIX /bin/install # AFS /usr/afsws/bin/install, which mishandles nonexistent args # SVR4 /usr/ucb/install, which tries to use the nonexistent group "staff" # ./install, which can be erroneously created by make from ./install.sh. echo $ac_n "checking for a BSD compatible install""... $ac_c" 1>&6 if test -z "$INSTALL"; then if eval "test \"`echo '$''{'ac_cv_path_install'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else IFS="${IFS= }"; ac_save_ifs="$IFS"; IFS="${IFS}:" for ac_dir in $PATH; do # Account for people who put trailing slashes in PATH elements. case "$ac_dir/" in /|./|.//|/etc/*|/usr/sbin/*|/usr/etc/*|/sbin/*|/usr/afsws/bin/*|/usr/ucb/*) ;; *) # OSF1 and SCO ODT 3.0 have their own names for install. for ac_prog in ginstall installbsd scoinst install; do if test -f $ac_dir/$ac_prog; then if test $ac_prog = install && grep dspmsg $ac_dir/$ac_prog >/dev/null 2>&1; then # AIX install. It has an incompatible calling convention. # OSF/1 installbsd also uses dspmsg, but is usable. : else ac_cv_path_install="$ac_dir/$ac_prog -c" break 2 fi fi done ;; esac done IFS="$ac_save_ifs" # As a last resort, use the slow shell script. test -z "$ac_cv_path_install" && ac_cv_path_install="$ac_install_sh" fi INSTALL="$ac_cv_path_install" fi echo "$ac_t""$INSTALL" 1>&6 # Use test -z because SunOS4 sh mishandles braces in ${var-val}. # It thinks the first close brace ends the variable substitution. test -z "$INSTALL_PROGRAM" && INSTALL_PROGRAM='${INSTALL}' test -z "$INSTALL_DATA" && INSTALL_DATA='${INSTALL} -m 644' # Extract the first word of "ranlib", so it can be a program name with args. set dummy ranlib; ac_word=$2 echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 if eval "test \"`echo '$''{'ac_cv_prog_RANLIB'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else if test -n "$RANLIB"; then ac_cv_prog_RANLIB="$RANLIB" # Let the user override the test. else IFS="${IFS= }"; ac_save_ifs="$IFS"; IFS="${IFS}:" for ac_dir in $PATH; do test -z "$ac_dir" && ac_dir=. if test -f $ac_dir/$ac_word; then ac_cv_prog_RANLIB="ranlib" break fi done IFS="$ac_save_ifs" test -z "$ac_cv_prog_RANLIB" && ac_cv_prog_RANLIB=":" fi fi RANLIB="$ac_cv_prog_RANLIB" if test -n "$RANLIB"; then echo "$ac_t""$RANLIB" 1>&6 else echo "$ac_t""no" 1>&6 fi if test "x$prefix" = xNONE; then echo $ac_n "checking for prefix by ""... $ac_c" 1>&6 # Extract the first word of "tclsh", so it can be a program name with args. set dummy tclsh; ac_word=$2 echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 if eval "test \"`echo '$''{'ac_cv_path_TCLSH'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else case "$TCLSH" in /*) ac_cv_path_TCLSH="$TCLSH" # Let the user override the test with a path. ;; *) IFS="${IFS= }"; ac_save_ifs="$IFS"; IFS="${IFS}:" for ac_dir in $PATH; do test -z "$ac_dir" && ac_dir=. if test -f $ac_dir/$ac_word; then ac_cv_path_TCLSH="$ac_dir/$ac_word" break fi done IFS="$ac_save_ifs" ;; esac fi TCLSH="$ac_cv_path_TCLSH" if test -n "$TCLSH"; then echo "$ac_t""$TCLSH" 1>&6 else echo "$ac_t""no" 1>&6 fi if test -n "$ac_cv_path_TCLSH"; then prefix=`echo $ac_cv_path_TCLSH|sed 's%/[^/][^/]*//*[^/][^/]*$%%'` fi fi # If we cannot run a trivial program, we must be cross compiling. echo $ac_n "checking whether cross-compiling""... $ac_c" 1>&6 if eval "test \"`echo '$''{'ac_cv_c_cross'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else if test "$cross_compiling" = yes; then ac_cv_c_cross=yes else cat > conftest.$ac_ext </dev/null; then ac_cv_c_cross=no else ac_cv_c_cross=yes fi fi rm -fr conftest* fi cross_compiling=$ac_cv_c_cross echo "$ac_t""$ac_cv_c_cross" 1>&6 CC=${CC-cc} #-------------------------------------------------------------------- # Supply substitutes for missing POSIX library procedures, or # set flags so Tcl uses alternate procedures. #-------------------------------------------------------------------- for ac_func in getcwd opendir strerror strstr do echo $ac_n "checking for $ac_func""... $ac_c" 1>&6 if eval "test \"`echo '$''{'ac_cv_func_$ac_func'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < /* Override any gcc2 internal prototype to avoid an error. */ char $ac_func(); int main() { return 0; } int t() { /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined (__stub_$ac_func) || defined (__stub___$ac_func) choke me #else $ac_func(); #endif ; return 0; } EOF if eval $ac_link; then rm -rf conftest* eval "ac_cv_func_$ac_func=yes" else rm -rf conftest* eval "ac_cv_func_$ac_func=no" fi rm -f conftest* fi if eval "test \"`echo '$ac_cv_func_'$ac_func`\" = yes"; then echo "$ac_t""yes" 1>&6 : else echo "$ac_t""no" 1>&6 LIBOBJS="$LIBOBJS ${ac_func}.o" fi done for ac_func in strtol tmpnam waitpid do echo $ac_n "checking for $ac_func""... $ac_c" 1>&6 if eval "test \"`echo '$''{'ac_cv_func_$ac_func'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < /* Override any gcc2 internal prototype to avoid an error. */ char $ac_func(); int main() { return 0; } int t() { /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined (__stub_$ac_func) || defined (__stub___$ac_func) choke me #else $ac_func(); #endif ; return 0; } EOF if eval $ac_link; then rm -rf conftest* eval "ac_cv_func_$ac_func=yes" else rm -rf conftest* eval "ac_cv_func_$ac_func=no" fi rm -f conftest* fi if eval "test \"`echo '$ac_cv_func_'$ac_func`\" = yes"; then echo "$ac_t""yes" 1>&6 : else echo "$ac_t""no" 1>&6 LIBOBJS="$LIBOBJS ${ac_func}.o" fi done echo $ac_n "checking for getwd""... $ac_c" 1>&6 if eval "test \"`echo '$''{'ac_cv_func_getwd'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < /* Override any gcc2 internal prototype to avoid an error. */ char getwd(); int main() { return 0; } int t() { /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined (__stub_getwd) || defined (__stub___getwd) choke me #else getwd(); #endif ; return 0; } EOF if eval $ac_link; then rm -rf conftest* eval "ac_cv_func_getwd=yes" else rm -rf conftest* eval "ac_cv_func_getwd=no" fi rm -f conftest* fi if eval "test \"`echo '$ac_cv_func_'getwd`\" = yes"; then echo "$ac_t""yes" 1>&6 : else echo "$ac_t""no" 1>&6 cat >> confdefs.h <<\EOF #define NO_GETWD 1 EOF fi echo $ac_n "checking for wait3""... $ac_c" 1>&6 if eval "test \"`echo '$''{'ac_cv_func_wait3'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < /* Override any gcc2 internal prototype to avoid an error. */ char wait3(); int main() { return 0; } int t() { /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined (__stub_wait3) || defined (__stub___wait3) choke me #else wait3(); #endif ; return 0; } EOF if eval $ac_link; then rm -rf conftest* eval "ac_cv_func_wait3=yes" else rm -rf conftest* eval "ac_cv_func_wait3=no" fi rm -f conftest* fi if eval "test \"`echo '$ac_cv_func_'wait3`\" = yes"; then echo "$ac_t""yes" 1>&6 : else echo "$ac_t""no" 1>&6 cat >> confdefs.h <<\EOF #define NO_WAIT3 1 EOF fi #-------------------------------------------------------------------- # On a few very rare systems, all of the libm.a stuff is # already in libc.a. Set compiler flags accordingly. # Also, Linux requires the "ieee" library for math to work # right. #-------------------------------------------------------------------- echo $ac_n "checking for sin""... $ac_c" 1>&6 if eval "test \"`echo '$''{'ac_cv_func_sin'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < /* Override any gcc2 internal prototype to avoid an error. */ char sin(); int main() { return 0; } int t() { /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined (__stub_sin) || defined (__stub___sin) choke me #else sin(); #endif ; return 0; } EOF if eval $ac_link; then rm -rf conftest* eval "ac_cv_func_sin=yes" else rm -rf conftest* eval "ac_cv_func_sin=no" fi rm -f conftest* fi if eval "test \"`echo '$ac_cv_func_'sin`\" = yes"; then echo "$ac_t""yes" 1>&6 MATH_LIBS="" else echo "$ac_t""no" 1>&6 MATH_LIBS="-lm" fi echo $ac_n "checking for -lieee""... $ac_c" 1>&6 if eval "test \"`echo '$''{'ac_cv_lib_ieee'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else ac_save_LIBS="$LIBS" LIBS="-lieee $LIBS" cat > conftest.$ac_ext <&6 MATH_LIBS="$MATH_LIBS -lieee" else echo "$ac_t""no" 1>&6 fi #-------------------------------------------------------------------- # Supply substitutes for missing POSIX header files. Special # notes: # - Sprite's dirent.h exists but is bogus. # - stdlib.h doesn't define strtol, strtoul, or # strtod insome versions of SunOS # - some versions of string.h don't declare procedures such # as strstr #-------------------------------------------------------------------- echo $ac_n "checking how to run the C preprocessor""... $ac_c" 1>&6 # On Suns, sometimes $CPP names a directory. if test -n "$CPP" && test -d "$CPP"; then CPP= fi if test -z "$CPP"; then if eval "test \"`echo '$''{'ac_cv_prog_CPP'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else # This must be in double quotes, not single quotes, because CPP may get # substituted into the Makefile and "${CC-cc}" will confuse make. CPP="${CC-cc} -E" # On the NeXT, cc -E runs the code through the compiler's parser, # not just through cpp. cat > conftest.$ac_ext < Syntax Error EOF eval "$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then : else echo "$ac_err" >&5 rm -rf conftest* CPP="${CC-cc} -E -traditional-cpp" cat > conftest.$ac_ext < Syntax Error EOF eval "$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then : else echo "$ac_err" >&5 rm -rf conftest* CPP=/lib/cpp fi rm -f conftest* fi rm -f conftest* ac_cv_prog_CPP="$CPP" fi fi CPP="$ac_cv_prog_CPP" echo "$ac_t""$CPP" 1>&6 for ac_hdr in unistd.h do ac_safe=`echo "$ac_hdr" | tr './\055' '___'` echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6 if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < EOF eval "$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* eval "ac_cv_header_$ac_safe=yes" else echo "$ac_err" >&5 rm -rf conftest* eval "ac_cv_header_$ac_safe=no" fi rm -f conftest* fi if eval "test \"`echo '$ac_cv_header_'$ac_safe`\" = yes"; then echo "$ac_t""yes" 1>&6 ac_tr_hdr=HAVE_`echo $ac_hdr | tr '[a-z]./\055' '[A-Z]___'` cat >> confdefs.h <&6 fi done echo $ac_n "checking dirent.h""... $ac_c" 1>&6 cat > conftest.$ac_ext < #include int main() { return 0; } int t() { #ifndef _POSIX_SOURCE # ifdef __Lynx__ /* * Generate compilation error to make the test fail: Lynx headers * are only valid if really in the POSIX environment. */ missing_procedure(); # endif #endif DIR *d; struct dirent *entryPtr; char *p; d = opendir("foobar"); entryPtr = readdir(d); p = entryPtr->d_name; closedir(d); ; return 0; } EOF if eval $ac_link; then rm -rf conftest* tcl_ok=yes else rm -rf conftest* tcl_ok=no fi rm -f conftest* cat > conftest.$ac_ext < EOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | egrep "Sprite version.* NOT POSIX" >/dev/null 2>&1; then rm -rf conftest* tcl_ok=no fi rm -f conftest* if test $tcl_ok = no; then cat >> confdefs.h <<\EOF #define NO_DIRENT_H 1 EOF fi echo "$ac_t""$tcl_ok" 1>&6 ac_safe=`echo "errno.h" | tr './\055' '___'` echo $ac_n "checking for errno.h""... $ac_c" 1>&6 if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < EOF eval "$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* eval "ac_cv_header_$ac_safe=yes" else echo "$ac_err" >&5 rm -rf conftest* eval "ac_cv_header_$ac_safe=no" fi rm -f conftest* fi if eval "test \"`echo '$ac_cv_header_'$ac_safe`\" = yes"; then echo "$ac_t""yes" 1>&6 : else echo "$ac_t""no" 1>&6 cat >> confdefs.h <<\EOF #define NO_ERRNO_H 1 EOF fi ac_safe=`echo "float.h" | tr './\055' '___'` echo $ac_n "checking for float.h""... $ac_c" 1>&6 if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < EOF eval "$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* eval "ac_cv_header_$ac_safe=yes" else echo "$ac_err" >&5 rm -rf conftest* eval "ac_cv_header_$ac_safe=no" fi rm -f conftest* fi if eval "test \"`echo '$ac_cv_header_'$ac_safe`\" = yes"; then echo "$ac_t""yes" 1>&6 : else echo "$ac_t""no" 1>&6 cat >> confdefs.h <<\EOF #define NO_FLOAT_H 1 EOF fi ac_safe=`echo "limits.h" | tr './\055' '___'` echo $ac_n "checking for limits.h""... $ac_c" 1>&6 if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < EOF eval "$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* eval "ac_cv_header_$ac_safe=yes" else echo "$ac_err" >&5 rm -rf conftest* eval "ac_cv_header_$ac_safe=no" fi rm -f conftest* fi if eval "test \"`echo '$ac_cv_header_'$ac_safe`\" = yes"; then echo "$ac_t""yes" 1>&6 : else echo "$ac_t""no" 1>&6 cat >> confdefs.h <<\EOF #define NO_LIMITS_H 1 EOF fi ac_safe=`echo "stdlib.h" | tr './\055' '___'` echo $ac_n "checking for stdlib.h""... $ac_c" 1>&6 if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < EOF eval "$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* eval "ac_cv_header_$ac_safe=yes" else echo "$ac_err" >&5 rm -rf conftest* eval "ac_cv_header_$ac_safe=no" fi rm -f conftest* fi if eval "test \"`echo '$ac_cv_header_'$ac_safe`\" = yes"; then echo "$ac_t""yes" 1>&6 tcl_ok=1 else echo "$ac_t""no" 1>&6 tcl_ok=0 fi cat > conftest.$ac_ext < EOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | egrep "strtol" >/dev/null 2>&1; then : else rm -rf conftest* tcl_ok=0 fi rm -f conftest* cat > conftest.$ac_ext < EOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | egrep "strtoul" >/dev/null 2>&1; then : else rm -rf conftest* tcl_ok=0 fi rm -f conftest* cat > conftest.$ac_ext < EOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | egrep "strtod" >/dev/null 2>&1; then : else rm -rf conftest* tcl_ok=0 fi rm -f conftest* if test $tcl_ok = 0; then cat >> confdefs.h <<\EOF #define NO_STDLIB_H 1 EOF fi ac_safe=`echo "string.h" | tr './\055' '___'` echo $ac_n "checking for string.h""... $ac_c" 1>&6 if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < EOF eval "$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* eval "ac_cv_header_$ac_safe=yes" else echo "$ac_err" >&5 rm -rf conftest* eval "ac_cv_header_$ac_safe=no" fi rm -f conftest* fi if eval "test \"`echo '$ac_cv_header_'$ac_safe`\" = yes"; then echo "$ac_t""yes" 1>&6 tcl_ok=1 else echo "$ac_t""no" 1>&6 tcl_ok=0 fi cat > conftest.$ac_ext < EOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | egrep "strstr" >/dev/null 2>&1; then : else rm -rf conftest* tcl_ok=0 fi rm -f conftest* cat > conftest.$ac_ext < EOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | egrep "strerror" >/dev/null 2>&1; then : else rm -rf conftest* tcl_ok=0 fi rm -f conftest* if test $tcl_ok = 0; then cat >> confdefs.h <<\EOF #define NO_STRING_H 1 EOF fi ac_safe=`echo "sys/time.h" | tr './\055' '___'` echo $ac_n "checking for sys/time.h""... $ac_c" 1>&6 if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < EOF eval "$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* eval "ac_cv_header_$ac_safe=yes" else echo "$ac_err" >&5 rm -rf conftest* eval "ac_cv_header_$ac_safe=no" fi rm -f conftest* fi if eval "test \"`echo '$ac_cv_header_'$ac_safe`\" = yes"; then echo "$ac_t""yes" 1>&6 : else echo "$ac_t""no" 1>&6 cat >> confdefs.h <<\EOF #define NO_SYS_TIME_H 1 EOF fi ac_safe=`echo "sys/wait.h" | tr './\055' '___'` echo $ac_n "checking for sys/wait.h""... $ac_c" 1>&6 if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < EOF eval "$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* eval "ac_cv_header_$ac_safe=yes" else echo "$ac_err" >&5 rm -rf conftest* eval "ac_cv_header_$ac_safe=no" fi rm -f conftest* fi if eval "test \"`echo '$ac_cv_header_'$ac_safe`\" = yes"; then echo "$ac_t""yes" 1>&6 : else echo "$ac_t""no" 1>&6 cat >> confdefs.h <<\EOF #define NO_SYS_WAIT_H 1 EOF fi #-------------------------------------------------------------------- # On some systems strstr is broken: it returns a pointer even # even if the original string is empty. #-------------------------------------------------------------------- echo $ac_n "checking proper strstr implementation""... $ac_c" 1>&6 if test "$cross_compiling" = yes; then { echo "configure: error: can not run test program while cross compiling" 1>&2; exit 1; } else cat > conftest.$ac_ext </dev/null; then tcl_ok=yes else tcl_ok=no fi fi rm -fr conftest* if test $tcl_ok = yes; then echo "$ac_t""yes" 1>&6 else echo "$ac_t""broken, using substitute" 1>&6 LIBOBJS="$LIBOBJS strstr.o" fi #-------------------------------------------------------------------- # Check for strtoul function. This is tricky because under some # versions of AIX strtoul returns an incorrect terminator # pointer for the string "0". #-------------------------------------------------------------------- echo $ac_n "checking for strtoul""... $ac_c" 1>&6 if eval "test \"`echo '$''{'ac_cv_func_strtoul'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < /* Override any gcc2 internal prototype to avoid an error. */ char strtoul(); int main() { return 0; } int t() { /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined (__stub_strtoul) || defined (__stub___strtoul) choke me #else strtoul(); #endif ; return 0; } EOF if eval $ac_link; then rm -rf conftest* eval "ac_cv_func_strtoul=yes" else rm -rf conftest* eval "ac_cv_func_strtoul=no" fi rm -f conftest* fi if eval "test \"`echo '$ac_cv_func_'strtoul`\" = yes"; then echo "$ac_t""yes" 1>&6 tcl_ok=1 else echo "$ac_t""no" 1>&6 tcl_ok=0 fi if test "$cross_compiling" = yes; then { echo "configure: error: can not run test program while cross compiling" 1>&2; exit 1; } else cat > conftest.$ac_ext </dev/null; then : else tcl_ok=0 fi fi rm -fr conftest* if test $tcl_ok = 0; then test -n "$verbose" && echo " Adding strtoul.o." LIBOBJS="$LIBOBJS strtoul.o" fi #-------------------------------------------------------------------- # Check for the strtod function. This is tricky because in some # versions of Linux strtod mis-parses strings starting with "+". #-------------------------------------------------------------------- echo $ac_n "checking for strtod""... $ac_c" 1>&6 if eval "test \"`echo '$''{'ac_cv_func_strtod'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < /* Override any gcc2 internal prototype to avoid an error. */ char strtod(); int main() { return 0; } int t() { /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined (__stub_strtod) || defined (__stub___strtod) choke me #else strtod(); #endif ; return 0; } EOF if eval $ac_link; then rm -rf conftest* eval "ac_cv_func_strtod=yes" else rm -rf conftest* eval "ac_cv_func_strtod=no" fi rm -f conftest* fi if eval "test \"`echo '$ac_cv_func_'strtod`\" = yes"; then echo "$ac_t""yes" 1>&6 tcl_ok=1 else echo "$ac_t""no" 1>&6 tcl_ok=0 fi if test "$cross_compiling" = yes; then { echo "configure: error: can not run test program while cross compiling" 1>&2; exit 1; } else cat > conftest.$ac_ext </dev/null; then : else tcl_ok=0 fi fi rm -fr conftest* if test $tcl_ok = 0; then test -n "$verbose" && echo " Adding strtod.o." LIBOBJS="$LIBOBJS strtod.o" fi #-------------------------------------------------------------------- # Under Solaris 2.4, strtod returns the wrong value for the # terminating character under some conditions. Check for this # and if the problem exists use a substitute procedure # "fixstrtod" that corrects the error. #-------------------------------------------------------------------- echo $ac_n "checking for strtod""... $ac_c" 1>&6 if eval "test \"`echo '$''{'ac_cv_func_strtod'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < /* Override any gcc2 internal prototype to avoid an error. */ char strtod(); int main() { return 0; } int t() { /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined (__stub_strtod) || defined (__stub___strtod) choke me #else strtod(); #endif ; return 0; } EOF if eval $ac_link; then rm -rf conftest* eval "ac_cv_func_strtod=yes" else rm -rf conftest* eval "ac_cv_func_strtod=no" fi rm -f conftest* fi if eval "test \"`echo '$ac_cv_func_'strtod`\" = yes"; then echo "$ac_t""yes" 1>&6 tcl_strtod=1 else echo "$ac_t""no" 1>&6 tcl_strtod=0 fi if test "$tcl_strtod" = 1; then echo $ac_n "checking for Solaris strtod bug""... $ac_c" 1>&6 if test "$cross_compiling" = yes; then { echo "configure: error: can not run test program while cross compiling" 1>&2; exit 1; } else cat > conftest.$ac_ext </dev/null; then echo "$ac_t""ok" 1>&6 else echo "$ac_t""buggy" 1>&6 LIBOBJS="$LIBOBJS fixstrtod.o" cat >> confdefs.h <<\EOF #define strtod fixstrtod EOF fi fi rm -fr conftest* fi #-------------------------------------------------------------------- # Check for various typedefs and provide substitutes if # they don't exist. #-------------------------------------------------------------------- echo $ac_n "checking for ANSI C header files""... $ac_c" 1>&6 if eval "test \"`echo '$''{'ac_cv_header_stdc'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < #include #include #include EOF eval "$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out" ac_err=`grep -v '^ *+' conftest.out` if test -z "$ac_err"; then rm -rf conftest* ac_cv_header_stdc=yes else echo "$ac_err" >&5 rm -rf conftest* ac_cv_header_stdc=no fi rm -f conftest* if test $ac_cv_header_stdc = yes; then # SunOS 4.x string.h does not declare mem*, contrary to ANSI. cat > conftest.$ac_ext < EOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | egrep "memchr" >/dev/null 2>&1; then : else rm -rf conftest* ac_cv_header_stdc=no fi rm -f conftest* fi if test $ac_cv_header_stdc = yes; then # ISC 2.0.2 stdlib.h does not declare free, contrary to ANSI. cat > conftest.$ac_ext < EOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | egrep "free" >/dev/null 2>&1; then : else rm -rf conftest* ac_cv_header_stdc=no fi rm -f conftest* fi if test $ac_cv_header_stdc = yes; then # /bin/cc in Irix-4.0.5 gets non-ANSI ctype macros unless using -ansi. if test "$cross_compiling" = yes; then ac_cv_header_stdc=no else cat > conftest.$ac_ext < #define ISLOWER(c) ('a' <= (c) && (c) <= 'z') #define TOUPPER(c) (ISLOWER(c) ? 'A' + ((c) - 'a') : (c)) #define XOR(e, f) (((e) && !(f)) || (!(e) && (f))) int main () { int i; for (i = 0; i < 256; i++) if (XOR (islower (i), ISLOWER (i)) || toupper (i) != TOUPPER (i)) exit(2); exit (0); } EOF eval $ac_link if test -s conftest && (./conftest; exit) 2>/dev/null; then : else ac_cv_header_stdc=no fi fi rm -fr conftest* fi fi echo "$ac_t""$ac_cv_header_stdc" 1>&6 if test $ac_cv_header_stdc = yes; then cat >> confdefs.h <<\EOF #define STDC_HEADERS 1 EOF fi echo $ac_n "checking for mode_t""... $ac_c" 1>&6 if eval "test \"`echo '$''{'ac_cv_type_mode_t'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < #if STDC_HEADERS #include #endif EOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | egrep "mode_t" >/dev/null 2>&1; then rm -rf conftest* ac_cv_type_mode_t=yes else rm -rf conftest* ac_cv_type_mode_t=no fi rm -f conftest* fi echo "$ac_t""$ac_cv_type_mode_t" 1>&6 if test $ac_cv_type_mode_t = no; then cat >> confdefs.h <<\EOF #define mode_t int EOF fi echo $ac_n "checking for pid_t""... $ac_c" 1>&6 if eval "test \"`echo '$''{'ac_cv_type_pid_t'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < #if STDC_HEADERS #include #endif EOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | egrep "pid_t" >/dev/null 2>&1; then rm -rf conftest* ac_cv_type_pid_t=yes else rm -rf conftest* ac_cv_type_pid_t=no fi rm -f conftest* fi echo "$ac_t""$ac_cv_type_pid_t" 1>&6 if test $ac_cv_type_pid_t = no; then cat >> confdefs.h <<\EOF #define pid_t int EOF fi echo $ac_n "checking for size_t""... $ac_c" 1>&6 if eval "test \"`echo '$''{'ac_cv_type_size_t'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < #if STDC_HEADERS #include #endif EOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | egrep "size_t" >/dev/null 2>&1; then rm -rf conftest* ac_cv_type_size_t=yes else rm -rf conftest* ac_cv_type_size_t=no fi rm -f conftest* fi echo "$ac_t""$ac_cv_type_size_t" 1>&6 if test $ac_cv_type_size_t = no; then cat >> confdefs.h <<\EOF #define size_t unsigned EOF fi echo $ac_n "checking for uid_t in sys/types.h""... $ac_c" 1>&6 if eval "test \"`echo '$''{'ac_cv_type_uid_t'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < EOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | egrep "uid_t" >/dev/null 2>&1; then rm -rf conftest* ac_cv_type_uid_t=yes else rm -rf conftest* ac_cv_type_uid_t=no fi rm -f conftest* fi echo "$ac_t""$ac_cv_type_uid_t" 1>&6 if test $ac_cv_type_uid_t = no; then cat >> confdefs.h <<\EOF #define uid_t int EOF cat >> confdefs.h <<\EOF #define gid_t int EOF fi #-------------------------------------------------------------------- # If a system doesn't have an opendir function (man, that's old!) # then we have to supply a different version of dirent.h which # is compatible with the substitute version of opendir that's # provided. This version only works with V7-style directories. #-------------------------------------------------------------------- echo $ac_n "checking for opendir""... $ac_c" 1>&6 if eval "test \"`echo '$''{'ac_cv_func_opendir'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < /* Override any gcc2 internal prototype to avoid an error. */ char opendir(); int main() { return 0; } int t() { /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined (__stub_opendir) || defined (__stub___opendir) choke me #else opendir(); #endif ; return 0; } EOF if eval $ac_link; then rm -rf conftest* eval "ac_cv_func_opendir=yes" else rm -rf conftest* eval "ac_cv_func_opendir=no" fi rm -f conftest* fi if eval "test \"`echo '$ac_cv_func_'opendir`\" = yes"; then echo "$ac_t""yes" 1>&6 : else echo "$ac_t""no" 1>&6 cat >> confdefs.h <<\EOF #define USE_DIRENT2_H 1 EOF fi #-------------------------------------------------------------------- # Check for the existence of sys_errlist (this is only needed if # there's no strerror, but I don't know how to conditionalize the # check). #-------------------------------------------------------------------- echo $ac_n "checking sys_errlist""... $ac_c" 1>&6 cat > conftest.$ac_ext <&6 if test $tcl_ok = no; then cat >> confdefs.h <<\EOF #define NO_SYS_ERRLIST 1 EOF fi #-------------------------------------------------------------------- # The check below checks whether defines the type # "union wait" correctly. It's needed because of weirdness in # HP-UX where "union wait" is defined in both the BSD and SYS-V # environments. Checking the usability of WIFEXITED seems to do # the trick. #-------------------------------------------------------------------- echo $ac_n "checking union wait""... $ac_c" 1>&6 cat > conftest.$ac_ext < #include int main() { return 0; } int t() { union wait x; WIFEXITED(x); /* Generates compiler error if WIFEXITED * uses an int. */ ; return 0; } EOF if eval $ac_link; then rm -rf conftest* tcl_ok=yes else rm -rf conftest* tcl_ok=no fi rm -f conftest* echo "$ac_t""$tcl_ok" 1>&6 if test $tcl_ok = no; then cat >> confdefs.h <<\EOF #define NO_UNION_WAIT 1 EOF fi #-------------------------------------------------------------------- # Check to see whether the system supports the matherr function # and its associated type "struct exception". #-------------------------------------------------------------------- echo $ac_n "checking matherr support""... $ac_c" 1>&6 cat > conftest.$ac_ext < int main() { return 0; } int t() { struct exception x; x.type = DOMAIN; x.type = SING; ; return 0; } EOF if eval $ac_compile; then rm -rf conftest* tcl_ok=yes else rm -rf conftest* tcl_ok=no fi rm -f conftest* echo "$ac_t""$tcl_ok" 1>&6 if test $tcl_ok = yes; then cat >> confdefs.h <<\EOF #define NEED_MATHERR 1 EOF fi #-------------------------------------------------------------------- # Check to see whether the system provides a vfork kernel call. # If not, then use fork instead. Also, check for a problem with # Solaris 2.4 and vforks and signals that can core dumps can occur # if a vforked child resets a signal handler. If the problem # exists, then use fork instead of vfork. #-------------------------------------------------------------------- echo $ac_n "checking for vfork""... $ac_c" 1>&6 if eval "test \"`echo '$''{'ac_cv_func_vfork'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < /* Override any gcc2 internal prototype to avoid an error. */ char vfork(); int main() { return 0; } int t() { /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined (__stub_vfork) || defined (__stub___vfork) choke me #else vfork(); #endif ; return 0; } EOF if eval $ac_link; then rm -rf conftest* eval "ac_cv_func_vfork=yes" else rm -rf conftest* eval "ac_cv_func_vfork=no" fi rm -f conftest* fi if eval "test \"`echo '$ac_cv_func_'vfork`\" = yes"; then echo "$ac_t""yes" 1>&6 tcl_ok=1 else echo "$ac_t""no" 1>&6 tcl_ok=0 fi if test "$tcl_ok" = 1; then echo $ac_n "checking Solaris 2.4 vfork/signal bug""... $ac_c" 1>&6; if test "$cross_compiling" = yes; then { echo "configure: error: can not run test program while cross compiling" 1>&2; exit 1; } else cat > conftest.$ac_ext < #include #include int gotSignal = 0; sigProc(sig) int sig; { gotSignal = 1; } main() { int pid, sts; (void) signal(SIGCHLD, sigProc); pid = vfork(); if (pid < 0) { exit(1); } else if (pid == 0) { (void) signal(SIGCHLD, SIG_DFL); _exit(0); } else { (void) wait(&sts); } exit((gotSignal) ? 0 : 1); } EOF eval $ac_link if test -s conftest && (./conftest; exit) 2>/dev/null; then echo "$ac_t""ok" 1>&6 else echo "$ac_t""buggy" 1>&6 tcl_ok=0 fi fi rm -fr conftest* fi rm -f core if test "$tcl_ok" = 0; then cat >> confdefs.h <<\EOF #define vfork fork EOF fi #-------------------------------------------------------------------- # Check whether there is an strncasecmp function on this system. # This is a bit tricky because under SCO it's in the socket # library. #-------------------------------------------------------------------- echo $ac_n "checking for strncasecmp""... $ac_c" 1>&6 if eval "test \"`echo '$''{'ac_cv_func_strncasecmp'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < /* Override any gcc2 internal prototype to avoid an error. */ char strncasecmp(); int main() { return 0; } int t() { /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined (__stub_strncasecmp) || defined (__stub___strncasecmp) choke me #else strncasecmp(); #endif ; return 0; } EOF if eval $ac_link; then rm -rf conftest* eval "ac_cv_func_strncasecmp=yes" else rm -rf conftest* eval "ac_cv_func_strncasecmp=no" fi rm -f conftest* fi if eval "test \"`echo '$ac_cv_func_'strncasecmp`\" = yes"; then echo "$ac_t""yes" 1>&6 : else echo "$ac_t""no" 1>&6 echo $ac_n "checking for -lsocket""... $ac_c" 1>&6 if eval "test \"`echo '$''{'ac_cv_lib_socket'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else ac_save_LIBS="$LIBS" LIBS="-lsocket $LIBS" cat > conftest.$ac_ext <&6 ac_tr_lib=HAVE_LIB`echo socket | tr 'a-z' 'A-Z'` cat >> confdefs.h <&6 LIBOBJS="$LIBOBJS strncasecmp.o" fi fi #-------------------------------------------------------------------- # The code below deals with several issues related to gettimeofday: # 1. Some systems don't provide a gettimeofday function at all # (set NO_GETTOD if this is the case). # 2. SGI systems don't use the BSD form of the gettimeofday function, # but they have a BSDgettimeofday function that can be used instead. # 3. See if gettimeofday is declared in the header file. # if not, set the GETTOD_NOT_DECLARED flag so that tclPort.h can # declare it. #-------------------------------------------------------------------- echo $ac_n "checking for BSDgettimeofday""... $ac_c" 1>&6 if eval "test \"`echo '$''{'ac_cv_func_BSDgettimeofday'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < /* Override any gcc2 internal prototype to avoid an error. */ char BSDgettimeofday(); int main() { return 0; } int t() { /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined (__stub_BSDgettimeofday) || defined (__stub___BSDgettimeofday) choke me #else BSDgettimeofday(); #endif ; return 0; } EOF if eval $ac_link; then rm -rf conftest* eval "ac_cv_func_BSDgettimeofday=yes" else rm -rf conftest* eval "ac_cv_func_BSDgettimeofday=no" fi rm -f conftest* fi if eval "test \"`echo '$ac_cv_func_'BSDgettimeofday`\" = yes"; then echo "$ac_t""yes" 1>&6 cat >> confdefs.h <<\EOF #define HAVE_BSDGETTIMEOFDAY 1 EOF else echo "$ac_t""no" 1>&6 echo $ac_n "checking for gettimeofday""... $ac_c" 1>&6 if eval "test \"`echo '$''{'ac_cv_func_gettimeofday'+set}'`\" = set"; then echo $ac_n "(cached) $ac_c" 1>&6 else cat > conftest.$ac_ext < /* Override any gcc2 internal prototype to avoid an error. */ char gettimeofday(); int main() { return 0; } int t() { /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined (__stub_gettimeofday) || defined (__stub___gettimeofday) choke me #else gettimeofday(); #endif ; return 0; } EOF if eval $ac_link; then rm -rf conftest* eval "ac_cv_func_gettimeofday=yes" else rm -rf conftest* eval "ac_cv_func_gettimeofday=no" fi rm -f conftest* fi if eval "test \"`echo '$ac_cv_func_'gettimeofday`\" = yes"; then echo "$ac_t""yes" 1>&6 : else echo "$ac_t""no" 1>&6 cat >> confdefs.h <<\EOF #define NO_GETTOD 1 EOF fi fi echo $ac_n "checking for gettimeofday declaration""... $ac_c" 1>&6 cat > conftest.$ac_ext < EOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | egrep "gettimeofday" >/dev/null 2>&1; then rm -rf conftest* echo "$ac_t""present" 1>&6 else rm -rf conftest* echo "$ac_t""missing" 1>&6 cat >> confdefs.h <<\EOF #define GETTOD_NOT_DECLARED 1 EOF fi rm -f conftest* trap '' 1 2 15 cat > confcache <<\EOF # This file is a shell script that caches the results of configure # tests run on this system so they can be shared between configure # scripts and configure runs. It is not useful on other systems. # If it contains results you don't want to keep, you may remove or edit it. # # By default, configure uses ./config.cache as the cache file, # creating it if it does not exist already. You can give configure # the --cache-file=FILE option to use a different cache file; that is # what configure does when it calls configure scripts in # subdirectories, so they share the cache. # Giving --cache-file=/dev/null disables caching, for debugging configure. # config.status only pays attention to the cache file if you give it the # --recheck option to rerun configure. # EOF # Ultrix sh set writes to stderr and can't be redirected directly, # and sets the high bit in the cache file unless we assign to the vars. (set) 2>&1 | sed -n "s/^\([a-zA-Z0-9_]*_cv_[a-zA-Z0-9_]*\)=\(.*\)/\1=\${\1='\2'}/p" \ >> confcache if cmp -s $cache_file confcache; then : else if test -w $cache_file; then echo "updating cache $cache_file" cat confcache > $cache_file else echo "not updating unwritable cache $cache_file" fi fi rm -f confcache trap 'rm -fr conftest* confdefs* core core.* *.core $ac_clean_files; exit 1' 1 2 15 test "x$prefix" = xNONE && prefix=$ac_default_prefix # Let make expand exec_prefix. test "x$exec_prefix" = xNONE && exec_prefix='${prefix}' # Any assignment to VPATH causes Sun make to only execute # the first set of double-colon rules, so remove it if not needed. # If there is a colon in the path, we need to keep it. if test "x$srcdir" = x.; then ac_vpsub='/^[ ]*VPATH[ ]*=[^:]*$/d' fi trap 'rm -f $CONFIG_STATUS conftest*; exit 1' 1 2 15 # Transform confdefs.h into DEFS. # Protect against shell expansion while executing Makefile rules. # Protect against Makefile macro expansion. cat > conftest.defs <<\EOF s%#define \([A-Za-z_][A-Za-z0-9_]*\) \(.*\)%-D\1=\2%g s%[ `~#$^&*(){}\\|;'"<>?]%\\&%g s%\[%\\&%g s%\]%\\&%g s%\$%$$%g EOF DEFS=`sed -f conftest.defs confdefs.h | tr '\012' ' '` rm -f conftest.defs # Without the "./", some shells look in PATH for config.status. : ${CONFIG_STATUS=./config.status} echo creating $CONFIG_STATUS rm -f $CONFIG_STATUS cat > $CONFIG_STATUS </dev/null | sed 1q`: # # $0 $ac_configure_args # # Compiler output produced by configure, useful for debugging # configure, is in ./config.log if it exists. ac_cs_usage="Usage: $CONFIG_STATUS [--recheck] [--version] [--help]" for ac_option do case "\$ac_option" in -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r) echo "running \${CONFIG_SHELL-/bin/sh} $0 $ac_configure_args --no-create --no-recursion" exec \${CONFIG_SHELL-/bin/sh} $0 $ac_configure_args --no-create --no-recursion ;; -version | --version | --versio | --versi | --vers | --ver | --ve | --v) echo "$CONFIG_STATUS generated by autoconf version 2.2" exit 0 ;; -help | --help | --hel | --he | --h) echo "\$ac_cs_usage"; exit 0 ;; *) echo "\$ac_cs_usage"; exit 1 ;; esac done ac_given_srcdir=$srcdir ac_given_INSTALL="$INSTALL" trap 'rm -f Makefile; exit 1' 1 2 15 # Protect against being on the right side of a sed subst in config.status. sed 's/%@/@@/; s/@%/@@/; s/%g$/@g/; /@g$/s/[\\\\&%]/\\\\&/g; s/@@/%@/; s/@@/@%/; s/@g$/%g/' > conftest.subs <<\CEOF $ac_vpsub $extrasub s%@CFLAGS@%$CFLAGS%g s%@CPPFLAGS@%$CPPFLAGS%g s%@CXXFLAGS@%$CXXFLAGS%g s%@DEFS@%$DEFS%g s%@LDFLAGS@%$LDFLAGS%g s%@LIBS@%$LIBS%g s%@exec_prefix@%$exec_prefix%g s%@prefix@%$prefix%g s%@program_transform_name@%$program_transform_name%g s%@INSTALL_PROGRAM@%$INSTALL_PROGRAM%g s%@INSTALL_DATA@%$INSTALL_DATA%g s%@RANLIB@%$RANLIB%g s%@TCLSH@%$TCLSH%g s%@CC@%$CC%g s%@LIBOBJS@%$LIBOBJS%g s%@MATH_LIBS@%$MATH_LIBS%g s%@CPP@%$CPP%g CEOF EOF cat >> $CONFIG_STATUS <> $CONFIG_STATUS <<\EOF for ac_file in .. $CONFIG_FILES; do if test "x$ac_file" != x..; then # Support "outfile[:infile]", defaulting infile="outfile.in". case "$ac_file" in *:*) ac_file_in=`echo "$ac_file"|sed 's%.*:%%'` ac_file=`echo "$ac_file"|sed 's%:.*%%'` ;; *) ac_file_in="${ac_file}.in" ;; esac # Adjust relative srcdir, etc. for subdirectories. # Remove last slash and all that follows it. Not all systems have dirname. ac_dir=`echo $ac_file|sed 's%/[^/][^/]*$%%'` if test "$ac_dir" != "$ac_file" && test "$ac_dir" != .; then # The file is in a subdirectory. test ! -d "$ac_dir" && mkdir "$ac_dir" ac_dir_suffix="/`echo $ac_dir|sed 's%^\./%%'`" # A "../" for each directory in $ac_dir_suffix. ac_dots=`echo $ac_dir_suffix|sed 's%/[^/]*%../%g'` else ac_dir_suffix= ac_dots= fi case "$ac_given_srcdir" in .) srcdir=. if test -z "$ac_dots"; then top_srcdir=. else top_srcdir=`echo $ac_dots|sed 's%/$%%'`; fi ;; /*) srcdir="$ac_given_srcdir$ac_dir_suffix"; top_srcdir="$ac_given_srcdir" ;; *) # Relative path. srcdir="$ac_dots$ac_given_srcdir$ac_dir_suffix" top_srcdir="$ac_dots$ac_given_srcdir" ;; esac case "$ac_given_INSTALL" in [/$]*) INSTALL="$ac_given_INSTALL" ;; *) INSTALL="$ac_dots$ac_given_INSTALL" ;; esac echo creating "$ac_file" rm -f "$ac_file" configure_input="Generated automatically from `echo $ac_file_in|sed 's%.*/%%'` by configure." case "$ac_file" in *Makefile*) ac_comsub="1i\\ # $configure_input" ;; *) ac_comsub= ;; esac sed -e "$ac_comsub s%@configure_input@%$configure_input%g s%@srcdir@%$srcdir%g s%@top_srcdir@%$top_srcdir%g s%@INSTALL@%$INSTALL%g " -f conftest.subs $ac_given_srcdir/$ac_file_in > $ac_file fi; done rm -f conftest.subs exit 0 EOF chmod +x $CONFIG_STATUS rm -fr confdefs* $ac_clean_files test "$no_create" = yes || ${CONFIG_SHELL-/bin/sh} $CONFIG_STATUS || exit 1 c_n "(cached) $ac_c" 1>&6 else ac_save_Ltcl7.4b4/configure.in010077500630510000012000000245340577032342400153600ustar00ousterstaff00002300000001dnl This file is an input file used by the GNU "autoconf" program to dnl generate the file "configure", which is run during Tcl installation dnl to configure the system for the local environment. AC_INIT(tcl.h) # @(#) configure.in 1.14 95/05/22 08:01:27 AC_PROG_INSTALL AC_PROG_RANLIB AC_PREFIX_PROGRAM(tclsh) AC_C_CROSS CC=${CC-cc} AC_SUBST(CC) #-------------------------------------------------------------------- # Supply substitutes for missing POSIX library procedures, or # set flags so Tcl uses alternate procedures. #-------------------------------------------------------------------- AC_REPLACE_FUNCS(getcwd opendir strerror strstr) AC_REPLACE_FUNCS(strtol tmpnam waitpid) AC_CHECK_FUNC(getwd, , AC_DEFINE(NO_GETWD)) AC_CHECK_FUNC(wait3, , AC_DEFINE(NO_WAIT3)) #-------------------------------------------------------------------- # On a few very rare systems, all of the libm.a stuff is # already in libc.a. Set compiler flags accordingly. # Also, Linux requires the "ieee" library for math to work # right. #-------------------------------------------------------------------- AC_CHECK_FUNC(sin, MATH_LIBS="", MATH_LIBS="-lm") AC_SUBST(MATH_LIBS) AC_CHECK_LIB(ieee, main, [MATH_LIBS="$MATH_LIBS -lieee"]) #-------------------------------------------------------------------- # Supply substitutes for missing POSIX header files. Special # notes: # - Sprite's dirent.h exists but is bogus. # - stdlib.h doesn't define strtol, strtoul, or # strtod insome versions of SunOS # - some versions of string.h don't declare procedures such # as strstr #-------------------------------------------------------------------- AC_HAVE_HEADERS(unistd.h) AC_MSG_CHECKING(dirent.h) AC_TRY_LINK([#include #include ], [ #ifndef _POSIX_SOURCE # ifdef __Lynx__ /* * Generate compilation error to make the test fail: Lynx headers * are only valid if really in the POSIX environment. */ missing_procedure(); # endif #endif DIR *d; struct dirent *entryPtr; char *p; d = opendir("foobar"); entryPtr = readdir(d); p = entryPtr->d_name; closedir(d); ], tcl_ok=yes, tcl_ok=no) AC_EGREP_HEADER([Sprite version.* NOT POSIX], dirent.h, tcl_ok=no) if test $tcl_ok = no; then AC_DEFINE(NO_DIRENT_H) fi AC_MSG_RESULT($tcl_ok) AC_CHECK_HEADER(errno.h, , AC_DEFINE(NO_ERRNO_H)) AC_CHECK_HEADER(float.h, , AC_DEFINE(NO_FLOAT_H)) AC_CHECK_HEADER(limits.h, , AC_DEFINE(NO_LIMITS_H)) AC_CHECK_HEADER(stdlib.h, tcl_ok=1, tcl_ok=0) AC_EGREP_HEADER(strtol, stdlib.h, , tcl_ok=0) AC_EGREP_HEADER(strtoul, stdlib.h, , tcl_ok=0) AC_EGREP_HEADER(strtod, stdlib.h, , tcl_ok=0) if test $tcl_ok = 0; then AC_DEFINE(NO_STDLIB_H) fi AC_CHECK_HEADER(string.h, tcl_ok=1, tcl_ok=0) AC_EGREP_HEADER(strstr, string.h, , tcl_ok=0) AC_EGREP_HEADER(strerror, string.h, , tcl_ok=0) if test $tcl_ok = 0; then AC_DEFINE(NO_STRING_H) fi AC_CHECK_HEADER(sys/time.h, , AC_DEFINE(NO_SYS_TIME_H)) AC_CHECK_HEADER(sys/wait.h, , AC_DEFINE(NO_SYS_WAIT_H)) #-------------------------------------------------------------------- # On some systems strstr is broken: it returns a pointer even # even if the original string is empty. #-------------------------------------------------------------------- AC_MSG_CHECKING([proper strstr implementation]) AC_TRY_RUN([ extern int strstr(); int main() { exit(strstr("\0test", "test") ? 1 : 0); } ], tcl_ok=yes, tcl_ok=no) if test $tcl_ok = yes; then AC_MSG_RESULT(yes) else AC_MSG_RESULT([broken, using substitute]) LIBOBJS="$LIBOBJS strstr.o" fi #-------------------------------------------------------------------- # Check for strtoul function. This is tricky because under some # versions of AIX strtoul returns an incorrect terminator # pointer for the string "0". #-------------------------------------------------------------------- AC_CHECK_FUNC(strtoul, tcl_ok=1, tcl_ok=0) AC_TRY_RUN([ extern int strtoul(); int main() { char *string = "0"; char *term; int value; value = strtoul(string, &term, 0); if ((value != 0) || (term != (string+1))) { exit(1); } exit(0); }], , tcl_ok=0) if test $tcl_ok = 0; then test -n "$verbose" && echo " Adding strtoul.o." LIBOBJS="$LIBOBJS strtoul.o" fi #-------------------------------------------------------------------- # Check for the strtod function. This is tricky because in some # versions of Linux strtod mis-parses strings starting with "+". #-------------------------------------------------------------------- AC_CHECK_FUNC(strtod, tcl_ok=1, tcl_ok=0) AC_TRY_RUN([ extern double strtod(); int main() { char *string = " +69"; char *term; double value; value = strtod(string, &term); if ((value != 69) || (term != (string+4))) { exit(1); } exit(0); }], , tcl_ok=0) if test $tcl_ok = 0; then test -n "$verbose" && echo " Adding strtod.o." LIBOBJS="$LIBOBJS strtod.o" fi #-------------------------------------------------------------------- # Under Solaris 2.4, strtod returns the wrong value for the # terminating character under some conditions. Check for this # and if the problem exists use a substitute procedure # "fixstrtod" that corrects the error. #-------------------------------------------------------------------- AC_CHECK_FUNC(strtod, tcl_strtod=1, tcl_strtod=0) if test "$tcl_strtod" = 1; then AC_MSG_CHECKING([for Solaris strtod bug]) AC_TRY_RUN([ extern double strtod(); int main() { char *string = "NaN"; char *term; strtod(string, &term); if ((term != string) && (term[-1] == 0)) { exit(1); } exit(0); }], AC_MSG_RESULT(ok), [ AC_MSG_RESULT(buggy) LIBOBJS="$LIBOBJS fixstrtod.o" AC_DEFINE(strtod, fixstrtod) ]) fi #-------------------------------------------------------------------- # Check for various typedefs and provide substitutes if # they don't exist. #-------------------------------------------------------------------- AC_TYPE_MODE_T AC_TYPE_PID_T AC_TYPE_SIZE_T AC_TYPE_UID_T #-------------------------------------------------------------------- # If a system doesn't have an opendir function (man, that's old!) # then we have to supply a different version of dirent.h which # is compatible with the substitute version of opendir that's # provided. This version only works with V7-style directories. #-------------------------------------------------------------------- AC_CHECK_FUNC(opendir, , AC_DEFINE(USE_DIRENT2_H)) #-------------------------------------------------------------------- # Check for the existence of sys_errlist (this is only needed if # there's no strerror, but I don't know how to conditionalize the # check). #-------------------------------------------------------------------- AC_MSG_CHECKING(sys_errlist) AC_TRY_LINK(, [ extern char *sys_errlist[]; extern int sys_nerr; sys_errlist[sys_nerr-1][0] = 0; ], tcl_ok=yes, tcl_ok=no) AC_MSG_RESULT($tcl_ok) if test $tcl_ok = no; then AC_DEFINE(NO_SYS_ERRLIST) fi #-------------------------------------------------------------------- # The check below checks whether defines the type # "union wait" correctly. It's needed because of weirdness in # HP-UX where "union wait" is defined in both the BSD and SYS-V # environments. Checking the usability of WIFEXITED seems to do # the trick. #-------------------------------------------------------------------- AC_MSG_CHECKING([union wait]) AC_TRY_LINK([#include #include ], [ union wait x; WIFEXITED(x); /* Generates compiler error if WIFEXITED * uses an int. */ ], tcl_ok=yes, tcl_ok=no) AC_MSG_RESULT($tcl_ok) if test $tcl_ok = no; then AC_DEFINE(NO_UNION_WAIT) fi #-------------------------------------------------------------------- # Check to see whether the system supports the matherr function # and its associated type "struct exception". #-------------------------------------------------------------------- AC_MSG_CHECKING([matherr support]) AC_TRY_COMPILE([#include ], [ struct exception x; x.type = DOMAIN; x.type = SING; ], tcl_ok=yes, tcl_ok=no) AC_MSG_RESULT($tcl_ok) if test $tcl_ok = yes; then AC_DEFINE(NEED_MATHERR) fi #-------------------------------------------------------------------- # Check to see whether the system provides a vfork kernel call. # If not, then use fork instead. Also, check for a problem with # Solaris 2.4 and vforks and signals that can core dumps can occur # if a vforked child resets a signal handler. If the problem # exists, then use fork instead of vfork. #-------------------------------------------------------------------- AC_CHECK_FUNC(vfork, tcl_ok=1, tcl_ok=0) if test "$tcl_ok" = 1; then AC_MSG_CHECKING([Solaris 2.4 vfork/signal bug]); AC_TRY_RUN([ #include #include #include int gotSignal = 0; sigProc(sig) int sig; { gotSignal = 1; } main() { int pid, sts; (void) signal(SIGCHLD, sigProc); pid = vfork(); if (pid < 0) { exit(1); } else if (pid == 0) { (void) signal(SIGCHLD, SIG_DFL); _exit(0); } else { (void) wait(&sts); } exit((gotSignal) ? 0 : 1); }], AC_MSG_RESULT(ok), [ AC_MSG_RESULT(buggy) tcl_ok=0 ]) fi rm -f core if test "$tcl_ok" = 0; then AC_DEFINE(vfork, fork) fi #-------------------------------------------------------------------- # Check whether there is an strncasecmp function on this system. # This is a bit tricky because under SCO it's in the socket # library. #-------------------------------------------------------------------- AC_CHECK_FUNC(strncasecmp, , AC_CHECK_LIB(socket, strncasecmp, , [LIBOBJS="$LIBOBJS strncasecmp.o"])) #-------------------------------------------------------------------- # The code below deals with several issues related to gettimeofday: # 1. Some systems don't provide a gettimeofday function at all # (set NO_GETTOD if this is the case). # 2. SGI systems don't use the BSD form of the gettimeofday function, # but they have a BSDgettimeofday function that can be used instead. # 3. See if gettimeofday is declared in the header file. # if not, set the GETTOD_NOT_DECLARED flag so that tclPort.h can # declare it. #-------------------------------------------------------------------- AC_CHECK_FUNC(BSDgettimeofday, AC_DEFINE(HAVE_BSDGETTIMEOFDAY), AC_CHECK_FUNC(gettimeofday, , AC_DEFINE(NO_GETTOD))) AC_MSG_CHECKING([for gettimeofday declaration]) AC_EGREP_HEADER(gettimeofday, sys/time.h, AC_MSG_RESULT(present), [ AC_MSG_RESULT(missing) AC_DEFINE(GETTOD_NOT_DECLARED) ]) AC_OUTPUT(Makefile) #-------------------------------------------------------------------- # Supply substitutes for missing POSIX library procedures, or # set flags so Tcl uses alternattcl7.4b4/changes010044400630510000012000001423300577032331600143660ustar00ousterstaff00002300000001Recent user-visible changes to Tcl: sccsid = @(#) changes 1.12 95/06/16 08:44:07 1. No more [command1] [command2] construct for grouping multiple commands on a single command line. 2. Semi-colon now available for grouping commands on a line. 3. For a command to span multiple lines, must now use backslash-return at the end of each line but the last. 4. "Var" command has been changed to "set". 5. Double-quotes now available as an argument grouping character. 6. "Return" may be used at top-level. 7. More backslash sequences available now. In particular, backslash-newline may be used to join lines in command files. 8. New or modified built-in commands: case, return, for, glob, info, print, return, set, source, string, uplevel. 9. After an error, the variable "errorInfo" is filled with a stack trace showing what was being executed when the error occurred. 10. Command abbreviations are accepted when parsing commands, but are not recommended except for purely-interactive commands. 11. $, set, and expr all complain now if a non-existent variable is referenced. 12. History facilities exist now. See Tcl.man and Tcl_RecordAndEval.man. 13. Changed to distinguish between empty variables and those that don't exist at all. Interfaces to Tcl_GetVar and Tcl_ParseVar have changed (NULL return value is now possible). *** POTENTIAL INCOMPATIBILITY *** 14. Changed meaning of "level" argument to "uplevel" command (1 now means "go up one level", not "go to level 1"; "#1" means "go to level 1"). *** POTENTIAL INCOMPATIBILITY *** 15. 3/19/90 Added "info exists" option to see if variable exists. 16. 3/19/90 Added "noAbbrev" variable to prohibit command abbreviations. 17. 3/19/90 Added extra errorInfo option to "error" command. 18. 3/21/90 Double-quotes now only affect space: command, variable, and backslash substitutions still occur inside double-quotes. *** POTENTIAL INCOMPATIBILITY *** 19. 3/21/90 Added support for \r. 20. 3/21/90 List, concat, eval, and glob commands all expect at least one argument now. *** POTENTIAL INCOMPATIBILITY *** 21. 3/22/90 Added "?:" operators to expressions. 22. 3/25/90 Fixed bug in Tcl_Result that caused memory to get trashed. ------------------- Released version 3.1 --------------------- 23. 3/29/90 Fixed bug that caused "file a.b/c ext" to return ".b/c". 24. 3/29/90 Semi-colon is not treated specially when enclosed in double-quotes. ------------------- Released version 3.2 --------------------- 25. 4/16/90 Rewrote "exec" not to use select or signals anymore. Should be more Sys-V compatible, and no slower in the normal case. 26. 4/18/90 Rewrote "glob" to eliminate GNU code (there's no GNU code left in Tcl, now), and added Tcl_TildeSubst procedure. Added automatic tilde-substitution in many commands, including "glob". ------------------- Released version 3.3 --------------------- 27. 7/11/90 Added "Tcl_AppendResult" procedure. 28. 7/20/90 "History" with no options now defaults to "history info" rather than to "history redo". Although this is a backward incompatibility, it should only be used interactively and thus shouldn't present any compatibility problems with scripts. 29. 7/20/90 Added "Tcl_GetInteger", "Tcl_GetDouble", and "Tcl_GetBoolean" procedures. 30. 7/22/90 Removed "Tcl_WatchInterp" procedure: doesn't seem to be necessary, since the same effect can be achieved with the deletion callbacks on individual commands. *** POTENTIAL INCOMPATIBILITY *** 31. 7/23/90 Added variable tracing: Tcl_TraceVar, Tcl_UnTraceVar, and Tcl_VarTraceInfo procedures, "trace" command. 32. 8/9/90 Mailed out list of all bug fixes since 3.3 release. 33. 8/29/90 Fixed bugs in Tcl_Merge relating to backslashes and semi-colons. Mailed out patch. 34. 9/3/90 Fixed bug in tclBasic.c: quotes weren't quoting ]'s. Mailed out patch. 35. 9/19/90 Rewrote exec to always use files both for input and output to the process. The old pipe-based version didn't work if the exec'ed process forked a child and then exited: Tcl waited around for stdout to get closed, which didn't happen until the grandchild exited. 36. 11/5/90 ERR_IN_PROGRESS flag wasn't being cleared soon enough in Tcl_Eval, allowing error messages from different commands to pile up in $errorInfo. Fixed by re-arranging code in Tcl_Eval that re-initializes result and ERR_IN_PROGRESS flag. Didn't mail out patch: changes too complicated to describe. 37. 12/19/90 Added Tcl_VarEval procedure as a convenience for assembling and executing Tcl commands. 38. 1/29/91 Fixed core leak in Tcl_AddErrorInfo. Also changed procedure and Tcl_Eval so that first call to Tcl_AddErrorInfo need not come from Tcl_Eval. ----------------- Released version 5.0 with Tk ------------------ 39. 4/3/91 Removed change bars from manual entries, leaving only those that came after version 3.3 was released. 40. 5/17/91 Changed tests to conform to Mary Ann May-Pumphrey's approach. 41. 5/23/91 Massive revision to Tcl parser to simplify the implementation of string and floating-point support in expressions. Newlines inside [] are now treated as command separators rather than word separators (this makes newline treatment consistent throughout Tcl). *** POTENTIAL INCOMPATIBILITY *** 42. 5/23/91 Massive rewrite of expression code to support floating-point values and simple string comparisons. The C interfaces to expression routines have changed (Tcl_Expr is replaced by Tcl_ExprLong, Tcl_ExprDouble, etc.), but all old Tcl expression strings should be accepted by the new expression code. *** POTENTIAL INCOMPATIBILITY *** 43. 5/23/91 Modified tclHistory.c to check for negative "keep" value. 44. 5/23/91 Modified Tcl_Backslash to handle backslash-newline. It now returns 0 to indicate that a backslash sequence should be replaced by no character at all. *** POTENTIAL INCOMPATIBILITY *** 45. 5/29/91 Modified to use ANSI C function prototypes. Must set "USE_ANSI" switch when compiling to get prototypes. 46. 5/29/91 Completed test suite by providing tests for all of the built-in Tcl commands. 47. 5/29/91 Changed Tcl_Concat to eliminate leading and trailing white-space in each of the things it concatenates and to ignore elements that are empty or have only white space in them. This produces cleaner output from the "concat" command. *** POTENTIAL INCOMPATIBILITY *** 48. 5/31/91 Changed "set" command and Tcl_SetVar procedure to return new value of variable. 49. 6/1/91 Added "while" and "cd" commands. 50. 6/1/91 Changed "exec" to delete the last character of program output if it is a newline. In most cases this makes it easier to process program-generated output. *** POTENTIAL INCOMPATIBILITY *** 51. 6/1/91 Made sure that pointers are never used after freeing them. 52. 6/1/91 Fixed bug in TclWordEnd where it wasn't dealing with [] inside quotes correctly. 53. 6/8/91 Fixed exec.test to accept return values of either 1 or 255 from "false" command. 54. 7/6/91 Massive overhaul of variable management. Associative arrays now available, along with "unset" command (and Tcl_UnsetVar procedure). Variable traces have been completely reworked: interfaces different both from Tcl and C, and multiple traces may exist on same variable. Can no longer redefine existing local variable to be global. Calling sequences have changed slightly for Tcl_GetVar and Tcl_SetVar ("global" is now "flags"). Tcl_SetVar can fail and return a NULL result. New forms of variable-manipulation procedures: Tcl_GetVar2, Tcl_SetVar2, etc. Syntax of variable $-notation changed to support array indexing. *** POTENTIAL INCOMPATIBILITY *** 55. 7/6/91 Added new list-manipulation procedures: Tcl_ScanElement, Tcl_ConvertElement, Tcl_AppendElement. 56. 7/12/91 Created new procedure Tcl_EvalFile, which does most of the work of the "source" command. 57. 7/20/91 Major reworking of "exec" command to allow pipelines, more redirection, background. Added new procedures Tcl_Fork, Tcl_WaitPids, Tcl_DetachPids, and Tcl_CreatePipeline. The old "< input" notation has been replaced by "<< input" ("<" is for redirection from a file). Also handles error returns and abnormal terminations (e.g. signals) differently. *** POTENTIAL INCOMPATIBILITY *** 58. 7/21/91 Added "append" and "lappend" commands. 59. 7/22/91 Reworked error messages and manual entries to use ?x? as the notation for an optional argument x, instead of [x]. The bracket notation was often confused with the use of brackets for command substitution. Also modified error messages to be more consistent. 60. 7/23/91 Tcl_DeleteCommand now returns an indication of whether or not the command actually existed, and the "rename" command uses this information to return an error if an attempt is made to delete a non-existent command. *** POTENTIAL INCOMPATIBILITY *** 61. 7/25/91 Added new "errorCode" mechanism, along with procedures Tcl_SetErrorCode, Tcl_UnixError, and Tcl_ResetResult. Renamed Tcl_Return to Tcl_SetResult, but left a #define for Tcl_Return to avoid compatibility problems. 62. 7/26/91 Extended "case" command with alternate syntax where all patterns and commands are together in a single list argument: makes it easier to write multi-line case statements. 63. 7/27/91 Changed "print" command to perform tilde-substitution on the file name. 64. 7/27/91 Added "tolower", "toupper", "trim", "trimleft", and "trimright" options to "string" command. 65. 7/29/91 Added "atime", "mtime", "size", and "stat" options to "file" command. 66. 8/1/91 Added "split" and "join" commands. 67. 8/11/91 Added commands for file I/O, including "open", "close", "read", "gets", "puts", "flush", "eof", "seek", and "tell". 68. 8/14/91 Switched to use a hash table for command lookups. Command abbreviations no longer have direct support in the Tcl interpreter, but it should be possible to simulate them with the auto-load features described below. The "noAbbrev" variable is no longer used by Tcl. *** POTENTIAL INCOMPATIBILITY *** 68.5 8/15/91 Added support for "unknown" command, which can be used to complete abbreviations, auto-load library files, auto-exec shell commands, etc. 69. 8/15/91 Added -nocomplain switch to "glob" command. 70. 8/20/91 Added "info library" option and TCL_LIBRARY #define. Also added "info script" option. 71. 8/20/91 Changed "file" command to take "option" argument as first argument (before file name), for consistency with other Tcl commands. *** POTENTIAL INCOMPATIBILITY *** 72. 8/20/91 Changed format of information in $errorInfo variable: comments such as ("while" body line 1) are now on separate lines from commands being executed. *** POTENTIAL INCOMPATIBILITY *** 73. 8/20/91 Changed Tcl_AppendResult so that it (eventually) frees large buffers that it allocates. 74. 8/21/91 Added "linsert", "lreplace", "lsearch", and "lsort" commands. 75. 8/28/91 Added "incr" and "exit" commands. 76. 8/30/91 Added "regexp" and "regsub" commands. 77. 9/4/91 Changed "dynamic" field in interpreters to "freeProc" (procedure address). This allows for alternative storage managers. *** POTENTIAL INCOMPATIBILITY *** 78. 9/6/91 Added "index", "length", and "range" options to "string" command. Added "lindex", "llength", and "lrange" commands. 79. 9/8/91 Removed "index", "length", "print" and "range" commands. "Print" is redundant with "puts", but less general, and the other commands are replaced with the new commands described in change 78 above. *** POTENTIAL INCOMPATIBILITY *** 80. 9/8/91 Changed history revision to occur even when history command is nested; needed in order to allow "history" to be invoked from "unknown" procedure. 81. 9/13/91 Changed "panic" not to use vfprintf (it's uglier and less general now, but makes it easier to run Tcl on systems that don't have vfprintf). Also changed "strerror" not to redeclare sys_errlist. 82. 9/19/91 Lots of changes to improve portability to different UNIX systems, including addition of "config" script to adapt Tcl to the configuration of the system it's being compiled on. 83. 9/22/91 Added "pwd" command. 84. 9/22/91 Renamed manual pages so that their filenames are no more than 14 characters in length, moved to "doc" subdirectory. 85. 9/24/91 Redid manual entries so they contain the supplemental macros that they need; can just print with "troff -man" or "man" now. 86. 9/26/91 Created initial version of script library, including a version of "unknown" that does auto-loading, auto-execution, and abbreviation expansion. This library is used by tclTest automatically. See the "library" manual entry for details. ----------------- Released version 6.0, 9/26/91 ------------------ 87. 9/30/91 Made "string tolower" and "string toupper" check case before converting: on some systems, "tolower" and "toupper" assume that character already has particular case. 88. 9/30/91 Fixed bug in Tcl_SetResult: wasn't always setting freeProc correctly when called with NULL value. This tended to cause memory allocation errors later. 89. 10/3/91 Added "upvar" command. 90. 10/4/91 Changed "format" so that internally it converts %D to %ld, %U to %lu, %O to %lo, and %F to %f. This eliminates some compatibility problems on some machines without affecting behavior. 91. 10/10/91 Fixed bug in "regsub" that caused core dumps with the -all option when the last match wasn't at the end of the string. 92. 10/17/91 Fixed problems with backslash sequences: \r support was incomplete and \f and \v weren't supported at all. 93. 10/24/91 Added Tcl_InitHistory procedure. 94. 10/24/91 Changed "regexp" to store "-1 -1" in subMatchVars that don't match, rather than returning an error. 95. 10/27/91 Modified "regexp" to return actual strings in matchVar and subMatchVars instead of indices. Added "-indices" switch to cause indices to be returned. *** POTENTIAL INCOMPATIBILITY *** 96. 10/27/91 Fixed bug in "scan" where it used hardwired constants for sizes of floats and doubles instead of using "sizeof". 97. 10/31/91 Fixed bug in tclParse.c where parse-related error messages weren't being storage-managed correctly, causing spurious free's. 98. 10/31/91 Form feed and vertical tab characters are now considered to be space characters by the parser. 99. 10/31/91 Added TCL_LEAVE_ERR_MSG flag to procedures like Tcl_SetVar. 100. 11/7/91 Fixed bug in "case" where "in" argument couldn't be omitted if all case branches were embedded in a single list. 101. 11/7/91 Switched to use "pid_t" and "uid_t" and other official POSIC types and function prototypes. ----------------- Released version 6.1, 11/7/91 ------------------ 102. 12/2/91 Modified Tcl_ScanElement and Tcl_ConvertElement in several ways. First, allowed caller to request that only backslashes be used (no braces). Second, made Tcl_ConvertElement more aggressive in using backslashes for braces and quotes. 103. 12/5/91 Added "type", "lstat", and "readlink" options to "file" command, plus added new "type" element to output of "stat" and "lstat" options. 104. 12/10/91 Manual entries had first lines that caused "man" program to try weird preprocessor. Added blank comment lines to fix problem. 105. 12/16/91 Fixed a few bugs in auto_mkindex proc: wasn't handling errors properly, and hadn't been upgraded for new "regexp" syntax. 106. 1/2/92 Fixed bug in "file" command where it didn't properly handle a file names containing tildes where the indicated user doesn't exist. 107. 1/2/92 Fixed lots of cases in tclUnixStr.c where two different errno symbols (e.g. EWOULDBLOCK and EAGAIN) have the same number; Tcl will only use one of them. 108. 1/2/92 Lots of changes to configuration script to handle many more systems more gracefully. E.g. should now detect the bogus strtoul that comes with AIX and substitute Tcl's own version instead. ----------------- Released version 6.2, 1/10/92 ------------------ 109. 1/20/92 Config didn't have code to actually use "uid_t" variable to set TCL_UIT_T #define. 110. 2/10/92 Tcl_Eval didn't properly reset "numLevels" variable when too-deep recursion occurred. 111. 2/29/92 Added "on" and "off" to keywords accepted by Tcl_GetBoolean. 112. 3/19/92 Config wasn't installing default version of strtod.c for systems that don't have one in libc.a. 113. 3/23/92 Fixed bug in tclExpr.c where numbers with leading "."s, like 0.75, couldn't be properly substituted into expressions with variable or command substitution. 114. 3/25/92 Fixed bug in tclUnixAZ.c where "gets" command wasn't checking to make sure that it was able to write the variable OK. 115. 4/16/92 Fixed bug in tclUnixAZ.c where "read" command didn't compute file size right for device files. 116. 4/23/92 Fixed but in tclCmdMZ.c where "trace vinfo" was overwriting the trace command. ----------------- Released version 6.3, 5/1/92 ------------------ 117. 5/1/92 Added Tcl_GlobalEval. 118. 6/1/92 Changed auto-load facility to source files at global level. 119. 6/8/92 Tcl_ParseVar wasn't always setting termPtr after errors, which sometimes caused core dumps. 120. 6/21/92 Fixed bug in initialization of regexp pattern cache. This bug caused segmentation violations in regexp commands under some conditions. 121. 6/22/92 Changed implementation of "glob" command to eliminate trailing slashes on directory names: they confuse some systems. There shouldn't be any user-visible changes in functionality except for names in error messages not having trailing slashes. 122. 7/2/92 Fixed bug that caused 'string match ** ""' to return 0. 123. 7/2/92 Fixed bug in Tcl_CreateCmdBuf where it wasn't initializing the buffer to an empty string. 124. 7/6/92 Fixed bug in "case" command where it used NULL pattern string after errors in the "default" clause. 125. 7/25/92 Speeded up auto_load procedure: don't reread all the index files unless the path has changed. 126. 8/3/92 Changed tclUnix.h to define MAXPATHLEN from PATH_MAX, not _POSIX_PATH_MAX. ----------------- Released version 6.4, 8/7/92 ------------------ 127. 8/10/92 Changed tclBasic.c so that comment lines can be continued by putting a backslash before the newline. 128. 8/21/92 Modified "unknown" to allow the source-ing of a file for an auto-load to trigger other nested auto-loads, as long as there isn't any recursion on the same command name. 129. 8/25/92 Modified "format" command to allow " " and "+" flags, and allow flags in any order. 130. 9/14/92 Modified Tcl_ParseVar so that it doesn't actually attempt to look up the variable if "noEval" mode is in effect in the interpreter (it just parses the name). This avoids the errors that used to occur in statements like "expr {[info exists foo] && $foo}". 131. 9/14/92 Fixed bug in "uplevel" command where it didn't output the correct error message if a level was specified but no command. 132. 9/14/92 Renamed manual entries to have extensions like .3 and .n, and added "install" target to Makefile. 133. 9/18/92 Modified "unknown" command to emulate !!, !, and ^^ csh history substitutions. 134. 9/21/92 Made the config script cleverer about figuring out which switches to pass to "nm". 135. 9/23/92 Fixed tclVar.c to be sure to copy flags when growing variables. Used to forget about traces in progress and make extra recursive calls on trace procs. 136. 9/28/92 Fixed bug in auto_reset where it was unsetting variables that might not exist. 137. 10/7/92 Changed "parray" library procedure to print any array accessible to caller, local or global. 138. 10/15/92 Fixed bug where propagation of new environment variable values among interpreters took N! time if there exist N interpreters. 139. 10/16/92 Changed auto_reset procedure so that it also deletes any existing procedures that are in the auto_load index (the assumption is that they should be re-loaded to get the latest versions). 140. 10/21/92 Fixed bug that caused lists to be incorrectly generated for elements that contained backslash-newline sequences. 141. 12/9/92 Added support for TCL_LIBRARY environment variable: use it as library location if it's present. 142. 12/9/92 Added "info complete" command, Tcl_CommandComplete procedure. 143. 12/16/92 Changed the Makefile to check to make sure "config" has been run (can't run config directly from the Makefile because it modifies the Makefile; thus make has to be run again after running config). ----------------- Released version 6.5, 12/17/92 ------------------ 144. 12/21/92 Changed config to look in several places for libc file. 145. 12/23/92 Added "elseif" support to if. Also, "then", "else", and "elseif" may no longer be abbreviated. *** POTENTIAL INCOMPATIBILITY *** 146. 12/28/92 Changed "puts" and "read" to support initial "-nonewline" switch instead of additional "nonewline" argument. The old form is still supported, but it is discouraged and is no longer documented. Also changed "puts" to make the file argument default to stdout: e.g. "puts foo" will print foo on standard output. 147. 1/6/93 Fixed bug whereby backslash-newline wasn't working when typed interactively, or in "info complete". 148. 1/22/93 Fixed bugs in "lreplace" and "linsert" where close quotes were being lost from last element before replacement or insertion. 149. 1/29/93 Fixed bug in Tcl_AssembleCmd where it wasn't requiring a newline at the end of a line before considering a command to be complete. The bug caused some very long lines in script files to be processed as multiple separate commands. 150. 1/29/93 Various changes in Makefile to add more configuration options, simplify installation, fix bugs (e.g. don't use -f switch for cp), etc. 151. 1/29/93 Changed "name1" and "name2" identifiers to "part1" and "part2" to avoid name conflicts with stupid C++ implementations that use "name1" and "name2" in a reserved way. 152. 2/1/93 Added "putenv" procedure to replace the standard system version so that it will work correctly with Tcl's environment handling. ----------------- Released version 6.6, 2/5/93 ------------------ 153. 2/10/93 Fixed bugs in config script: missing "endif" in libc loop, and tried to use strncasecmp.c instead of strcasecmp.c. 154. 2/10/93 Makefile improvements: added RANLIB variable for easier Sys-V configuration, added SHELL variable for SGI systems. ----------------- Released version 6.7, 2/11/93 ------------------ 153. 2/6/93 Changes in backslash processing: - \Cx, \Mx, \CMx, \e sequences no longer special - \ also eats up any space after the newline, replacing the whole sequence with a single space character - Hex sequences like \x24 are now supported, along with ANSI C's \a. - "format" no longer does backslash processing on its format string - there is no longer any special meaning to a 0 return value from Tcl_Backslash - unknown backslash sequences, like (e.g. \*), are replaced with the following character (e.g. *), instead of just treating the backslash as an ordinary character. *** POTENTIAL INCOMPATIBILITY *** 154. 2/6/93 Updated all copyright notices. The meaning hasn't changed at all but the wording does a better job of protecting U.C. from liability (according to U.C. lawyers, anyway). 155. 2/6/93 Changed "regsub" so that it overwrites the result variable in all cases, even if there is no match. *** POTENTIAL INCOMPATIBILITY *** 156. 2/8/93 Added support for XPG3 %n$ conversion specifiers to "format" command. 157. 2/17/93 Fixed bug in Tcl_Eval where errors due to infinite recursion could result in core dumps. 158. 2/17/93 Improved the auto-load mechanism to deal gracefully (i.e. return an error) with a situation where a library file that supposedly defines a procedure doesn't actually define it. 159. 2/17/93 Renamed Tcl_UnixError procedure to Tcl_PosixError, and changed errorCode variable usage to use POSIX as keyword instead of UNIX. *** POTENTIAL INCOMPATIBILITY *** 160. 2/19/93 Changes to exec and process control: - Added support for >>, >&, >>&, |&, <@, >@, and >&@ forms of redirection. - When exec puts processes into background, it returns a list of their pids as result. - Added support for file, etc. (i.e. no space between ">" and file name. - Added -keepnewline option. - Deleted Tcl_Fork and Tcl_WaitPids procedures (just use fork and waitpid instead). - Added waitpid compatibility procedure for systems that don't have it. - Added Tcl_ReapDetachedProcs procedure. - Changed "exec" to return an error if there is stderr output, even if the command returns a 0 exit status (it's always been documented this way, but the implementation wasn't correct). - If a process returns a non-zero exit status but doesn't generate any diagnostic output, then Tcl generates an error message for it. *** POTENTIAL INCOMPATIBILITY *** 161. 2/25/93 Fixed two memory-management problems having to do with managing the old result during variable trace callbacks. 162. 3/1/93 Added dynamic string library: Tcl_DStringInit, Tcl_DStringAppend, Tcl_DStringFree, Tcl_DStringResult, etc. 163. 3/1/93 Modified glob command to only return the names of files that exist, and to only return names ending in "/" if the file is a directory. *** POTENTIAL INCOMPATIBILITY *** 164. 3/19/93 Modified not to use system calls like "read" directly, but instead to use special Tcl procedures that retry automatically if interrupted by signals. 165. 4/3/93 Eliminated "noSep" argument to Tcl_AppendElement, plus TCL_NO_SPACE flag for Tcl_SetVar and Tcl_SetVar2. *** POTENTIAL INCOMPATIBILITY *** 166. 4/3/93 Eliminated "flags" and "termPtr" arguments to Tcl_Eval. *** POTENTIAL INCOMPATIBILITY *** 167. 4/3/93 Changes to expressions: - The "expr" command now accepts multiple arguments, which are concatenated together with space separators. - Integers aren't automatically promoted to floating-point if they overflow the word size: errors are generated instead. - Tcl can now handle "NaN" and other special values if the underlying library procedures handle them. - When printing floating-point numbers, Tcl ensures that there is a "." or "e" in the number, so it can't be treated as an integer accidentally. The procedure Tcl_PrintDouble is available to provide this function in other contexts. Also, the variable "tcl_precision" can be used to set the precision for printing (must be a decimal number giving digits of precision). - Expressions now support transcendental and other functions, e.g. sin, acos, hypot, ceil, and round. Can add new math functions with Tcl_CreateMathFunc(). - Boolean expressions can now have any of the string values accepted by Tcl_GetBoolean, such as "yes" or "no". *** POTENTIAL INCOMPATIBILITY *** 168. 4/5/93 Changed Tcl_UnsetVar and Tcl_UnsetVar2 to return TCL_OK or TCL_ERROR instead of 0 or -1. *** POTENTIAL INCOMPATIBILITY *** 169. 4/5/93 Eliminated Tcl_CmdBuf structure and associated procedures; can use Tcl_DStrings instead. *** POTENTIAL INCOMPATIBILITY *** 170. 4/8/93 Changed interface to Tcl_TildeSubst to use a dynamic string for buffer space. This makes the procedure re-entrant and thread-safe, whereas it wasn't before. *** POTENTIAL INCOMPATIBILITY *** 171. 4/14/93 Eliminated tclHash.h, and moved everything from it to tcl.h *** POTENTIAL INCOMPATIBILITY *** 172. 4/15/93 Eliminated Tcl_InitHistory, made "history" command always be part of interpreter. *** POTENTIAL INCOMPATIBILITY *** 173. 4/16/93 Modified "file" command so that "readable" option always exists, even on machines that don't support symbolic links (always returns same error as if the file wasn't a symbolic link). 174. 4/26/93 Fixed bugs in "regsub" where ^ patterns didn't get handled right (pretended not to match when it really did, and looped infinitely if -all was specified). 175. 4/29/93 Various improvements in the handling of variables: - Can create variables and array elements during a read trace. - Can delete variables during traces (note: unset traces will be invoked when this happens). - Can upvar to array elements. - Can retarget an upvar to another variable by re-issuing the upvar command with a different "other" variable. 176. 5/3/93 Added Tcl_GetCommandInfo, which returns info about a Tcl command such as whether it exists and its ClientData. Also added Tcl_SetCommandInfo, which allows any of this information to be modified and also allows a command's delete procedure to have a different ClientData value than its command procedure. 177. 5/5/93 Added Tcl_RegExpMatch procedure. 178. 5/6/93 Fixed bug in "scan" where it didn't properly handle %% conversion specifiers. Also changed "scan" to use Tcl_PrintDouble for printing real values. 179. 5/7/93 Added "-exact", "-glob", and "-regexp" options to "lsearch" command to allow different kinds of pattern matching. 180. 5/7/93 Added many new switches to "lsort" to control the sorting process: "-ascii", "-integer", "-real", "-command", "-increasing", and "-decreasing". 181. 5/10/93 Changes to file I/O: - Modified "open" command to support a list of POSIX access flags like {WRONLY CREAT TRUNC} in addition to current fopen-style access modes. Also added "permissions" argument to set permissions of newly-created files. - Fixed Scott Bolte's bug (can close stdin etc. in application and then re-open them with Tcl commands). - Exported access to Tcl's file table with new procedures Tcl_EnterFile and Tcl_GetOpenFile. 182. 5/15/93 Added new "pid" command, which can be used to retrieve either the current process id or a list of the process ids in a pipeline opened with "open |..." 183. 6/3/93 Changed to use GNU autoconfig for configuration instead of the home-brew "config" script. Also made many other configuration-related changes, such as using instead of explicitly declaring system calls in tclUnix.h. 184. 6/4/93 Fixed bug where core-dumps could occur if a procedure redefined itself (the memory for the procedure's body could get reallocated in the middle of evaluating the body); implemented simple reference count mechanism. 185. 6/5/93 Changed tclIndex file format in two ways: (a) it's now eval-ed instead of parsed, which makes it 3-4x faster; (b) the entries in auto_index are now commands to evaluate, which allows commands to be loaded in different ways such as dynamic-loading of C code. The old tclIndex file format is still supported. 186. 6/7/93 Eliminated tclTest program, added new "tclsh" program that is more like wish (allows script files to be invoked automatically using "#!/usr/local/bin/tclsh", makes arguments available to script, etc.). Added support for Tcl_AppInit plus default version; this allows new Tcl applications to be created without modifying the main program for tclsh. 187. 6/7/93 Fixed bug in TclWordEnd that kept backslash-newline from working correctly in some cases during interactive input. 188. 6/9/93 Added Tcl_LinkVar and related procedures, which automatically keep a Tcl variable in sync with a C variable. 189. 6/16/93 Increased maximum nesting depth from 100 to 1000. 190. 6/16/93 Modified "trace var" command so that error messages from within traces are returned properly as the result of the variable access, instead of the generic "access disallowed by trace command" message. 191. 6/16/93 Added Tcl_CallWhenDeleted to provide callbacks when an interpreter is deleted (same functionality as Tcl_WatchInterp, which used to exist in versions before 6.0). 193. 6/16/93 Added "-code" argument to "return" command; it's there primarily for completeness, so that procedures implementing control constructs can reflect exceptional conditions back to their callers. 194. 6/16/93 Split up Tcl.n to make separate manual entries for each Tcl command. Tcl.n now contains a summary of the language syntax. 195. 6/17/93 Added new "switch" command to replace "case": allows alternate forms of pattern matching (exact, glob, regexp), replaces pattern lists with single patterns (but you can use "-" bodies to share one body among several patterns), eliminates "in" noise word. "Case" command is now obsolete. 196. 6/17/93 Changed the "exec", "glob", "regexp", and "regsub" commands to include a "--" switch. All initial arguments starting with "-" are now treated as switches unless a "--" switch is present to end the list. *** POTENTIAL INCOMPATIBILITY *** 197. 6/17/93 Changed auto-exec so that the subprocess gets stdin, stdout, and stderr from the parent. This allows truly interactive sub-processes (e.g. vi) to be auto-exec'ed from a tcl shell command line. 198. 6/18/93 Added patchlevel.h, for use in coordinating future patch releases, and also added "info patchlevel" command to make the patch level available to Tcl scripts. 199. 6/19/93 Modified "glob" command so that a leading "//" in a name gets left as is (this is needed for systems like Apollos where "//" is the super-root; Tcl used to collapse the two slashes into a single slash). 200. 7/7/93 Added Tcl_SetRecursionLimit procedure so that the maximum allowable nesting depth can be controlled for an interpreter from C. ----------------- Released version 7.0 Beta 1, 7/9/93 ------------------ 201. 7/12/93 Modified Tcl_GetInt and tclExpr.c so that full-precision unsigned integers can be specified without overflow errors. 202. 7/12/93 Configuration changes: eliminate leading blank line in configure script; provide separate targets in Makefile for installing binary and non-binary information; check for size_t and a few other potentially missing typedefs; don't put tclAppInit.o into libtcl.a; better checks for matherr support. 203. 7/14/93 Changed tclExpr.c to check the termination pointer before errno after strtod calls, to avoid problems with some versions of strtod that set errno in unexpected ways. 204. 7/16/93 Changed "scan" command to be more ANSI-conformant: eliminated %F, %D, etc., added code to ignore "l", "h", and "L" modifiers but always convert %e, %f, and %g with implicit "l"; also added support for %u and %i. Also changed "format" command to eliminate %D, %U, %O, and add %i. *** POTENTIAL INCOMPATIBILITY *** 205. 7/17/93 Changed "uplevel" and "upvar" so that they can be used from global level to global level: this used to generate an error. 206. 7/19/93 Renamed "setenv", "putenv", and "unsetenv" procedures to avoid conflicts with system procedures with the same names. If you want Tcl's procedures to override the system procedures, do it in the Makefile (instructions are in the Makefile). *** POTENTIAL INCOMPATIBILITY *** ----------------- Released version 7.0 Beta 2, 7/21/93 ------------------ 207. 7/21/93 Fixed bug in tclVar.c where freed memory was accidentally used if a procedure returned an element of a local array. 208. 7/22/93 Fixed bug in "unknown" where it didn't properly handle errors occurring in the "auto_load" procedure, leaving its state inconsistent. 209. 7/23/93 Changed exec's ">2" redirection operator to "2>" for consistency with sh. This is incompatible with earlier beta releases of 7.0 but not with pre-7.0 releases, which didn't support either operator. 210. 7/28/93 Changed backslash-newline handling so that the resulting space character *is* treated as a word separator unless the backslash sequence is in quotes or braces. This is incompatible with 7.0b1 and 7.0b2 but is more compatible with pre-7.0 versions that the b1 and b2 releases were. 211. 7/28/93 Eliminated Tcl_LinkedVarWritable, added TCL_LINK_READ_ONLY to Tcl_LinkVar to accomplish same purpose. This change is incompatible with earlier beta releases, but not with releases before Tcl 7.0. 212. 7/29/93 Renamed regexp C functions so they won't clash with POSIX regexp functions that use the same name. 213. 8/3/93 Added "-errorinfo" and "-errorcode" options to "return" command: these allow for much better handling of the errorInfo and errorCode variables in some cases. 214. 8/12/93 Changed "expr" so that % always returns a remainder with the same sign as the divisor and absolute value smaller than the divisor. 215. 8/14/93 Turned off auto-exec in "unknown" unless the command was typed interactively. This means you must use "exec" when invoking subprocesses, unless it's a command that's typed interactively. *** POTENTIAL INCOMPATIBILITY *** 216. 8/14/93 Added support for tcl_prompt1 and tcl_prompt2 variables to tclMain.c: makes prompts user-settable. 217. 8/14/93 Added asynchronous handlers (Tcl_AsyncCreate etc.) so that signals can be taken cleanly by Tcl applications. 218. 8/16/93 Moved information about open files from the interpreter structure to global variables so that a file can be opened in one interpreter and read or written in another. 219. 8/16/93 Removed ENV_FLAGS from Makefile, so that there's no official support for overriding setenv, unsetenv, and putenv. 220. 8/20/93 Various configuration improvements: coerce chars to unsigned chars before using macros like isspace; source ~/.tclshrc file during initialization if it exists and program is running interactively; allow there to be directories in auto_path that don't exist or don't have tclIndex files (ignore them); added Tcl_Init procedure and changed Tcl_AppInit to call it. 221. 8/21/93 Fixed bug in expr where "+", "-", and " " were all getting treated as integers with value 0. 222. 8/26/93 Added "tcl_interactive" variable to tclsh. 223. 8/27/93 Added procedure Tcl_FilePermissions to return whether a given file can be read or written or both. Modified Tcl_EnterFile to take a permissions mask rather than separate read and write arguments. 224. 8/28/93 Fixed performance bug in "glob" command (unnecessary call to "access" for each file caused a 5-10x slow-down for big directories). ----------------- Released version 7.0 Beta 3, 8/28/93 ------------------ 225. 9/9/93 Renamed regexp.h to tclRegexp.h to avoid conflicts with system include file by same name. 226. 9/9/93 Added Tcl_DontCallWhenDeleted. 227. 9/16/93 Changed not to call exit C procedure directly; instead always invoke "exit" Tcl command so that application can redefine the command to do additional cleanup. 228. 9/17/93 Changed auto-exec to handle names that contain slashes (i.e. don't use PATH for them). 229. 9/23/93 Fixed bug in "read" and "gets" commands where they didn't clear EOF conditions. ----------------- Released version 7.0, 9/29/93 ------------------ 230. 10/7/93 "Scan" command wasn't properly aligning things in memory, so segmentation faults could arise under some circumstances. 231. 10/7/93 Fixed bug in Tcl_ConvertElement where it forgot to backslash leading curly brace when creating lists. 232. 10/7/93 Eliminated dependency of tclMain.c on tclInt.h and tclUnix.h, so that people can copy the file out of the Tcl source directory to make modified private versions. 233. 10/8/93 Fixed bug in auto-loader that reversed the priority order of entries in auto_path for new-style index files. Now things are back to the way they were before 3.0: first in auto_path is always highest priority. 234. 10/13/93 Fixed bug where Tcl_CommandComplete didn't recognize comments and treat them as such. Thus if you typed the line # { interactively, Tcl would think that the command wasn't complete and wait for more input before evaluating the script. 235. 10/14/93 Fixed bug where "regsub" didn't set the output variable if the input string was empty. 236. 10/23/93 Fixed bug where Tcl_CreatePipeline didn't close off enough file descriptors in child processes, causing children not to exit properly in some cases. 237. 10/28/93 Changed "list" and "concat" commands not to generate errors if given zero arguments, but instead to just return an empty string. ----------------- Released version 7.1, 11/4/93 ------------------ Note: there is no 7.2 release. It was flawed and was thus withdrawn shortly after it was released. 238. 11/10/93 TclMain.c didn't compile on some systems because of R_OK in call to "access". Changed to eliminate call to "access". ----------------- Released version 7.3, 11/26/93 ------------------ 239. 11/6/93 Modified "lindex", "linsert", "lrange", and "lreplace" so that "end" can be specified as an index. 240. 11/6/93 Modified "append" and "lappend" to allow only two words total (i.e., nothing to append) without generating an error. 241. 12/2/93 Changed to use EAGAIN as the errno for non-blocking I/O instead of EWOULDBLOCK: this should fix problem where non-blocking I/O didn't work correctly on System-V systems. 242. 12/22/93 Fixed bug in expressions where cancelled evaluation wasn't always working correctly (e.g. "set one 1; eval {1 || 1/$one}" failed with a divide by zero error). 243. 1/6/94 Changed TCL_VOLATILE definition from -1 to the address of a dummy procedure Tcl_Volatile, since -1 causes portability problems on some machines (e.g., Crays). 244. 2/4/94 Added support for unary plus. 245. 2/17/94 Changed Tcl_RecordAndEval and "history" command to call Tcl_GlobalEval instead of Tcl_Eval. Otherwise, invocation of these facilities in nested procedures can cause unwanted results. 246. 2/17/94 Fixed bug in tclExpr.c where an expression such as "expr {"12398712938788234-1298379" != ""}" triggers an integer overflow error for the number in quotes, even though it isn't really a proper integer anyway. 247. 2/19/94 Added new procedure Tcl_DStringGetResult to move result from interpreter to a dynamic string. 248. 2/19/94 Fixed bug in Tcl_DStringResult that caused it to overwrite the contents of a static result in some situations. This can cause bizarre errors such as variables suddenly having empty values. 249. 2/21/94 Fixed bug in Tcl_AppendElement, Tcl_DStringAppendElement, and the "lappend" command that caused improper omission of a separator space in some cases. For example, the script set x "abc{"; lappend x "def" used to return the result "abc{def" instead of "abc{ def". 250. 3/3/94 Tcl_ConvertElement was outputting empty elements as \0 if TCL_DONT_USE_BRACES was set. This depends on old pre-7.0 meaning of \0, which is no longer in effect, so it didn't really work. Changed to output empty elements as {} always. 251. 3/3/94 Renamed Tcl_DStringTrunc to Tcl_DStringSetLength and extended it so that it can be used to lengthen a string as well as shorten it. Tcl_DStringTrunc is defined as a macro for backward compatibility, but it is deprecated. 252. 3/3/94 Added Tcl_AllowExceptions procedure. 253. 3/13/94 Fixed bug in Tcl_FormatCmd that could cause "format" to mis-behave on 64-bit Big-Endian machines. 254. 3/13/94 Changed to use vfork instead of fork on systems where vfork exists. 255. 3/23/94 Fixed bug in expressions where ?: didn't associate right-to-left as they should. 256. 4/3/94 Fixed "exec" to flush any files used in >@ or >&@ redirection in exec, so that data buffered for them is written before any new data added by the subprocess. 257. 4/3/94 Added "subst" command. 258. 5/20/94 The tclsh main program is now called Tcl_Main; tclAppInit.c has a "main" procedure that calls Tcl_Main. This makes it easier to use Tcl with C++ programs, which need their own main programs, and it also allows an application to prefilter the argument list before calling Tcl_Main. *** POTENTIAL INCOMPATIBILITY *** 259. 6/6/94 Fixed bug in procedure returns where the errorInfo variable could get truncated if an unset trace was invoked as part of returning from the procedure. 260. 6/13/94 Added "wordstart" and "wordend" options to "string" command. 261. 6/27/94 Fixed bug in expressions where they didn't properly cancel the evaluation of math functions in &&, ||, and ?:. 262. 7/11/94 Incorrect boolean values, like "ogle", weren't being handled properly. 263. 7/15/94 Added Tcl_RegExpCompile, Tcl_RegExpExec, and Tcl_RegExpRange, which provide lower-level access to regular expression pattern matching. 264. 7/22/94 Fixed bug in "glob" command where "glob -nocomplain ~bad_user" would complain about a missing user. Now it doesn't complain anymore. 265. 8/4/94 Fixed bug with linked variables where they didn't behave correctly when accessed via upvars. 266. 8/17/94 Fixed bug in Tcl_EvalFile where it didn't clear interp->result. 267. 8/31/94 Modified "open" command so that errors in exec-ing subprocesses are returned by the open immediately, rather than being delayed until the "close" is executed. 268. 9/9/94 Modified "expr" command to generate errors for integer overflow (includes addition, subtraction, negation, multiplication, division). 269. 9/23/94 Modified "regsub" to return a count of the number of matches and replacements, rather than 0/1. 279. 10/4/94 Added new features to "array" command: - added "get" and "set" commands for easy conversion between arrays and lists. - added "exists" command to see if a variable is an array, changed "names" and "size" commands to treat a non-existent array (or scalar variable) just like an empty one. - added pattern option to "names" command. 280. 10/6/94 Modified Tcl_SetVar2 so that read traces on variables get called during append operations. 281. 10/20/94 Fixed bug in "read" command where reading from stdin required two control-D's to stop the reading. 282. 11/3/94 Changed "expr" command to use longs for division just like all other expr operators; it previously used ints for division. 283. 11/4/94 Fixed bugs in "unknown" procedure: it wasn't properly handling exception returns from commands that were executed after being auto-loaded. ----------------- Released version 7.4b1, 12/23/94 ------------------ 284. 12/26/94 Fixed "install" target in Makefile (couldn't always find install program). 285. 12/26/94 Added strcncasecmp procedure to compat directory. 286. 1/3/95 Fixed all procedure calls to explicitly cast arguments: implicit conversions from prototypes (especially integer->double) don't work when compiling under non-ANSI compilers. Tcl is now clean under gcc -Wconversion. 287. 1/4/95 Fixed problem in Tcl_ArrayCmd where same name was used for both a label and a variable; caused problems on several older compilers, making array command misbehave and causing many errors in Tcl test suite. ----------------- Released version 7.4b2, 1/12/95 ------------------ 288. 2/9/95 Modified Tcl_CreateCommand to return a token, and added Tcl_GetCommandName procedure. Together, these procedures make it possible to track renames of a command. 289. 2/13/95 Fixed bug in expr where "089" was interpreted as a floating-point number rather than a bogus octal number. *** POTENTIAL INCOMPATIBILITY *** 290. 2/14/95 Added code to Tcl_GetInt and Tcl_GetDouble to check for overflows when reading in numbers. 291. 2/18/95 Changed "array set" to stop after first error, rather than continuing after error. 292. 2/20/95 Upgraded to use autoconf version 2.2. 293. 2/20/95 Fixed core dump that could occur in "scan" command if a close bracket was omitted. 294. 2/27/95 Changed Makefile to always use install-sh for installations: there's just too much variation among "install" system programs, which makes installation flakey. ----------------- Released version 7.4b3, 3/24/95 ------------------ 3/25/95 (bug fix) Changed "install" to "./install" in Makefile so that "make install" will work even when "." isn't in the search path. 3/29/95 (bug fix) Fixed bug where the auto-loading mechanism wasn't protecting the values of the errorCode and errorInfo variables. 3/29/95 (new feature) Added optional pattern argument to "parray" procedure. 3/29/95 (bug fix) Made the full functionality of "return -code ... -errorcode ..." work not just inside procedures, but also in sourced files and at top level. 4/6/95 (new feature) Added "pattern" option to "array names" command. 4/18/95 (bug fix) Fixed bug in parser where it didn't allow backslash-newline immediately after an argument in braces or quotes. 4/19/95 (new feature) Added tcl_library variable, which application can set to override default library directory. 4/30/95 (bug fix) During trace callbacks for array elements, the variable name used in the original reference would be temporarily modified to separate the array name and element name; if the trace callback used the same name string, it would get the wrong name (the array name without element). Fixed to restore the variable name before making trace callbacks. 4/30/95 (new feature) Added -nobackslashes, -nocommands, and -novariables switches to "subst" command. 5/4/95 (new feature) Added TCL_EVAL_GLOBAL flag to Tcl_RecordAndEval. 5/5/95 (bug fix) Format command would overrun memory when printing integers with very large precision, as in "format %.1000d 0". 5/5/95 (portability improvement) Changed to use BSDgettimeofday on IRIX machines, to avoid compilation problems with the gettimeofday declaration. 5/6/95 (bug fix) Changed manual entries to use the standard .TH macro instead of a custom .HS macro; the .HS macro confuses index generators like makewhatis. 5/9/95 (bug fix) Modified configure script to check for Solaris bug that makes vfork unreliable (core dumps result if vforked child changes a signal handler); will use fork instead of vfork if the bug is present. 6/5/95 (bug fix) Modified "lsort" command to disallow recursive calls to lsort from a comparison function. This is needed because qsort is not reentrant. 6/5/95 (bug fix) Undid change 243 above: changed TCL_VOLATILE and TCL_DYNAMIC back to integer constants rather than procedure addresses. This was needed because procedure addresses can have multiple values under some dynamic loading systems (e.g. SunOS 4.1 and Windows). 6/8/95 (feature change) Modified interface to Tcl_Main to pass in the address of the application-specific initialization procedure. Tcl_AppInit is no longer hardwired into Tcl_Main. This is needed in order to make Tcl a shared library. 6/8/95 (feature change) Modified Makefile so that the installed versions of tclsh and libtcl.a have version number in them (e.g. tclsh7.4 and libtcl7.4.a) and the library directory name also has an embedded version number (e.g., /usr/local/lib/tcl7.4). This should make it easier for Tcl 7.4 to coexist with earlier versions. ----------------- Released version 7.4b4, 6/17/95 ------------------ ed version 7.3, 11/26/93 ------------------ 239. 11/6/93 Modified "lindex", "linsert", "lrange", and "lreplace" so that "end" can be specified as an index. 240. 11/6/93 Modified "append" and "lappend" to allow only two words total (i.e., nothing to append) without generating an error. 241. 12tcl7.4b4/README010044400630510000012000000331470577032331600137200ustar00ousterstaff00002300000001Tcl by John Ousterhout john.ousterhout@eng.sun.com @(#) README 1.13 95/06/16 08:44:06 1. Introduction --------------- This directory contains the sources and documentation for Tcl, an embeddable tool command language. The information here corresponds to release 7.4b4 (a beta release of Tcl 7.4). This release contains many bug fixes and a few new features; it should be backwards compatible with Tcl 7.3 except for one change related to Tcl_AppInit (see below for details). 2. Documentation ---------------- The best way to get started is to read "the Tcl book": Title: Tcl and the Tk Toolkit Author: John K. Ousterhout Publisher: Addison-Wesley ISBN: 0-201-63337-X The "doc" subdirectory in this release contains a complete set of reference manual entries for Tcl. Files with extension ".1" are for programs (for example, tclsh.1); files with extension ".3" are for C library procedures; and files with extension ".n" describe Tcl commands. The file "doc/Tcl.n" gives a quick summary of the Tcl language syntax. To print any of the man pages, cd to the "doc" directory and invoke your favorite variant of troff using the normal -man macros, for example ditroff -man Tcl.n to print Tcl.n. If Tcl has been installed correctly and your "man" program supports it, you should be able to access the Tcl manual entries using the normal "man" mechanisms, such as man Tcl 3. Compiling and installing Tcl ------------------------------- This release should compile and run either "out of the box" or with trivial changes on any UNIX-like system that approximates POSIX, BSD, or System V. I know that it runs on workstations from Sun, H-P, and DEC. To compile Tcl, do the following: (a) Check for patches. Look in the FTP directory from which you retrieved the base distribution and see if there are files with names like tcl7.4p1.patch, tcl7.4p2patch, etc. These files may also have .Z extensions to indicate compression. If you find any patch files, apply them to the source directory in order from "p1" up. To apply an uncompressed patch file such as tcl7.4p1.patch, invoke a shell command like the following from the directory containing this file: patch -p < tcl7.4p1.patch If the patch file is compressed, invoke a command like the following: zcat tcl7.4p2.patch.Z | patch -p (b) Type "./configure" in this directory. This runs a configuration script created by GNU autoconf, which configures Tcl for your system and creates a Makefile. The configure script allows you to customize the Tcl configuration for your site; for details on how you can do this, check out the autoconf documenation (not included here). (c) Type "make". This will create a library archive called "libtcl.a" and an interpreter application called "tclsh" that allows you to type Tcl commands interactively or execute script files. (d) If the make fails then you'll have to personalize the Makefile for your site or possibly modify the distribution in other ways. First check the file "porting.notes" to see if there are hints for compiling on your system. If you need to modify Makefile, there are comments at the beginning of it that describe the things you might want to change and how to change them. (e) Type "make install" to install Tcl binaries and script files in standard places. You'll need write permission on the installation directoryies to do this. The installation directories are determined by the "configure" script and may be specified with the --prefix and --exec_prefix options to "configure". See the Makefile for information on what directories were chosen; you can override these choices by modifying the "prefix" and "exec_prefix" variables in the Makefile. (f) At this point you can play with Tcl by invoking the "tclsh" program and typing Tcl commands. However, if you haven't installed Tcl then you'll first need to set your TCL_LIBRARY variable to hold the full path name of the "library" subdirectory. Note that the installed versions of tclsh and libtcl.a have a version number in their names, such as "tclsh7.4" or "libtcl7.4.a"; to use the installed versions, either specify the version number or create a symbolic link (e.g. from "tclsh" to "tclsh7.4"). If you have trouble compiling Tcl, I'd suggest looking at the file "porting.notes". It contains information that people have sent me about changes they had to make to compile Tcl in various environments. I make no guarantees that this information is accurate, complete, or up-to-date, but you may find it useful. If you get Tcl running on a new configuration, I'd be happy to receive new information to add to "porting.notes". I'm also interested in hearing how to change the configuration setup so that Tcl compiles out of the box on more platforms. 4. Test suite ------------- There is a relatively complete test suite for all of the Tcl core in the subdirectory "tests". To use it just type "make test" in this directory. You should then see a printout of the test files processed. If any errors occur, you'll see a much more substantial printout for each error. See the README file in the "tests" directory for more information on the test suite. The Tcl test suite is very sensitive to proper implementation of ANSI C library procedures such as sprintf and sscanf. If the test suite generates errors, most likely they are due to non-conformance of your system's ANSI C library; such problems are unlikely to affect any real applications so it's probably safe to ignore them. 5. Additional release information --------------------------------- There is now an official home for Tcl and Tk on the Web at the following URL: http://www.smli.com/research/tcl These Web pages include release updates, reports on bug fixes and porting issues, and pointers to many other Tcl/Tk Web pages at other sites. Check them out! (The name of the machine for the Tcl/Tk home page may change in the future, so if the above URL doesn't work, try "http://www.sunlabs.com/research/tcl".) 6. Summary of changes in recent releases ---------------------------------------- This is the fourth (and probably last) beta release of Tcl 7.4. Tcl 7.4b4 contains several bug fixes, plus the following new and changed features: 1. Added new options to the "subst" command: -nobackslashes, -nocommands, and -novariables. 2. Added optional pattern argument to "parray" library procedure and "array names" command. 3. Added tcl_library variable (whose value is now returned by the "info library" command). This allows the application to change the location of the Tcl libraries. 4. Added TCL_EVAL_GLOBAL flag to Tcl_RecordAndEval. 5. Modified interface to Tcl_Main to pass in the address of the Tcl_AppInit procedure as argument (more flexible, plus handles dynamic linking better). 6. Changed name of installed versions of binaries from tclsh and libtcl.a to tclsh7.4 and libtcl7.4.a, for easier coexistence with older versions. Tcl 7.4 is a minor release. There are many bug fixes (most of them minor), but only a few new features and just one potential incompatibility. For complete information on what has changed, see the file "changes". The one incompatible change is that Tcl no longer provides a "main" procedure by default. What used to be "main" is now called "Tcl_Main", and each application needs to provide a "main" that calls "Tcl_Main". Typically this is done in the tclAppInit.c file; see the tclAppInit.c file in the distribution for an example. Here is a summary of the new features in Tcl 7.4: 1. Added new "subst" command for making $ and [] substitutions on an strings. 2. The "array" command has several new features: - "get" and "set" commands for conversion between arrays and strings. - "exists" command for checking for array element existence. - "names" and "size" commands now treat a non-existent array the same as an empty one. - "names" takes an optional pattern argument. 3. "lindex", "linsert", "lrange", and "lreplace" all accept "end" as an index. 4. Expressions support unary "+". 5. The "string" command has new "wordstart" and "wordend" options. 6. Tcl now exports the procedures Tcl_RegExpCompile, Tcl_RegExpExec, and Tcl_RegExpRange for C-level access to pattern matching. 7. When an error occurs while creating a pipeline with "open", it is returned immediately as the result of the "open" rather than being delayed until the "close" command. 8. "regsub" now returns a count of the number of matches and replacements, rather than 0/1. 9. Added mechanism for tracking renames of commands. See the new procedure Tcl_GetCommandName. 10. Added tcl_library variable (whose value is now returned by the "info library" command). This allows the application to change the location of the Tcl libraries. 7. Tcl newsgroup ----------------- There is a network news group "comp.lang.tcl" intended for the exchange of information about Tcl, Tk, and related applications. Feel free to use the newsgroup both for general information questions and for bug reports. I read the newsgroup and will attempt to fix bugs and problems reported to it. 8. Tcl contributed archive -------------------------- Many people have created exciting packages and applications based on Tcl and made them freely available to the Tcl community. An archive of these contributions is kept on the machine ftp.aud.alcatel.com. You can access the archive using anonymous FTP; the Tcl contributed archive is in the directory "/tcl". The archive also contains several FAQ ("frequently asked questions") documents that provide solutions to problems commonly encountered by TCL newcomers. 9. Support and bug fixes ------------------------ We're very interested in receiving bug reports and suggestions for improvements. I suggest sending this information to the comp.lang.tcl newsgroup rather than to me. We'll see anything on comp.lang.tcl, and in addition someone else who reads comp.lang.tcl may be able to offer a solution. Bugs usually get fixed in 1-3 weeks, but enhancements may take a while and may not happen at all unless there is widespread support for them (I'm trying to slow the rate at which Tcl turns into a kitchen sink). It's almost impossible to make incompatible changes to Tcl at this point. When reporting bugs, please provide a short tclsh script that we can use to reproduce the bug. Make sure that the script runs with a bare-bones tclsh and doesn't depend on any extensions or other programs, particularly those that exist only at your site. Also, please include three additional pieces of information with the script: (a) how do we use the script to make the problem happen (e.g. what things do we click on, in what order)? (b) what happens when you do these things (presumably this is undesirable)? (c) what did you expect to happen instead? The Tcl community is too large for us to provide much individual support for users. If you need help I suggest that you post questions to comp.lang.tcl. We read the newsgroup and will attempt to answer esoteric questions for which no-one else is likely to know the answer. In addition, Tcl support and training are available commercially from NeoSoft (info@neosoft.com), Computerized Processes Unlimited (gwl@cpu.com), and Data Kinetics (education@dkl.com). 9. Tcl release organization --------------------------- Each Tcl release is identified by two numbers separated by a dot, e.g. 6.7 or 7.0. If a new release contains changes that are likely to break existing C code or Tcl scripts then the major release number increments and the minor number resets to zero: 6.0, 7.0, etc. If a new release contains only bug fixes and compatible changes, then the minor number increments without changing the major number, e.g. 7.1, 7.2, etc. If you have C code or Tcl scripts that work with release X.Y, then they should also work with any release X.Z as long as Z > Y. Beta releases have an additional suffix of the form bx. For example, Tcl 7.0b1 is the first beta release of Tcl version 7.0, Tcl 7.0b2 is the second beta release, and so on. A beta release is an initial version of a new release, used to fix bugs and bad features before declaring the release stable. Each new release will be preceded by one or more beta releases. We hope that lots of people will try out the beta releases and report problems back to me. We'll make new beta releases to fix the problems, until eventually there is a beta release that appears to be stable. Once this occurs we'll remove the beta suffix so that the last beta release becomes the official release. If a new release contains incompatibilities (e.g. 7.0) then we can't promise to maintain compatibility among its beta releases. For example, release 7.0b2 may not be backward compatible with 7.0b1. we'll try to minimize incompatibilities between beta releases, but if a major problem turns up then we'll fix it even if it introduces an incompatibility. Once the official release is made then there won't be any more incompatibilities until the next release with a new major version number. 10. Compiling on non-UNIX systems -------------------------------- The Tcl features that depend on system calls peculiar to UNIX (stat, fork, exec, times, etc.) are now separate from the main body of Tcl, which only requires a few generic library procedures such as malloc and strcpy. Thus it should be relatively easy to compile Tcl for non-UNIX machines such as MACs and DOS PC's, although a number of UNIX-specific commands will be absent (e.g. exec, time, and glob). See the comments at the top of Makefile for information on how to compile without the UNIX features. rmation to add to "porting.notes". I'm also interested in hearing how to change the configuration setup so that Tcl compiles out of the box on more platforms. 4. Test suite ------------- There is a relatively complete test suite for all of the Tcl core in the subdirectory "tests". To use it just type "make test" in this directory. You should then see a printout of the test files processed. If any errotcl7.4b4/porting.notes010044400630510000012000000100640575470475400156000ustar00ousterstaff00002300000001This file contains a collection of notes that various people have provided about porting Tcl to various machines and operating systems. I don't have personal access to any of these machines, so I make no guarantees that the notes are correct, complete, or up-to-date. If you see the word "I" in any explanations, it refers to the person who contributed the information, not to me; this means that I probably can't answer any questions about any of this stuff. In some cases, a person has volunteered to act as a contact point for questions about porting Tcl to a particular machine; in these cases the person's name and e-mail address are listed. I'm very interested in getting new porting information to add to the file; please mail updates to "john.ousterhout@eng.sun.com". This file reflects information provided for Tcl 7.4 and later releases. If there is no information for your configuration in this file, check the file "porting.old" too; it contains information that was submitted for Tcl 7.3 and earlier releases, and some of that information may still be valid. Porting information is likely to become available on the Web sometime soon. You might try the following URLs: http://www.smli.com/research/tcl http://www.smli.com/tcl http://www.smli.com/~ouster http://playground.sun.com/~ouster sccsid = @(#) porting.notes 1.8 95/05/12 09:16:44 -------------------------------------------- Solaris, various versions -------------------------------------------- 1. If typing "make test" results in an error message saying that there are no "*.test" files, or you get lots of globbing errors, it's probably because your system doesn't have cc installed and you used gcc. In order for this to work, you have to set your CC environment variable to gcc and your CPP environment variable to "gcc -E" before running the configure script. 2. Make sure that /usr/ucb is not in your PATH or LD_LIBRARY_PATH environment variables; this will cause confusion between the new Solaris libraries and older UCB versions (Tcl will expect one version and get another). -------------------------------------------- Pyramid DC/OSx SVr4, DC/OSx version 94c079 -------------------------------------------- Tcl seems to dump core in cmdinfo.test when compiled with the optimiser turned on in TclEval which calls 'free'. To get around this, turn the optimiser off. -------------------------------------------- SGI machines, IRIX 5.2, 5.3, IRIX64 6.0.1 -------------------------------------------- 1. If you compile with gcc-2.6.3 under some versions of IRIX (e.g. 4.0.5), DBL_MAX is defined too large for gcc and Tcl complains about all floating-point values being too large to represent. If this happens, redefining DBL_MAX to 9.99e299. -------------------------------------------- IBM RTs, AOS -------------------------------------------- 1. Steal fmod from 4.4BSD 2. Add a #define to tclExpr such that: extern double fmod(); is defined conditionally on ibm032 -------------------------------------------- FreeBSD -------------------------------------------- FreeBSD's math library does not properly handle floating-point exceptions, which can cause core dumps. The following patch eliminates the problem: *** tclBasic.c:1.1.1.1 Tue Sep 27 15:49:29 1994 --- tclBasic.c Tue Sep 27 15:49:29 1994 *************** *** 35,40 **** --- 35,42 ---- # include "tclUnix.h" #endif + #include + /* * The following structure defines all of the commands in the Tcl core, * and the C procedures that execute them. *************** *** 276,281 **** --- 278,285 ---- error $msg\n\ }"; + fpsetround(FP_RN); + fpsetmask(0L); return Tcl_Eval(interp, initCmd); } -------------------------------------------- Solaris 2.3 and 2.4 -------------------------------------------- There have been several reports of problems with the "glob" command. So far these reports have all been for older versions of Tcl, but if you run into problems, edit the Makefile after "configure" is run and add "-DNO_DIRENT_H=1" to the definitions of DEFS. Do this before compiling. tcl7.4b4/porting.old010044400630510000012000000344750567535664400152450ustar00ousterstaff00002300000001This is an old version of the file "porting.notes". It contains porting information that people submitted for Tcl releases numbered 7.3 and earlier. You may find information in this file useful if there is no information available for your machine in the current version of "porting.notes". I don't have personal access to any of these machines, so I make no guarantees that the notes are correct, complete, or up-to-date. If you see the word "I" in any explanations, it refers to the person who contributed the information, not to me; this means that I probably can't answer any questions about any of this stuff. In some cases, a person has volunteered to act as a contact point for questions about porting Tcl to a particular machine; in these cases the person's name and e-mail address are listed. sccsid = @(#) porting.old 1.2 94/12/19 11:23:18 --------------------------------------------- Cray machines running UNICOS: Contact: John Freeman (jlf@cray.com) --------------------------------------------- 1. There is an error in the strstr function in UNICOS such that if the string to be searched is empty (""), the search will continue past the end of the string. Because of this, the history substitution loop will sometimes run past the end of its target string and trash malloc's free list, resulting in a core dump some time later. (As you can probably guess, this took a while to diagnose.) I've submitted a problem report to the C library maintainers, but in the meantime here is a workaround. ----------------------------------------------------------------- diff -c1 -r1.1 tclHistory.c *** 1.1 1991/11/12 16:01:58 --- tclHistory.c 1991/11/12 16:14:22 *************** *** 23,24 **** --- 23,29 ---- #include "tclInt.h" + + #ifdef _CRAY + /* There is a bug in strstr in UNICOS; this works around it. */ + #define strstr(s1,s2) ((s1)?(*(s1)?strstr((s1),(s2)):0):0) + #endif _CRAY --------------------------------------------- MIPS systems runing EP/IX: --------------------------------------------- 1. Need to add a line "#include " in tclUnix.h. 2. Need to add "-lbsd" into the line that makes tclTest: ${CC} ${CFLAGS} tclTest.o libtcl.a -lbsd -o tclTest --------------------------------------------- IBM RS/6000 systems running AIX: --------------------------------------------- 1. The system version of strtoul is buggy, at least under some versions of AIX. If the expression tests fail, try forcing Tcl to use its own version of strtoul instead of the system version. To do this, first copy strtoul.c from the compat subdirectory up to the main Tcl directory. Then modify the Makefile so that the definition for COMPAT_OBJS includes "strtoul.o". Note: the "config" script should now detect the buggy strtoul and substitute Tcl's version automatically. 2. You may have to comment out the declaration of open in tclUnix.h. 3. You may need to add "-D_BSD -lbsd" to the CFLAGS definition. This causes the system include files to look like BSD include files and causes C library routines to act like bsd library routines. Without this, the system may choke on "struct wait". --------------------------------------------- AT&T 4.03 OS: --------------------------------------------- Machine: i386/33Mhz i387 32k Cache 16MByte OS: AT&T SYSV Release 4 Version 3 X: X11R5 fixlevel 9 Xserver: X386 1.2 1. Change the Tk Makefile as follows: XLIB = -lX11 should be changed to: XLIB = -lX11 -lsocket -lnsl ------------------------------------------------------- Silicon Graphics systems: ------------------------------------------------------- 1. Change the CC variable in the Makefile to: CC = cc -xansi -D__STDC__ -signed 2. In Irix releases 4.0.1 or earlier the C compiler has a buggy optimizer. If Tcl fails its test suite or generates inexplicable errors, compile tclVar.c with -O0 instead of -O. 3. For IRIX 5.1 or later, comments 1 and 2 are no longer relevant, but you must add -D_BSD_SIGNALS to CFLAGS to get the proper signal routines. 4. Add a "-lsun" switch in the targets for tclsh and tcltest, just before ${MATH_LIBS}. 5. Rumor has it that you also need to add the "-lmalloc" library switch in the targets for tclsh and tcltest. 6. In IRIX 5.2 you'll have to modify Makefile to fix the following problems: - The "-c" option is illegal with this version of install, but the "-F" switch is needed instead. Change this in the "INSTALL =" definition line. - The order of file and directory have to be changed in all the invocations of INSTALL_DATA or INSTALL_PROGRAM. --------------------------------------------- NeXT machines running NeXTStep 3.1: --------------------------------------------- 1. Run configure with predefined CPP: CPP='cc -E' ./configure (If your shell is [t]csh, do a "setenv CPP 'cc -E' ") 2. Edit Makefile: -add tmpnam.o to COMPAT_OBJS: COMPAT_OBJS = getcwd.o waitpid.o strtod.o tmpnam.o -add the following to AC_FLAGS: -Dstrtod=tcl_strtod 3. Edit compat/tmpnam.c and replace "/usr/tmp" with "/tmp" After this, tcl7.0 will be build fine on NeXT (ignore linker warning) and run all the tests. There are some formatting problems in printf() or scanf() which come from NeXT's lacking POSIX conformance. Ignore those errors, they don't matter much. 4. Additional information that may apply to NeXTStep 3.2 only: The problem on NEXTSTEP 3.2 is that the configure script makes some bad assumptions about the uid_t and gid_t types. Actually, the may have been valid for NEXTSTEP 3.0, or it may be NEXTSTEP's rudimentary attempt at POSIX support under 3.2, but no matter what the reason, the configure script sets up the Makefile with CFLAGS '-Duid_t=int' and '-Dgid_t=int', which are, unfortunately, incorrect, since they shoudl actually be (I think) unsigned shorts. This causes problems when the 'stat' structure is included, since it throws off the field offsets from what the 'fstat' function thinks they should be. Anyway, the quick fix is to run configure and then edit the Makefile to remove the uid_t and gid_t defines. This will allow tcl and Tk to compile and run. There are some other problems on NEXTSTEP, specifically with %g in the printf family of functions, but making the uid_t and gid_t change will get it up and running. --------------------------------------------- NeXT machines running NeXTStep 3.2: --------------------------------------------- 1. Run configure with predefined CPP: CPP='cc -E' ./configure (If your shell is [t]csh, do a "setenv CPP 'cc -E' ") 2. Edit Makefile: -add tmpnam.o to COMPAT_OBJS: COMPAT_OBJS = getcwd.o waitpid.o strtod.o tmpnam.o -add the following to AC_FLAGS: -Dstrtod=tcl_strtod -add '-m' to MATH_LIBS: MATH_LIBS = -m -lm -add '-O2 -arch m68k -arch i386' to CFLAGS: CFLAGS = -O2 -arch m68k -arch i386 ------------------------------------------------- ISC 2.2 UNIX (using standard ATT SYSV compiler): ------------------------------------------------- In Makefile, change CFLAGS = -g -I. -DTCL_LIBRARY=\"${TCL_LIBRARY}\" to CFLAGS = -g -I. -DPOSIX_JC -DTCL_LIBRARY=\"${TCL_LIBRARY}\" This brings in the typedef for pid_t, which is needed for /usr/include/sys/wait.h in tclUnix.h. --------------------------------------------- DEC Alphas: --------------------------------------------- 1. There appears to be a compiler/library bug that causes core-dumps unless you compile tclVar.c without optimization (remove the -O compiler switch). The problem appears to have been fixed in the 1.3-4 version of the compiler. --------------------------------------------- CDC 4680MP, EP/IX 1.4.3: --------------------------------------------- The installation was done in the System V environment (-systype sysv) with the BSD extensions available (-I/usr/include/bsd and -lbsd). It was built with the 2.20 level C compiler. The 2.11 level should not be used because it has a problem with detecting NaN values in lines like: if (x != x) ... which appear in the TCL code. To make the configure script find the BSD extensions, I set environment variable DEFS to "-I/usr/include/bsd" and LIBS to "-lbsd" before running it. I would have also set CC to "cc2.20", but that compiler driver has a bug that loader errors (e.g. not finding a library routine, which the script uses to tell what is available) do not cause an error status to be returned to the shell (but see the comments about "-non_shared" below in the 2.1.1 notes). There is a bug in the include file that mis-defines the structure fields and causes WIFEXITED and WIFSIGNALED to return incorrect values. My solution was to create a subdirectory "sys" of the main TCL source directory and put a corrected wait.h in it. The "-I." already on all the compile lines causes it to be used instead of the system version. To fix this, compare the structure definition in /usr/include/bsd/sys/wait.h with /bsd43/include/sys/wait.h (or mail to John Jackson, jrj@cc.purdue.edu, and he'll send you a context diff). After running configure, I made the following changes to Makefile: 1) In AC_FLAGS, change: -DNO_WAIT3=1 to -DNO_WAIT3=0 -Dwait3=wait2 EP/IX (in the System V environment) provides a wait2() system call with what TCL needs (the WNOHANG flag). The extra parameter TCL passes to what it thinks is wait3() (the resources used by the child process) is always zero and will be safely ignored. 2) Change: CC=cc to CC=cc2.20 because of the NaN problem mentioned earlier. Skip this if the default compiler is already 2.20 (or later). 3) Add "-lbsd" to the commands that create tclsh and tcltest (look for "-o"). --------------------------------------------- CDC 4680MP, EP/IX 2.1.1: --------------------------------------------- The installation was done in the System V environment (-systype sysv) with the BSD extensions available (-I/usr/include/bsd and -lbsd). It was built with the 3.11 level C compiler. The 2.11 level should not be used because it has a problem with detecting NaN values in lines like: if (x != x) ... which appear in the TCL code. The 2.20 compiler does not have this problem. To make the configure script find the BSD extensions, I set environment variable DEFS to: "-I/usr/include/bsd -D__STDC__=0 -non_shared" and LIBS to: "-lbsd" before running it. The "-non_shared" is needed because with shared libraries, the compiler (actually, the loader) does not report an error for "missing" routines. The configuration script depends on this error to know what routines are available. This is the real problem I reported above for EP/IX 1.4.3 that I incorrectly attributed to a compiler driver bug. I don't have 1.4.3 available any more, but it's possible using "-non_shared" on it would have solved the problem. The same bug exists at 2.1.1 (yes, I have reported it to CDC), and the same fix as described in the 1.4.3 porting notes works. In addition to the three Makefile changes described in the 1.4.3 notes, you can remove the "-non_shared" flag from AC_FLAGS. It is only needed for the configuration step, not the build. You will get duplicate definition compilation warnings of: DBL_MIN DBL_MAX FLT_MIN FLT_MAX during tclExpr.c. These can be ignored. During expr.test, you will get a failure for one of the "fmod" tests unless you have CDC patch CC40038311 installed. --------------------------------------------- Convex systems, OS 10.1 and 10.2: Contact: Lennart Sorth (ls@dmi.min.dk) --------------------------------------------- 1. tcl7.0b2 compiles on Convex systems (OS 10.1 and 10.2) by just running configure, typing make, except tclUnixUtil.c needs to be compiled with option "-pcc" (portable cc, =!ANSI) due to: cc: Error on line 1111 of tclUnixUtil.c: 'waitpid' redeclared: incompatible types. ------------------------------------------------- Pyramid, OSx 5.1a (UCB universe, GCC installed): ------------------------------------------------- 1. The procedures memcpy, strchr, fmod, and strrchr are all missing, so you'll need to provide substitutes for them. After you do that everything should compile fine. There will be one error in a scan test, but it's an obscure one because of a non-ANSI implementation of sscanf on the machine; you can ignore it. 2. You may also have to add "tmpnam.o" to COMPAT_OBJS in Makefile: the system version appears to be bad. ------------------------------------------------- Encore 91, UMAX V 3.0.9.3: ------------------------------------------------- 1. Modify the CFLAGS assignment in file Makefile.in to include the -DENCORE flag in Makefile: CFLAGS = -O -DENCORE 2. "mkdir" does not by default create the parent directories. The mkdir directives should be modified to "midir -p". ------------------------------------------------- Sequent machines running Dynix: Contact: Andrew Swan (aswan@soda.berkeley.edu) ------------------------------------------------- 1. Use gcc instead of the cc distributed by Sequent 2. The distributed math library does not include the fmod function. Source for fmod can be retrieved from a BSD source archive (such as ftp.uu.net) and included in the compat directory. Add fmod.o to the COMPAT_OBJS variable in the Makefile. You may need to comment out references to 'isnan' and 'finite' in fmod.c 3. If the linker complains that there are two copies of the 'tanh' function, use the ar command to extract the objects from the math library and build a new one without tanh.o 4. The *scanf functions in the Sequent libraries are apparently broken, which will cause the scanning tests to fail. The cases that fail are fairly obscure. Using GNU libc apparently solves this problem. ------------------------------------------------- Systems running Interactive 4.0: ------------------------------------------------- 1. Add "-posix -D_SYSV3" to CFLAGS in Makefile (or Makefile.in). ------------------------------------------------- Systems running FreeBSD 1.1.5.1: ------------------------------------------------- The following changes comprise the entire porting effort of tcl7.3 to FreeBSD (i.e. these were the changes to tclTest.c) and should probably be made part of the tcl distribution. The changes only effect the way that floating point exceptions are reported. I've choosen to move the changes out of tclTest.c and into tclBasic.c. in tclBasic.c at top-of-file: #ifdef BSD_NET2 #include #endif in tclBasic.c in Tcl_Init(): #ifdef BSD_NET2 fpsetround(FP_RN); fpsetmask(0L); #endif waitpid.o strtod.o tmpnam.o -add the following to AC_FLAGS: -Dstrtod=tcl_strtod 3. Edit compat/tmpnam.c and replace "/usr/tmp" with "/tmp" After this, tcl7.0 will be build fine on NeXT (igntcl7.4b4/license.terms010044400630510000012000000033060567470030500155300ustar00ousterstaff00002300000001This software is copyrighted by the Regents of the University of California, Sun Microsystems, Inc., and other parties. The following terms apply to all files associated with the software unless explicitly disclaimed in individual files. The authors hereby grant permission to use, copy, modify, distribute, and license this software and its documentation for any purpose, provided that existing copyright notices are retained in all copies and that this notice is included verbatim in any distributions. No written agreement, license, or royalty fee is required for any of the authorized uses. Modifications to this software may be copyrighted by their authors and need not follow the licensing terms described here, provided that the new terms are clearly indicated on the first page of each file where they apply. IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. RESTRICTED RIGHTS: Use, duplication or disclosure by the government is subject to the restrictions as set forth in subparagraph (c) (1) (ii) of the Rights in Technical Data and Computer Software Clause as DFARS 252.227-7013 and FAR 52.227-19. tcl7.4b4/install-sh010055500630510000012000000042120564727501300150360ustar00ousterstaff00002300000001#!/bin/sh # # install - install a program, script, or datafile # This comes from X11R5; it is not part of GNU. # # $XConsortium: install.sh,v 1.2 89/12/18 14:47:22 jim Exp $ # # This script is compatible with the BSD install script, but was written # from scratch. # # set DOITPROG to echo to test this script # Don't use :- since 4.3BSD and earlier shells don't like it. doit="${DOITPROG-}" # put in absolute paths if you don't have them in your path; or use env. vars. mvprog="${MVPROG-mv}" cpprog="${CPPROG-cp}" chmodprog="${CHMODPROG-chmod}" chownprog="${CHOWNPROG-chown}" chgrpprog="${CHGRPPROG-chgrp}" stripprog="${STRIPPROG-strip}" rmprog="${RMPROG-rm}" instcmd="$mvprog" chmodcmd="" chowncmd="" chgrpcmd="" stripcmd="" rmcmd="$rmprog -f" mvcmd="$mvprog" src="" dst="" while [ x"$1" != x ]; do case $1 in -c) instcmd="$cpprog" shift continue;; -m) chmodcmd="$chmodprog $2" shift shift continue;; -o) chowncmd="$chownprog $2" shift shift continue;; -g) chgrpcmd="$chgrpprog $2" shift shift continue;; -s) stripcmd="$stripprog" shift continue;; *) if [ x"$src" = x ] then src=$1 else dst=$1 fi shift continue;; esac done if [ x"$src" = x ] then echo "install: no input file specified" exit 1 fi if [ x"$dst" = x ] then echo "install: no destination specified" exit 1 fi # If destination is a directory, append the input filename; if your system # does not like double slashes in filenames, you may need to add some logic if [ -d $dst ] then dst="$dst"/`basename $src` fi # Make a temp file name in the proper directory. dstdir=`dirname $dst` dsttmp=$dstdir/#inst.$$# # Move or copy the file name to the temp name $doit $instcmd $src $dsttmp # and set any options; do chmod last to preserve setuid bits if [ x"$chowncmd" != x ]; then $doit $chowncmd $dsttmp; fi if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dsttmp; fi if [ x"$stripcmd" != x ]; then $doit $stripcmd $dsttmp; fi if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dsttmp; fi # Now rename the file to the real destination. $doit $rmcmd $dst $doit $mvcmd $dsttmp $dst exit 0 sh,v 1.2 89/12/18 14:47:22 jim Exp $ # # This script is compatible with the BSD install script, but was written # from scratch. # # set DOITPROG to echo to test this script # Don't use :- since 4.3BSD and earlier shells don't like it. doit="${DOITPROG-}" # put in absolute paths if you don't have them in your path; or use env. vars. mvprog="${MVPROG-mv}" cpprog="${CPtcl7.4b4/library/004077500630510000012000000000000577032343000145005ustar00ousterstaff00002300000001tcl7.4b4/library/license.terms010044400630510000012000000033060567470030500171740ustar00ousterstaff00002300000001This software is copyrighted by the Regents of the University of California, Sun Microsystems, Inc., and other parties. The following terms apply to all files associated with the software unless explicitly disclaimed in individual files. The authors hereby grant permission to use, copy, modify, distribute, and license this software and its documentation for any purpose, provided that existing copyright notices are retained in all copies and that this notice is included verbatim in any distributions. No written agreement, license, or royalty fee is required for any of the authorized uses. Modifications to this software may be copyrighted by their authors and need not follow the licensing terms described here, provided that the new terms are clearly indicated on the first page of each file where they apply. IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. RESTRICTED RIGHTS: Use, duplication or disclosure by the government is subject to the restrictions as set forth in subparagraph (c) (1) (ii) of the Rights in Technical Data and Computer Software Clause as DFARS 252.227-7013 and FAR 52.227-19. tcl7.4b4/library/init.tcl010044400630510000012000000175770576565442400161770ustar00ousterstaff00002300000001# init.tcl -- # # Default system startup file for Tcl-based applications. Defines # "unknown" procedure and auto-load facilities. # # @(#) init.tcl 1.37 95/03/29 10:26:32 # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # set auto_path [info library] set errorCode "" set errorInfo "" # unknown: # Invoked when a Tcl command is invoked that doesn't exist in the # interpreter: # # 1. See if the autoload facility can locate the command in a # Tcl script file. If so, load it and execute it. # 2. If the command was invoked interactively at top-level: # (a) see if the command exists as an executable UNIX program. # If so, "exec" the command. # (b) see if the command requests csh-like history substitution # in one of the common forms !!, !, or ^old^new. If # so, emulate csh's history substitution. # (c) see if the command is a unique abbreviation for another # command. If so, invoke the command. proc unknown args { global auto_noexec auto_noload env unknown_pending tcl_interactive global errorCode errorInfo # Save the values of errorCode and errorInfo variables, since they # may get modified if caught errors occur below. The variables will # be restored just before re-executing the missing command. set savedErrorCode $errorCode set savedErrorInfo $errorInfo set name [lindex $args 0] if ![info exists auto_noload] { # # Make sure we're not trying to load the same proc twice. # if [info exists unknown_pending($name)] { unset unknown_pending($name) if {[array size unknown_pending] == 0} { unset unknown_pending } return -code error "self-referential recursion in \"unknown\" for command \"$name\""; } set unknown_pending($name) pending; set ret [catch {auto_load $name} msg] unset unknown_pending($name); if {$ret != 0} { return -code $ret "error while autoloading \"$name\": $msg" } if ![array size unknown_pending] { unset unknown_pending } if $msg { set errorCode $savedErrorCode set errorInfo $savedErrorInfo set code [catch {uplevel $args} msg] if {$code == 1} { # # Strip the last five lines off the error stack (they're # from the "uplevel" command). # set new [split $errorInfo \n] set new [join [lrange $new 0 [expr [llength $new] - 6]] \n] return -code error -errorcode $errorCode \ -errorinfo $new $msg } else { return -code $code $msg } } } if {([info level] == 1) && ([info script] == "") \ && [info exists tcl_interactive] && $tcl_interactive} { if ![info exists auto_noexec] { if [auto_execok $name] { set errorCode $savedErrorCode set errorInfo $savedErrorInfo return [uplevel exec >&@stdout <@stdin $args] } } set errorCode $savedErrorCode set errorInfo $savedErrorInfo if {$name == "!!"} { return [uplevel {history redo}] } if [regexp {^!(.+)$} $name dummy event] { return [uplevel [list history redo $event]] } if [regexp {^\^([^^]*)\^([^^]*)\^?$} $name dummy old new] { return [uplevel [list history substitute $old $new]] } set cmds [info commands $name*] if {[llength $cmds] == 1} { return [uplevel [lreplace $args 0 0 $cmds]] } if {[llength $cmds] != 0} { if {$name == ""} { return -code error "empty command name \"\"" } else { return -code error \ "ambiguous command name \"$name\": [lsort $cmds]" } } } return -code error "invalid command name \"$name\"" } # auto_load: # Checks a collection of library directories to see if a procedure # is defined in one of them. If so, it sources the appropriate # library file to create the procedure. Returns 1 if it successfully # loaded the procedure, 0 otherwise. proc auto_load cmd { global auto_index auto_oldpath auto_path env errorInfo errorCode if [info exists auto_index($cmd)] { uplevel #0 $auto_index($cmd) return [expr {[info commands $cmd] != ""}] } if [catch {set path $auto_path}] { if [catch {set path $env(TCLLIBPATH)}] { if [catch {set path [info library]}] { return 0 } } } if [info exists auto_oldpath] { if {$auto_oldpath == $path} { return 0 } } set auto_oldpath $path catch {unset auto_index} for {set i [expr [llength $path] - 1]} {$i >= 0} {incr i -1} { set dir [lindex $path $i] set f "" if [catch {set f [open $dir/tclIndex]}] { continue } set error [catch { set id [gets $f] if {$id == "# Tcl autoload index file, version 2.0"} { eval [read $f] } elseif {$id == "# Tcl autoload index file: each line identifies a Tcl"} { while {[gets $f line] >= 0} { if {([string index $line 0] == "#") || ([llength $line] != 2)} { continue } set name [lindex $line 0] set auto_index($name) "source $dir/[lindex $line 1]" } } else { error "$dir/tclIndex isn't a proper Tcl index file" } } msg] if {$f != ""} { close $f } if $error { error $msg $errorInfo $errorCode } } if [info exists auto_index($cmd)] { uplevel #0 $auto_index($cmd) if {[info commands $cmd] != ""} { return 1 } } return 0 } # auto_execok: # Returns 1 if there's an executable in the current path for the # given name, 0 otherwise. Builds an associative array auto_execs # that caches information about previous checks, for speed. proc auto_execok name { global auto_execs env if [info exists auto_execs($name)] { return $auto_execs($name) } set auto_execs($name) 0 if {[string first / $name] >= 0} { if {[file executable $name] && ![file isdirectory $name]} { set auto_execs($name) 1 } return $auto_execs($name) } foreach dir [split $env(PATH) :] { if {$dir == ""} { set dir . } if {[file executable $dir/$name] && ![file isdirectory $dir/$name]} { set auto_execs($name) 1 return 1 } } return 0 } # auto_reset: # Destroy all cached information for auto-loading and auto-execution, # so that the information gets recomputed the next time it's needed. # Also delete any procedures that are listed in the auto-load index # except those related to auto-loading. proc auto_reset {} { global auto_execs auto_index auto_oldpath foreach p [info procs] { if {[info exists auto_index($p)] && ($p != "unknown") && ![string match auto_* $p]} { rename $p {} } } catch {unset auto_execs} catch {unset auto_index} catch {unset auto_oldpath} } # auto_mkindex: # Regenerate a tclIndex file from Tcl source files. Takes as argument # the name of the directory in which the tclIndex file is to be placed, # floowed by any number of glob patterns to use in that directory to # locate all of the relevant files. proc auto_mkindex {dir args} { global errorCode errorInfo set oldDir [pwd] cd $dir set dir [pwd] append index "# Tcl autoload index file, version 2.0\n" append index "# This file is generated by the \"auto_mkindex\" command\n" append index "# and sourced to set up indexing information for one or\n" append index "# more commands. Typically each line is a command that\n" append index "# sets an element in the auto_index array, where the\n" append index "# element name is the name of a command and the value is\n" append index "# a script that loads the command.\n\n" foreach file [eval glob $args] { set f "" set error [catch { set f [open $file] while {[gets $f line] >= 0} { if [regexp {^proc[ ]+([^ ]*)} $line match procName] { append index "set [list auto_index($procName)]" append index " \"source \$dir/$file\"\n" } } close $f } msg] if $error { set code $errorCode set info $errorInfo catch {close $f} cd $oldDir error $msg $info $code } } set f [open tclIndex w] puts $f $index nonewline close $f cd $oldDir } unknown_pending($name) pending; set ret [catch {auto_load $name} msg] unset unknown_pending($name); if {$ret != 0} { rettcl7.4b4/library/parray.tcl010044400630510000012000000015240576565442400165130ustar00ousterstaff00002300000001# parray: # Print the contents of a global array on stdout. # # @(#) parray.tcl 1.8 95/03/29 10:26:43 # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # proc parray {a {pattern *}} { upvar 1 $a array if ![array exists array] { error "\"$a\" isn't an array" } set maxl 0 foreach name [lsort [array names array $pattern]] { if {[string length $name] > $maxl} { set maxl [string length $name] } } set maxl [expr {$maxl + [string length $a] + 2}] foreach name [lsort [array names array $pattern]] { set nameString [format %s(%s) $a $name] puts stdout [format "%-*s = %s" $maxl $nameString $array($name)] } } tcl7.4b4/library/tclIndex010044400630510000012000000012110576565442400161770ustar00ousterstaff00002300000001# Tcl autoload index file, version 2.0 # This file is generated by the "auto_mkindex" command # and sourced to set up indexing information for one or # more commands. Typically each line is a command that # sets an element in the auto_index array, where the # element name is the name of a command and the value is # a script that loads the command. set auto_index(unknown) "source $dir/init.tcl" set auto_index(auto_load) "source $dir/init.tcl" set auto_index(auto_execok) "source $dir/init.tcl" set auto_index(auto_reset) "source $dir/init.tcl" set auto_index(auto_mkindex) "source $dir/init.tcl" set auto_index(parray) "source $dir/parray.tcl" tcl7.4b4/doc/004077500630510000012000000000000577032346500136115ustar00ousterstaff00002300000001tcl7.4b4/doc/license.terms010044400630510000012000000033060567470030500162750ustar00ousterstaff00002300000001This software is copyrighted by the Regents of the University of California, Sun Microsystems, Inc., and other parties. The following terms apply to all files associated with the software unless explicitly disclaimed in individual files. The authors hereby grant permission to use, copy, modify, distribute, and license this software and its documentation for any purpose, provided that existing copyright notices are retained in all copies and that this notice is included verbatim in any distributions. No written agreement, license, or royalty fee is required for any of the authorized uses. Modifications to this software may be copyrighted by their authors and need not follow the licensing terms described here, provided that the new terms are clearly indicated on the first page of each file where they apply. IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. RESTRICTED RIGHTS: Use, duplication or disclosure by the government is subject to the restrictions as set forth in subparagraph (c) (1) (ii) of the Rights in Technical Data and Computer Software Clause as DFARS 252.227-7013 and FAR 52.227-19. tcl7.4b4/doc/AddErrInfo.3010044400630510000012000000121360575277300500156450ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1989-1993 The Regents of the University of California. '\" Copyright (c) 1994 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) AddErrInfo.3 1.17 95/05/06 15:17:56 '\" .so man.macros .TH Tcl_AddErrorInfo 3 "" Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_AddErrorInfo, Tcl_SetErrorCode, Tcl_PosixError \- record information about errors .SH SYNOPSIS .nf \fB#include \fR .sp \fBTcl_AddErrorInfo\fR(\fIinterp, message\fR) .sp \fBTcl_SetErrorCode\fR(\fIinterp, element, element, ...\fB (char *) NULL\fR) .sp char * \fBTcl_PosixError\fR(\fIinterp\fR) .SH ARGUMENTS .AS Tcl_Interp *message .AP Tcl_Interp *interp in Interpreter in which to record information. .AP char *message in Identifying string to record in \fBerrorInfo\fR variable. .AP char *element in String to record as one element of \fBerrorCode\fR variable. Last \fIelement\fR argument must be NULL. .BE .SH DESCRIPTION .PP These procedures are used to manipulate two global variables that hold information about errors. The variable \fBerrorInfo\fR holds a stack trace of the operations that were in progress when an error occurred, and is intended to be human-readable. The variable \fBerrorCode\fR holds a list of items that are intended to be machine-readable. The first item in \fBerrorCode\fR identifies the class of .VS error that occurred (e.g. POSIX means an error occurred in .VE a POSIX system call) and additional elements in \fBerrorCode\fR hold additional pieces of information that depend on the class. See the Tcl overview manual entry for details on the various formats for \fBerrorCode\fR. .PP The \fBerrorInfo\fR variable is gradually built up as an error unwinds through the nested operations. Each time an error code is returned to \fBTcl_Eval\fR it calls the procedure \fBTcl_AddErrorInfo\fR to add additional text to \fBerrorInfo\fR describing the command that was being executed when the error occurred. By the time the error has been passed all the way back to the application, it will contain a complete trace of the activity in progress when the error occurred. .PP It is sometimes useful to add additional information to \fBerrorInfo\fR beyond what can be supplied automatically by \fBTcl_Eval\fR. \fBTcl_AddErrorInfo\fR may be used for this purpose: its \fImessage\fR argument contains an additional string to be appended to \fBerrorInfo\fR. For example, the \fBsource\fR command calls \fBTcl_AddErrorInfo\fR to record the name of the file being processed and the line number on which the error occurred; for Tcl procedures, the procedure name and line number within the procedure are recorded, and so on. The best time to call \fBTcl_AddErrorInfo\fR is just after \fBTcl_Eval\fR has returned \fBTCL_ERROR\fR. In calling \fBTcl_AddErrorInfo\fR, you may find it useful to use the \fBerrorLine\fR field of the interpreter (see the \fBTcl_Interp\fR manual entry for details). .PP The procedure \fBTcl_SetErrorCode\fR is used to set the \fBerrorCode\fR variable. Its \fIelement\fR arguments give one or more strings to record in \fBerrorCode\fR: each \fIelement\fR will become one item of a properly-formed Tcl list stored in \fBerrorCode\fR. \fBTcl_SetErrorCode\fR is typically invoked just before returning an error. If an error is returned without calling \fBTcl_SetErrorCode\fR then the Tcl interpreter automatically sets \fBerrorCode\fR to \fBNONE\fR. .PP \fBTcl_PosixError\fR .VS sets the \fBerrorCode\fR variable after an error in a POSIX kernel call. It reads the value of the \fBerrno\fR C variable and calls \fBTcl_SetErrorCode\fR to set \fBerrorCode\fR in the \fBPOSIX\fR format. In addition, \fBTcl_PosixError\fR returns a human-readable .VE diagnostic message for the error (this is the same value that will appear as the third element in \fBerrorCode\fR). It may be convenient to include this string as part of the error message returned to the application in \fIinterp->result\fR. .PP It is important to call the procedures described here rather than setting \fBerrorInfo\fR or \fBerrorCode\fR directly with \fBTcl_SetVar\fR. The reason for this is that the Tcl interpreter keeps information about whether these procedures have been called. For example, the first time \fBTcl_AppendResult\fR is called for an error, it clears the existing value of \fBerrorInfo\fR and adds the error message in \fIinterp->result\fR to the variable before appending \fImessage\fR; in subsequent calls, it just appends the new \fImessage\fR. When \fBTcl_SetErrorCode\fR is called, it sets a flag indicating that \fBerrorCode\fR has been set; this allows the Tcl interpreter to set \fBerrorCode\fR to \fBNONE\fB if it receives an error return when \fBTcl_SetErrorCode\fR hasn't been called. .PP If the procedure \fBTcl_ResetResult\fR is called, it clears all of the state associated with \fBerrorInfo\fR and \fBerrorCode\fR (but it doesn't actually modify the variables). If an error had occurred, this will clear the error state to make it appear as if no error had occurred after all. .SH "SEE ALSO" Tcl_ResetResult, Tcl_Interp .SH KEYWORDS error, stack, trace, variable tcl7.4b4/doc/AllowExc.3010044400630510000012000000025540575277300500154110ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1989-1993 The Regents of the University of California. '\" Copyright (c) 1994 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) AllowExc.3 1.3 95/05/06 15:17:57 '\" .so man.macros .TH Tcl_AllowExceptions 3 7.4 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_AllowExceptions \- allow all exceptions in next script evaluation .SH SYNOPSIS .nf \fB#include \fR .sp \fBTcl_AllowExceptions\fR(\fIinterp\fR) .SH ARGUMENTS .AS Tcl_Interp *doublePtr .AP Tcl_Interp *interp in Interpreter in which script will be evaluated. .BE .SH DESCRIPTION .PP If a script is evaluated at top-level (i.e. no other scripts are pending evaluation when the script is invoked), and if the script terminates with a completion code other than TCL_OK, TCL_CONTINUE or TCL_RETURN, then Tcl normally converts this into a TCL_ERROR return with an appropriate message. .PP However, if \fBTcl_AllowExceptions\fR is invoked immediately before calling a procedure such as \fBTcl_Eval\fR, then arbitrary completion codes are permitted from the script, and they are returned without modification. This is useful in cases where the caller can deal with exceptions such as TCL_BREAK or TCL_CONTINUE in a meaningful way. .SH KEYWORDS continue, break, exception, interpreter tcl7.4b4/doc/AppInit.3010044400630510000012000000053420576564146300152430ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) AppInit.3 1.6 95/06/08 11:36:33 '\" .so man.macros .TH Tcl_AppInit 3 7.0 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_AppInit \- perform application-specific initialization .SH SYNOPSIS .nf \fB#include \fR .sp int \fBTcl_AppInit\fR(\fIinterp\fR) .SH ARGUMENTS .AS Tcl_Interp *interp .AP Tcl_Interp *interp in Interpreter for the application. .BE .SH DESCRIPTION .PP \fBTcl_AppInit\fR is a ``hook'' procedure that is invoked by the main programs for Tcl applications such as \fBtclsh\fR and \fBwish\fR. Its purpose is to allow new Tcl applications to be created without modifying the main programs provided as part of Tcl and Tk. To create a new application you write a new version of \fBTcl_AppInit\fR to replace the default version provided by Tcl, then link your new \fBTcl_AppInit\fR with the Tcl library. .PP \fBTcl_AppInit\fR is invoked after by \fBTcl_Main\fR and \fBTk_Main\fR after their own initialization and before entering the main loop to process commands. Here are some examples of things that \fBTcl_AppInit\fR might do: .IP [1] Call initialization procedures for various packages used by the application. Each initialization procedure adds new commands to \fIinterp\fR for its package and performs other package-specific initialization. .IP [2] Process command-line arguments, which can be accessed from the Tcl variables \fBargv\fR and \fBargv0\fR in \fIinterp\fR. .IP [3] Invoke a startup script to initialize the application. .LP .VS \fBTcl_AppInit\fR returns TCL_OK or TCL_ERROR. If it returns TCL_ERROR then it must leave an error message in \fIinterp->result\fR; otherwise the result is ignored. .PP In addition to \fBTcl_AppInit\fR, your application should also contain a procedure \fBmain\fR that calls \fBTcl_Main\fR as follows: .DS Tcl_Main(argc, argv, Tcl_AppInit); .DE The third argument to \fBTcl_Main\fR gives the address of the application-specific initialization procedure to invoke. This means that you don't have to use the name \fBTcl_AppInit\fR for the procedure, but in practice the name is nearly always \fBTcl_AppInit\fR (in versions before Tcl 7.4 the name \fBTcl_AppInit\fR was implicit; there was no way to specify the procedure explicitly). The best way to get started is to make a copy of the file \fBtclAppInit.c\fR from the Tcl library or source directory. It already contains a \fBmain\fR procedure and a template for \fBTcl_AppInit\fR that you can modify for your application. .VE .SH KEYWORDS application, argument, command, initialization, interpreter tcl7.4b4/doc/Async.3010044400630510000012000000142600575277300600147460ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1989-1993 The Regents of the University of California. '\" Copyright (c) 1994-1995 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) Async.3 1.8 95/05/06 15:17:59 '\" .so man.macros .TH Tcl_AsyncCreate 3 7.0 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_AsyncCreate, Tcl_AsyncMark, Tcl_AsyncInvoke, Tcl_AsyncDelete \- handle asynchronous events .SH SYNOPSIS .nf \fB#include \fR .sp extern int \fBtcl_AsyncReady\fR; .sp Tcl_AsyncHandler \fBTcl_AsyncCreate\fR(\fIproc, clientData\fR) .sp \fBTcl_AsyncMark\fR(\fIasync\fR) .sp int \fBTcl_AsyncInvoke\fR(\fIinterp, code\fR) .sp \fBTcl_AsyncDelete\fR(\fIasync\fR) .SH ARGUMENTS .AS Tcl_AsyncHandler clientData .AP Tcl_AsyncProc *proc in Procedure to invoke to handle an asynchronous event. .AP ClientData clientData in One-word value to pass to \fIproc\fR. .AP Tcl_AsyncHandler async in Token for asynchronous event handler. .AP Tcl_Interp *interp in Tcl interpreter in which command was being evaluated when handler was invoked, or NULL if handler was invoked when there was no interpreter active. .AP int code in Completion code from command that just completed in \fIinterp\fR, or 0 if \fIinterp\fR is NULL. .BE .SH DESCRIPTION .PP These procedures provide a safe mechanism for dealing with asynchronous events such as signals. If an event such as a signal occurs while a Tcl script is being evaluated then it isn't safe to take any substantive action to process the event. For example, it isn't safe to evaluate a Tcl script since the interpreter may already be in the middle of evaluating a script; it may not even be safe to allocate memory, since a memory allocation could have been in progress when the event occurred. The only safe approach is to set a flag indicating that the event occurred, then handle the event later when the world has returned to a clean state, such as after the current Tcl command completes. .PP \fBTcl_AsyncCreate\fR creates an asynchronous handler and returns a token for it. The asynchronous handler must be created before any occurrences of the asynchronous event that it is intended to handle (it is not safe to create a handler at the time of an event). When an asynchronous event occurs the code that detects the event (such as a signal handler) should call \fBTcl_AsyncMark\fR with the token for the handler. \fBTcl_AsyncMark\fR will mark the handler as ready to execute, but it will not invoke the handler immediately. Tcl will call the \fIproc\fR associated with the handler later, when the world is in a safe state, and \fIproc\fR can then carry out the actions associated with the asynchronous event. \fIProc\fR should have arguments and result that match the type \fBTcl_AsyncProc\fR: .nf .RS typedef int Tcl_AsyncProc( .RS ClientData \fIclientData\fR, Tcl_Interp *\fIinterp\fR, int \fIcode\fR); .RE .RE .fi The \fIclientData\fR will be the same as the \fIclientData\fR argument passed to \fBTcl_AsyncCreate\fR when the handler was created. If \fIproc\fR is invoked just after a command has completed execution in an interpreter, then \fIinterp\fR will identify the interpreter in which the command was evaluated and \fIcode\fR will be the completion code returned by that command. The command's result will be present in \fIinterp->result\fR. When \fIproc\fR returns, whatever it leaves in \fIinterp->result\fR will be returned as the result of the command and the integer value returned by \fIproc\fR will be used as the new completion code for the command. .PP It is also possible for \fIproc\fR to be invoked when no interpreter is active. This can happen, for example, if an asynchronous event occurs while the application is waiting for interactive input or an X event. In this case \fIinterp\fR will be NULL and \fIcode\fR will be 0, and the return value from \fIproc\fR will be ignored. .PP The procedure \fBTcl_AsyncInvoke\fR is called to invoke all of the handlers that are ready. The global variable \fBtcl_AsyncReady\fR will be non-zero whenever any asynchronous handlers are ready; it can be checked to avoid calls to \fBTcl_AsyncInvoke\fR when there are no ready handlers. Tcl checks \fBtcl_AsyncReady\fR after each command is evaluated and calls \fBTcl_AsyncInvoke\fR if needed. Applications may also call \fBTcl_AsyncInvoke\fR at interesting times for that application. For example, Tk's event handler checks \fBtcl_AsyncReady\fR after each event and calls \fBTcl_AsyncInvoke\fR if needed. The \fIinterp\fR and \fIcode\fR arguments to \fBTcl_AsyncInvoke\fR have the same meaning as for \fIproc\fR: they identify the active interpreter, if any, and the completion code from the command that just completed. .PP \fBTcl_AsyncDelete\fR removes an asynchronous handler so that its \fIproc\fR will never be invoked again. A handler can be deleted even when ready, and it will still not be invoked. .PP If multiple handlers become active at the same time, the handlers are invoked in the order they were created (oldest handler first). The \fIcode\fR and \fIinterp->result\fR for later handlers reflect the values returned by earlier handlers, so that the most recently created handler has last say about the interpreter's result and completion code. If new handlers become ready while handlers are executing, \fBTcl_AsyncInvoke\fR will invoke them all; at each point it invokes the highest-priority (oldest) ready handler, repeating this over and over until there are no longer any ready handlers. .SH WARNING .PP It is almost always a bad idea for an asynchronous event handler to modify \fIinterp->result\fR or return a code different from its \fIcode\fR argument. This sort of behavior can disrupt the execution of scripts in subtle ways and result in bugs that are extremely difficult to track down. If an asynchronous event handler needs to evaluate Tcl scripts then it should first save \fIinterp->result\fR plus the values of the variables \fBerrorInfo\fR and \fBerrorCode\fR (this can be done, for example, by storing them in dynamic strings). When the asynchronous handler is finished it should restore \fIinterp->result\fR, \fBerrorInfo\fR, and \fBerrorCode\fR, and return the \fIcode\fR argument. .SH KEYWORDS asynchronous event, handler, signal tcl7.4b4/doc/Backslash.3010044400630510000012000000024170575277300600155650ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1989-1993 The Regents of the University of California. '\" Copyright (c) 1994 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) Backslash.3 1.14 95/05/06 15:18:00 '\" .so man.macros .TH Tcl_Backslash 3 "" Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_Backslash \- parse a backslash sequence .SH SYNOPSIS .nf \fB#include \fR .sp char \fBTcl_Backslash\fR(\fIsrc, countPtr\fR) .SH ARGUMENTS .AS char *countPtr .AP char *src in Pointer to a string starting with a backslash. .AP int *countPtr out If \fIcountPtr\fR isn't NULL, \fI*countPtr\fR gets filled in with number of characters in the backslash sequence, including the backslash character. .BE .SH DESCRIPTION .PP This is a utility procedure used by several of the Tcl commands. It parses a backslash sequence and returns the single character corresponding to the sequence. \fBTcl_Backslash\fR modifies \fI*countPtr\fR to contain the number of characters in the backslash sequence. .PP See the Tcl manual entry for information on the valid backslash sequences. All of the sequences described in the Tcl manual entry are supported by \fBTcl_Backslash\fR. .SH KEYWORDS backslash, parse tcl7.4b4/doc/CallDel.3010044400630510000012000000042370575277300600151740ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) CallDel.3 1.5 95/05/06 15:18:01 '\" .so man.macros .TH Tcl_CallWhenDeleted 3 7.0 Tcl "Tcl Library Procedures" .BS .SH NAME .na Tcl_CallWhenDeleted, Tcl_DontCallWhenDeleted \- Arrange for callback when interpreter is deleted .ad .SH SYNOPSIS .nf \fB#include \fR .sp \fBTcl_CallWhenDeleted\fR(\fIinterp\fR, \fIproc\fR, \fIclientData\fR) .sp \fBTcl_DontCallWhenDeleted\fR(\fIinterp\fR, \fIproc\fR, \fIclientData\fR) .SH ARGUMENTS .AS Tcl_InterpDeleteProc clientData .AP Tcl_Interp *interp in Interpreter with which to associated callback. .AP Tcl_InterpDeleteProc *proc in Procedure to call when \fIinterp\fR is deleted. .AP ClientData clientData in Arbitrary one-word value to pass to \fIproc\fR. .BE .SH DESCRIPTION .PP \fBTcl_CallWhenDeleted\fR arranges for \fIproc\fR to be called by \fBTcl_DeleteInterp\fR if/when \fIinterp\fR is deleted at some future time. \fIProc\fR will be invoked just before the interpreter is deleted, but the interpreter will still be valid at the time of the call. \fIProc\fR should have arguments and result that match the type \fBTcl_InterpDeleteProc\fR: .nf .RS typedef int Tcl_InterpDeleteProc( .RS ClientData \fIclientData\fR, Tcl_Interp *\fIinterp\fR); .RE .RE .fi The \fIclientData\fP and \fIinterp\fR parameters are copies of the \fIclientData\fP and \fIinterp\fR arguments given to \fBTcl_CallWhenDeleted\fR. Typically, \fIclientData\fR points to an application-specific data structure that \fIproc\fR uses to perform cleanup when an interpreter is about to go away. \fIProc\fR does not return a value. .PP \fBTcl_DontCallWhenDeleted\fR cancels a previous call to \fBTcl_CallWhenDeleted\fR with the same arguments, so that \fIproc\fR won't be called after all when \fIinterp\fR is deleted. If there is no deletion callback that matches \fIinterp\fR, \fIproc\fR, and \fIclientData\fR then the call to \fBTcl_DontCallWhenDeleted\fR has no effect. .SH KEYWORDS callback, delete, interpreter tcl7.4b4/doc/CmdCmplt.3010044400630510000012000000017450575277300600154000ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1989-1993 The Regents of the University of California. '\" Copyright (c) 1994 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) CmdCmplt.3 1.4 95/05/06 15:18:01 '\" .so man.macros .TH Tcl_CommandComplete 3 "" Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_CommandComplete \- Check for unmatched braces in a Tcl command .SH SYNOPSIS .nf \fB#include \fR .sp int \fBTcl_CommandComplete\fR(\fIcmd\fR) .SH ARGUMENTS .AS char *cmd .AP char *cmd in Command string to test for completeness. .BE .SH DESCRIPTION .PP \fBTcl_CommandComplete\fR takes a Tcl command string as argument and determines whether it contains one or more complete commands (i.e. there are no unclosed quotes, braces, brackets, or variable references). If the command string is complete then it returns 1; otherwise it returns 0. .SH KEYWORDS complete command, partial command tcl7.4b4/doc/Concat.3010044400630510000012000000032400575277300600150740ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1989-1993 The Regents of the University of California. '\" Copyright (c) 1994 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) Concat.3 1.8 95/05/06 15:18:02 '\" .so man.macros .TH Tcl_Concat 3 "" Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_Concat \- concatenate a collection of strings .SH SYNOPSIS .nf \fB#include \fR .sp char * \fBTcl_Concat\fR(\fIargc, argv\fR) .SH ARGUMENTS .AP int argc in Number of strings. .AP char *argv[] in Array of strings to concatenate. Must have \fIargc\fR entries. .BE .SH DESCRIPTION .PP \fBTcl_Concat\fR is a utility procedure used by several of the Tcl commands. Given a collection of strings, it concatenates them together into a single string, with the original strings separated by spaces. This procedure behaves differently than \fBTcl_Merge\fR, in that the arguments are simply concatenated: no effort is made to ensure proper list structure. However, in most common usage the arguments will all be proper lists themselves; if this is true, then the result will also have proper list structure. .PP \fBTcl_Concat\fR eliminates leading and trailing white space as it copies strings from \fBargv\fR to the result. If an element of \fBargv\fR consists of nothing but white space, then that string is ignored entirely. This white-space removal was added to make the output of the \fBconcat\fR command cleaner-looking. .PP The result string is dynamically allocated using \fBmalloc()\fR; the caller must eventually release the space by calling \fBfree()\fR. .SH KEYWORDS concatenate, strings tcl7.4b4/doc/CrtCommand.3010044400630510000012000000164440575277300700157270ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1989-1993 The Regents of the University of California. '\" Copyright (c) 1994-1995 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) CrtCommand.3 1.16 95/05/06 15:18:03 '\" .so man.macros .TH Tcl_CreateCommand 3 "" Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_CreateCommand, Tcl_DeleteCommand, Tcl_GetCommandInfo, Tcl_SetCommandInfo \- implement new commands in C .SH SYNOPSIS .nf \fB#include \fR .sp .VS .VE Tcl_Command \fBTcl_CreateCommand\fR(\fIinterp, cmdName, proc, clientData, deleteProc\fR) .sp int \fBTcl_DeleteCommand\fR(\fIinterp, cmdName\fR) .sp .VS int \fBTcl_GetCommandInfo\fR(\fIinterp, cmdName, infoPtr\fR) .sp int \fBTcl_SetCommandInfo\fR(\fIinterp, cmdName, infoPtr\fR) .sp .VS char * \fBTcl_GetCommandName\fR(\fIinterp, token\fR) .VE .VE .SH ARGUMENTS .AS Tcl_CmdDeleteProc **deleteProcPtr .AP Tcl_Interp *interp in Interpreter in which to create new command. .AP char *cmdName in Name of command. .AP Tcl_CmdProc *proc in Implementation of new command: \fIproc\fR will be called whenever \fIcmdName\fR is invoked as a command. .AP ClientData clientData in Arbitrary one-word value to pass to \fIproc\fR and \fIdeleteProc\fR. .AP Tcl_CmdDeleteProc *deleteProc in Procedure to call before \fIcmdName\fR is deleted from the interpreter; allows for command-specific cleanup. If NULL, then no procedure is called before the command is deleted. .AP Tcl_CmdInfo *infoPtr in/out .VS Pointer to structure containing various information about a Tcl command. .AP Tcl_Command token in Token for command, returned by previous call to \fBTcl_CreateCommand\fR. The command must not have been deleted. .VE .BE .SH DESCRIPTION .PP \fBTcl_CreateCommand\fR defines a new command in \fIinterp\fR and associates it with procedure \fIproc\fR such that whenever \fIcmdName\fR is invoked as a Tcl command (via a call to \fBTcl_Eval\fR) the Tcl interpreter will call \fIproc\fR to process the command. If there is already a command \fIcmdName\fR associated with the interpreter, it is deleted. .VS \fBTcl_CreateCommand\fR returns a token that may be used to refer to the command in subsequent calls to \fBTcl_GetCommandName\fR. .VE \fIProc\fP should have arguments and result that match the type \fBTcl_CmdProc\fR: .nf .RS typedef int Tcl_CmdProc( .RS ClientData \fIclientData\fR, Tcl_Interp *\fIinterp\fR, int \fIargc\fR, char *\fIargv\fR[]); .RE .RE .fi When \fIproc\fR is invoked the \fIclientData\fP and \fIinterp\fR parameters will be copies of the \fIclientData\fP and \fIinterp\fR arguments given to \fBTcl_CreateCommand\fR. Typically, \fIclientData\fR points to an application-specific data structure that describes what to do when the command procedure is invoked. \fIArgc\fR and \fIargv\fR describe the arguments to the command, \fIargc\fR giving the number of arguments (including the command name) and \fIargv\fR giving the values of the arguments as strings. The \fIargv\fR array will contain \fIargc\fR+1 values; the first \fIargc\fR values point to the argument strings, and the last value is NULL. .PP \fIProc\fR must return an integer code that is either \fBTCL_OK\fR, \fBTCL_ERROR\fR, \fBTCL_RETURN\fR, \fBTCL_BREAK\fR, or \fBTCL_CONTINUE\fR. See the Tcl overview man page for details on what these codes mean. Most normal commands will only return \fBTCL_OK\fR or \fBTCL_ERROR\fR. In addition, \fIproc\fR must set \fIinterp->result\fR to point to a string value; in the case of a \fBTCL_OK\fR return code this gives the result of the command, and in the case of \fBTCL_ERROR\fR it gives an error message. The \fBTcl_SetResult\fR procedure provides an easy interface for setting the return value; for complete details on how the \fIinterp->result\fR field is managed, see the \fBTcl_Interp\fR man page. Before invoking a command procedure, \fBTcl_Eval\fR sets \fIinterp->result\fR to point to an empty string, so simple commands can return an empty result by doing nothing at all. .PP .VS The contents of the \fIargv\fR array belong to Tcl and are not guaranteed to persist once \fIproc\fR returns: \fIproc\fR should not modify them, nor should it set \fIinterp->result\fR to point anywhere within the \fIargv\fR values. Call \fBTcl_SetResult\fR with status \fBTCL_VOLATILE\fR if you want to return something from the \fIargv\fR array. .VE .PP \fIDeleteProc\fR will be invoked when (if) \fIcmdName\fR is deleted. This can occur through a call to \fBTcl_DeleteCommand\fR or \fBTcl_DeleteInterp\fR, or by replacing \fIcmdName\fR in another call to \fBTcl_CreateCommand\fR. \fIDeleteProc\fR is invoked before the command is deleted, and gives the application an opportunity to release any structures associated with the command. \fIDeleteProc\fR should have arguments and result that match the type \fBTcl_CmdDeleteProc\fR: .nf .RS .sp typedef void Tcl_CmdDeleteProc(ClientData \fIclientData\fR); .sp .RE .fi The \fIclientData\fR argument will be the same as the \fIclientData\fR argument passed to \fBTcl_CreateCommand\fR. .PP \fBTcl_DeleteCommand\fR deletes a command from a command interpreter. Once the call completes, attempts to invoke \fIcmdName\fR in \fIinterp\fR will result in errors. If \fIcmdName\fR isn't bound as a command in \fIinterp\fR then \fBTcl_DeleteCommand\fR does nothing and returns -1; otherwise it returns 0. There are no restrictions on \fIcmdName\fR: it may refer to a built-in command, an application-specific command, or a Tcl procedure. .PP .VS \fBTcl_GetCommandInfo\fR checks to see whether its \fIcmdName\fR argument exists as a command in \fIinterp\fR. If not then it returns 0. Otherwise it places information about the command in the structure pointed to by \fIinfoPtr\fR and returns 1. Tcl_CmdInfo structures have fields named \fIproc\fR, \fIclientData\fR, and \fIdeleteProc\fR, which have the same meaning as the corresponding arguments to \fBTcl_CreateCommand\fR. There is also a field \fIdeleteData\fR, which is the ClientData value to pass to \fIdeleteProc\fR; it is normally the same as \fIclientData\fR but may be set independently using the \fBTcl_SetCommandInfo\fR procedure. .PP \fBTcl_SetCommandInfo\fR is used to modify the procedures and ClientData values associated with a command. Its \fIcmdName\fR argument is the name of a command in \fIinterp\fR. If this command does not exist then \fBTcl_SetCommandInfo\fR returns 0. Otherwise, it copies the information from \fI*infoPtr\fR to Tcl's internal structure for the command and returns 1. Note that this procedure allows the ClientData for a command's deletion procedure to be given a different value than the ClientData for its command procedure. .PP \fBTcl_GetCommandName\fR provides a mechanism for tracking commands that have been renamed. Given a token returned by \fBTcl_CreateCommand\fR when the command was created, \fBTcl_GetCommandName\fR returns the string name of the command. If the command has been renamed since it was created, then \fBTcl_GetCommandName\fR returns the current name. The command corresponding to \fItoken\fR must not have been deleted. The string returned by \fBTcl_GetCommandName\fR is in dynamic memory owned by Tcl and is only guaranteed to retain its value as long as the command isn't deleted or renamed; callers should copy the string if they need to keep it for a long time. .VE .SH KEYWORDS bind, command, create, delete, interpreter what these codes mean. Most normal commands will only return \fBTCL_OK\fR or \fBTCL_ERROR\fR. In addition, \fIproc\fR must set \fIinterp->result\fR to point to a string value; in the case of a \fBTCL_OK\fR return code tcl7.4b4/doc/CrtInterp.3010044400630510000012000000031020575277300700155750ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1989-1993 The Regents of the University of California. '\" Copyright (c) 1994 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) CrtInterp.3 1.9 95/05/06 15:18:04 '\" .so man.macros .TH Tcl_CreateInterp 3 "" Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_CreateInterp, Tcl_DeleteInterp \- create and delete Tcl command interpreters .SH SYNOPSIS .nf \fB#include \fR .sp Tcl_Interp * \fBTcl_CreateInterp\fR() .sp \fBTcl_DeleteInterp\fR(\fIinterp\fR) .SH ARGUMENTS .AS Tcl_Interp *interp .AP Tcl_Interp *interp in Token for interpreter to be destroyed. .BE .SH DESCRIPTION .PP \fBTcl_CreateInterp\fR creates a new interpreter structure and returns a token for it. The token is required in calls to most other Tcl procedures, such as \fBTcl_CreateCommand\fR, \fBTcl_Eval\fR, and \fBTcl_DeleteInterp\fR. Clients are only allowed to access a few of the fields of Tcl_Interp structures; see the Tcl_Interp and \fBTcl_CreateCommand\fR man pages for details. The new interpreter is initialized with no defined variables and only the built-in Tcl commands. To bind in additional commands, call \fBTcl_CreateCommand\fR. .PP \fBTcl_DeleteInterp\fR destroys a command interpreter and releases all of the resources associated with it, including variables, procedures, and application-specific command bindings. After \fBTcl_DeleteInterp\fR returns the caller should never again use the \fIinterp\fR token. .SH KEYWORDS command, create, delete, interpreter tcl7.4b4/doc/CrtMathFnc.3010044400630510000012000000070570576215603200156630ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1989-1993 The Regents of the University of California. '\" Copyright (c) 1994-1995 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) CrtMathFnc.3 1.5 95/05/28 13:24:41 '\" .so man.macros .TH Tcl_CreateMathFunc 3 7.0 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_CreateMathFunc \- Define a new math function for expressions .SH SYNOPSIS .nf \fB#include \fR .sp \fBTcl_CreateMathFunc\fR(\fIinterp, name, numArgs, argTypes, proc, clientData\fR) .SH ARGUMENTS .AS Tcl_ValueType clientData .AP Tcl_Interp *interp in Interpreter in which new function will be defined. .AP char *name in Name for new function. .AP int numArgs in Number of arguments to new function; also gives size of \fIargTypes\fR array. .AP Tcl_ValueType *argTypes in Points to an array giving the permissible types for each argument to function. .AP Tcl_MathProc *proc in Procedure that implements the function. .AP ClientData clientData in Arbitrary one-word value to pass to \fIproc\fR when it is invoked. .BE .SH DESCRIPTION .PP Tcl allows a number of mathematical functions to be used in expressions, such as \fBsin\fR, \fBcos\fR, and \fBhypot\fR. \fBTcl_CreateMathFunc\fR allows applications to add additional functions to those already provided by Tcl or to replace existing functions. \fIName\fR is the name of the function as it will appear in expressions. If \fIname\fR doesn't already exist as a function then a new function is created. If it does exist, then the existing function is replaced. \fINumArgs\fR and \fIargTypes\fR describe the arguments to the function. Each entry in the \fIargTypes\fR array must be either TCL_INT, TCL_DOUBLE, or TCL_EITHER to indicate whether the corresponding argument must be an integer, a double-precision floating value, or either, respectively. .PP Whenever the function is invoked in an expression Tcl will invoke \fIproc\fR. \fIProc\fR should have arguments and result that match the type \fBTcl_MathProc\fR: .nf .RS typedef int Tcl_MathProc( .RS ClientData \fIclientData\fR, Tcl_Interp *\fIinterp\fR, Tcl_Value *\fIargs\fR, Tcl_Value *\fIresultPtr\fR); .RE .RE .fi .PP When \fIproc\fR is invoked the \fIclientData\fR and \fIinterp\fR arguments will be the same as those passed to \fBTcl_CreateMathFunc\fR. \fIArgs\fR will point to an array of \fInumArgs\fR Tcl_Value structures, which describe the actual arguments to the function: .nf .RS typedef struct Tcl_Value { .RS Tcl_ValueType \fItype\fR; .VS .VE long \fIintValue\fR; double \fIdoubleValue\fR; .RE } Tcl_Value; .RE .fi .PP The \fItype\fR field indicates the type of the argument and is either TCL_INT or TCL_DOUBLE. It will match the \fIargTypes\fR value specified for the function unless the \fIargTypes\fR value was TCL_EITHER. Tcl converts the argument supplied in the expression to the type requested in \fIargTypes\fR, if that is necessary. Depending on the value of the \fItype\fR field, the \fIintValue\fR or \fIdoubleValue\fR field will contain the actual value of the argument. .PP \fIProc\fR should compute its result and store it either as an integer in \fIresultPtr->intValue\fR or as a floating value in \fIresultPtr->doubleValue\fR. It should set also \fIresultPtr->type\fR to either TCL_INT or TCL_DOUBLE to indicate which value was set. Under normal circumstances \fIproc\fR should return TCL_OK. If an error occurs while executing the function, \fIproc\fR should return TCL_ERROR and leave an error message in \fIinterp->result\fR. .SH KEYWORDS expression, mathematical function the University of California. '\" Copyright (c) 1994-1995 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) CrtMathFnc.3 1.5 95/05/28 13:24:41 '\" .so man.macros .TH Tcl_CreateMathFunc 3 7.0 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_CreateMathFunc \- Define a new math function for expressions .SH SYNOPSIS .nf \fB#include \fR tcl7.4b4/doc/CrtPipelin.3010044400630510000012000000104570576547632200157530ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1989-1993 The Regents of the University of California. '\" Copyright (c) 1994 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) CrtPipelin.3 1.10 95/06/07 21:30:11 '\" .so man.macros .TH Tcl_CreatePipeline 3 "" Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_CreatePipeline \- create one or more child processes, with I/O redirection .SH SYNOPSIS .nf \fB#include \fR .sp int \fBTcl_CreatePipeline\fR(\fIinterp, argc, argv, pidArrayPtr, inPipePtr, outPipePtr, errFilePtr\fR) .SH ARGUMENTS .AS Tcl_Interp **pidArrayPtr .AP Tcl_Interp *interp in Interpreter to use for error reporting. .AP int argc in Number of strings in \fIargv\fR array. .AP char **argv in Array of strings describing command(s) and I/O redirection. \fIArgv[argc]\fR must be NULL. .AP int **pidArrayPtr out The value at \fI*pidArrayPtr\fR is modified to hold a pointer to an array of process identifiers. The array is dynamically allocated and must be freed by the caller. .AP int *inPipePtr out If this argument is NULL then standard input for the first command in the pipeline comes from the current standard input. If \fIinPipePtr\fR is not NULL then \fBTcl_CreatePipeline\fR will create a pipe, arrange for it to be used for standard input to the first command, and store a file id for writing to that pipe at \fI*inPipePtr\fR. If the command specified its own input using redirection, then no pipe is created and -1 is stored at \fI*inPipePtr\fR. .AP int *outPipePtr out If this argument is NULL then standard output for the last command in the pipeline goes to the current standard output. If \fIoutPipePtr\fR is not NULL then \fBTcl_CreatePipeline\fR will create a pipe, arrange for it to be used for standard output from the last command, and store a file id for reading from that pipe at \fI*outPipePtr\fR. If the command specified its own output using redirection then no pipe is created and -1 is stored at \fI*outPipePtr\fR. .AP int *errFilePtr out If this argument is NULL then error output for all the commands in the pipeline will go to the current standard error file. If \fIerrFilePtr\fR is not NULL, error output from all the commands in the pipeline will go to a temporary file created by \fBTcl_CreatePipeline\fR. A file id to read from that file will be stored at \fI*errFilePtr\fR. The file will already have been removed, so closing the file descriptor at \fI*errFilePtr\fR will cause the file to be flushed completely. .BE .SH DESCRIPTION .PP \fBTcl_CreatePipeline\fR processes the \fIargv\fR array and sets up one or more child processes in a pipeline configuration. \fBTcl_CreatePipeline\fR handles pipes specified with ``|'', input redirection specified with ``<'' or ``<<'', and output redirection specified with ``>''; see the documentation for the \fBexec\fR command for details on these specifications. The return value from \fBTcl_CreatePipeline\fR is a count of the number of child processes created; the process identifiers for those processes are stored in a \fImalloc\fR-ed array and a pointer to that array is stored at \fI*pidArrayPtr\fR. It is the caller's responsibility to free the array when finished with it. .PP If the \fIinPipePtr\fR, \fIoutPipePtr\fR, and \fIerrFilePtr\fR arguments are NULL then the pipeline's standard input, standard output, and standard error are taken from the corresponding streams of the process. Non-NULL values may be specified for these arguments to use pipes for standard input and standard output and a file for standard error. \fBTcl_CreatePipeline\fR will create the requested pipes or file and return file identifiers that may be used to read or write them. It is the caller's responsibility to close all of these files when they are no longer needed. If \fIargv\fR specifies redirection for standard input or standard output, then pipes will not be created even if requested by the \fIinPipePtr\fR and \fIoutPipePtr\fR arguments. .PP If an error occurs in \fBTcl_CreatePipeline\fR (e.g. ``|'' or ``<'' was the last argument in \fIargv\fR, or it wasn't possible to fork off a child), then -1 is returned and \fIinterp->result\fR is set to an error message. .SH "SEE ALSO" \fBTcl_DetachPids\fR, \fBTcl_ReapDetachedProcs\fR .SH KEYWORDS background, child, detach, fork, process, status, wait tcl7.4b4/doc/CrtTrace.3010044400630510000012000000106760575277300700154100ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1989-1993 The Regents of the University of California. '\" Copyright (c) 1994 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) CrtTrace.3 1.10 95/05/06 15:18:07 '\" .so man.macros .TH Tcl_CreateTrace 3 "" Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_CreateTrace, Tcl_DeleteTrace \- arrange for command execution to be traced .SH SYNOPSIS .nf \fB#include \fR .sp Tcl_Trace \fBTcl_CreateTrace\fR(\fIinterp, level, proc, clientData\fR) .sp \fBTcl_DeleteTrace\fR(\fIinterp, trace\fR) .SH ARGUMENTS .AS Tcl_CmdTraceProc (clientData)() .AP Tcl_Interp *interp in Interpreter containing command to be traced or untraced. .AP int level in Only commands at or below this nesting level will be traced. 1 means top-level commands only, 2 means top-level commands or those that are invoked as immediate consequences of executing top-level commands (procedure bodies, bracketed commands, etc.) and so on. .AP Tcl_CmdTraceProc *proc in Procedure to call for each command that's executed. See below for details on the calling sequence. .AP ClientData clientData in Arbitrary one-word value to pass to \fIproc\fR. .AP Tcl_Trace trace in Token for trace to be removed (return value from previous call to \fBTcl_CreateTrace\fR). .BE .SH DESCRIPTION .PP \fBTcl_CreateTrace\fR arranges for command tracing. From now on, \fIproc\fR will be invoked before Tcl calls command procedures to process commands in \fIinterp\fR. The return value from \fBTcl_CreateTrace\fR is a token for the trace, which may be passed to \fBTcl_DeleteTrace\fR to remove the trace. There may be many traces in effect simultaneously for the same command interpreter. .PP \fIProc\fR should have arguments and result that match the type \fBTcl_CmdTraceProc\fR: .nf .sp .RS typedef void Tcl_CmdTraceProc( .RS ClientData \fIclientData\fR, Tcl_Interp *\fIinterp\fR, int \fIlevel\fR, char *\fIcommand\fR, Tcl_CmdProc *\fIcmdProc\fR, ClientData \fIcmdClientData\fR, int \fIargc\fR, char *\fIargv\fR[])); .sp .RE .RE .fi The \fIclientData\fP and \fIinterp\fP parameters are copies of the corresponding arguments given to \fBTcl_CreateTrace\fR. \fIClientData\fR typically points to an application-specific data structure that describes what to do when \fIproc\fR is invoked. \fILevel\fR gives the nesting level of the command (1 for top-level commands passed to \fBTcl_Eval\fR by the application, 2 for the next-level commands passed to \fBTcl_Eval\fR as part of parsing or interpreting level-1 commands, and so on). \fICommand\fR points to a string containing the text of the command, before any argument substitution. \fICmdProc\fR contains the address of the command procedure that will be called to process the command (i.e. the \fIproc\fR argument of some previous call to \fBTcl_CreateCommand\fR) and \fIcmdClientData\fR contains the associated client data for \fIcmdProc\fR (the \fIclientData\fR value passed to \fBTcl_CreateCommand\fR). \fIArgc\fR and \fIargv\fR give the final argument information that will be passed to \fIcmdProc\fR, after command, variable, and backslash substitution. \fIProc\fR must not modify the \fIcommand\fR or \fIargv\fR strings. .PP Tracing will only occur for commands at nesting level less than or equal to the \fIlevel\fR parameter (i.e. the \fIlevel\fR parameter to \fIproc\fR will always be less than or equal to the \fIlevel\fR parameter to \fBTcl_CreateTrace\fR). .PP Calls to \fIproc\fR will be made by the Tcl parser immediately before it calls the command procedure for the command (\fIcmdProc\fR). This occurs after argument parsing and substitution, so tracing for substituted commands occurs before tracing of the commands containing the substitutions. If there is a syntax error in a command, or if there is no command procedure associated with a command name, then no tracing will occur for that command. If a string passed to Tcl_Eval contains multiple commands (bracketed, or on different lines) then multiple calls to \fIproc\fR will occur, one for each command. The \fIcommand\fR string for each of these trace calls will reflect only a single command, not the entire string passed to Tcl_Eval. .PP \fBTcl_DeleteTrace\fR removes a trace, so that no future calls will be made to the procedure associated with the trace. After \fBTcl_DeleteTrace\fR returns, the caller should never again use the \fItrace\fR token. .SH KEYWORDS command, create, delete, interpreter, trace ommand execution to be traced .SH SYNOPSIS .nf \fB#include tcl7.4b4/doc/DString.3010044400630510000012000000132720575277300700152460ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1995 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) DString.3 1.16 95/05/06 15:18:08 '\" .so man.macros .TH Tcl_DString 3 7.4 Tcl "Tcl Library Procedures" .BS .SH NAME .na Tcl_DStringInit, Tcl_DStringAppend, Tcl_DStringAppendElement, Tcl_DStringStartSublist, Tcl_DStringEndSublist, Tcl_DStringLength, Tcl_DStringValue, Tcl_DStringSetLength, Tcl_DStringFree, Tcl_DStringResult, Tcl_DStringGetResult \- manipulate dynamic strings .ad .SH SYNOPSIS .nf \fB#include \fR .sp \fBTcl_DStringInit\fR(\fIdsPtr\fR) .sp char * \fBTcl_DStringAppend\fR(\fIdsPtr, string, length\fR) .sp char * \fBTcl_DStringAppendElement\fR(\fIdsPtr, string\fR) .sp \fBTcl_DStringStartSublist\fR(\fIdsPtr\fR) .sp \fBTcl_DStringEndSublist\fR(\fIdsPtr\fR) .sp int \fBTcl_DStringLength\fR(\fIdsPtr\fR) .sp char * \fBTcl_DStringValue\fR(\fIdsPtr\fR) .sp .VS \fBTcl_DStringSetLength\fR(\fIdsPtr, newLength\fR) .VE .sp \fBTcl_DStringFree\fR(\fIdsPtr\fR) .sp \fBTcl_DStringResult\fR(\fIinterp, dsPtr\fR) .sp .VS \fBTcl_DStringGetResult\fR(\fIinterp, dsPtr\fR) .VE .SH ARGUMENTS .AS Tcl_DString newLength .AP Tcl_DString *dsPtr in/out Pointer to structure that is used to manage a dynamic string. .AP char *string in Pointer to characters to add to dynamic string. .AP int length in Number of characters from string to add to dynamic string. If -1, add all characters up to null terminating character. .AP int newLength in New length for dynamic string, not including null terminating character. .AP Tcl_Interp *interp in/out Interpreter whose result is to be set from or moved to the dynamic string. .BE .SH DESCRIPTION .PP Dynamic strings provide a mechanism for building up arbitrarily long strings by gradually appending information. If the dynamic string is short then there will be no memory allocation overhead; as the string gets larger, additional space will be allocated as needed. .PP \fBTcl_DStringInit\fR initializes a dynamic string to zero length. The Tcl_DString structure must have been allocated by the caller. No assumptions are made about the current state of the structure; anything already in it is discarded. If the structure has been used previously, \fBTcl_DStringFree\fR should be called first to free up any memory allocated for the old string. .PP \fBTcl_DStringAppend\fR adds new information to a dynamic string, allocating more memory for the string if needed. If \fIlength\fR is less than zero then everything in \fIstring\fR is appended to the dynamic string; otherwise \fIlength\fR specifies the number of bytes to append. \fBTcl_DStringAppend\fR returns a pointer to the characters of the new string. The string can also be retrieved from the \fIstring\fR field of the Tcl_DString structure. .PP \fBTcl_DStringAppendElement\fR is similar to \fBTcl_DStringAppend\fR except that it doesn't take a \fIlength\fR argument (it appends all of \fIstring\fR) and it converts the string to a proper list element before appending. \fBTcl_DStringAppendElement\fR adds a separator space before the new list element unless the new list element is the first in a list or sub-list (i.e. either the current string is empty, or it contains the single character ``{'', or the last two characters of the current string are `` {''). \fBTcl_DStringAppendElement\fR returns a pointer to the characters of the new string. .PP \fBTcl_DStringStartSublist\fR and \fBTcl_DStringEndSublist\fR can be used to create nested lists. To append a list element that is itself a sublist, first call \fBTcl_DStringStartSublist\fR, then call \fBTcl_DStringAppendElement\fR for each of the elements in the sublist, then call \fBTcl_DStringEndSublist\fR to end the sublist. \fBTcl_DStringStartSublist\fR appends a space character if needed, followed by an open brace; \fBTcl_DStringEndSublist\fR appends a close brace. Lists can be nested to any depth. .PP \fBTcl_DStringLength\fR is a macro that returns the current length of a dynamic string (not including the terminating null character). \fBTcl_DStringValue\fR is a macro that returns a pointer to the current contents of a dynamic string. .PP .VS .PP \fBTcl_DStringSetLength\fR changes the length of a dynamic string. If \fInewLength\fR is less than the string's current length, then the string is truncated. If \fInewLength\fR is greater than the string's current length, then the string will become longer and new space will be allocated for the string if needed. However, \fBTcl_DStringSetLength\fR will not initialize the new space except to provide a terminating null character; it is up to the caller to fill in the new space. \fBTcl_DStringSetLength\fR does not free up the string's storage space even if the string is truncated to zero length, so \fBTcl_DStringFree\fR will still need to be called. .VE .PP \fBTcl_DStringFree\fR should be called when you're finished using the string. It frees up any memory that was allocated for the string and reinitializes the string's value to an empty string. .PP \fBTcl_DStringResult\fR sets the result of \fIinterp\fR to the value of the dynamic string given by \fIdsPtr\fR. It does this by moving a pointer from \fIdsPtr\fR to \fIinterp->result\fR. This saves the cost of allocating new memory and copying the string. \fBTcl_DStringResult\fR also reinitializes the dynamic string to an empty string. .PP .VS \fBTcl_DStringGetResult\fR does the opposite of \fBTcl_DStringResult\fR. It sets the value of \fIdsPtr\fR to the result of \fIinterp\fR and it clears \fIinterp\fR's result. If possible it does this by moving a pointer rather than by copying the string. .VE .SH KEYWORDS append, dynamic string, free, result tcl7.4b4/doc/DetachPids.3010044400630510000012000000047060575277300700157060ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1989-1993 The Regents of the University of California. '\" Copyright (c) 1994 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) DetachPids.3 1.12 95/05/06 15:18:08 '\" .so man.macros .TH Tcl_DetachPids 3 "" Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_DetachPids, Tcl_ReapDetachedProcs \- manage child processes in background .SH SYNOPSIS .nf \fB#include \fR .sp \fBTcl_DetachPids\fR(\fInumPids, pidPtr\fR) .sp .VS \fBTcl_ReapDetachedProcs\fR() .VE .SH ARGUMENTS .AS int *statusPtr .AP int numPids in Number of process ids contained in the array pointed to by \fIpidPtr\fR. .AP int *pidPtr in Address of array containing \fInumPids\fR process ids. .BE .SH DESCRIPTION .PP .VS \fBTcl_DetachPids\fR and \fBTcl_ReapDetachedProcs\fR provide a mechanism for managing subprocesses that are running in background. These procedures are needed because the parent of a process must eventually invoke the \fBwaitpid\fR kernel call (or one of a few other similar kernel calls) to wait for the child to exit. Until the parent waits for the child, the child's state cannot be completely reclaimed by the system. If a parent continually creates children and doesn't wait on them, the system's process table will eventually overflow, even if all the children have exited. .PP \fBTcl_DetachPids\fR may be called to ask Tcl to take responsibility for one or more processes whose process ids are contained in the \fIpidPtr\fR array passed as argument. The caller presumably has started these processes running in background and doesn't want to have to deal with them again. .PP \fBTcl_ReapDetachedProcs\fR invokes the \fBwaitpid\fR kernel call on each of the background processes so that its state can be cleaned up if it has exited. If the process hasn't exited yet, \fBTcl_ReapDetachedProcs\fR doesn't wait for it to exit; it will check again the next time it is invoked. Tcl automatically calls \fBTcl_ReapDetachedProcs\fR each time the \fBexec\fR command is executed, so in most cases it isn't necessary for any code outside of Tcl to invoke \fBTcl_ReapDetachedProcs\fR. However, if you call \fBTcl_DetachPids\fR in situations where the \fBexec\fR command may never get executed, you may wish to call \fBTcl_ReapDetachedProcs\fR from time to time so that background processes can be cleaned up. .VE .SH KEYWORDS background, child, detach, process, wait tcl7.4b4/doc/EnterFile.3010044400630510000012000000064060575277301000155440ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1989-1993 The Regents of the University of California. '\" Copyright (c) 1994 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) EnterFile.3 1.6 95/05/06 15:18:09 '\" .so man.macros .TH Tcl_EnterFile 3 7.0 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_EnterFile, Tcl_GetOpenFile, Tcl_FilePermissions \- manipulate the table of open files .SH SYNOPSIS .nf \fB#include \fR .sp \fBTcl_EnterFile\fR(\fIinterp, file, permissions\fR) .sp int \fBTcl_GetOpenFile\fR(\fIinterp, string, write, checkUsage, filePtr\fR) .sp int \fBTcl_FilePermissions(\fIfile\fR) .SH ARGUMENTS .AS Tcl_Interp checkUsage .AP Tcl_Interp *interp in Tcl interpreter from which file is to be accessed. .AP FILE *file in Handle for file that is to become accessible in \fIinterp\fR. .AP int permissions in OR-ed combination of TCL_FILE_READABLE and TCL_FILE_WRITABLE; indicates whether \fIfile\fR was opened for reading or writing or both. .AP char *string in String identifying file, such as \fBstdin\fR or \fBfile4\fR. .AP int write in Non-zero means the file will be used for writing, zero means it will be used for reading. .AP int checkUsage in If non-zero, then an error will be generated if the file wasn't opened for the access indicated by \fIwrite\fR. .AP FILE **filePtr out Points to word in which to store pointer to FILE structure for the file given by \fIstring\fR. .BE .SH DESCRIPTION .PP These procedures provide access to Tcl's file naming mechanism. \fBTcl_EnterFile\fR enters an open file into Tcl's file table so that it can be accessed using Tcl commands like \fBgets\fR, \fBputs\fR, \fBseek\fR, and \fBclose\fR. It returns in \fIinterp->result\fR an identifier such as \fBfile4\fR that can be used to refer to the file in subsequent Tcl commands. \fBTcl_EnterFile\fR is typically used to implement new Tcl commands that open sockets, pipes, or other kinds of files not already supported by the built-in commands. .PP \fBTcl_GetOpenFile\fR takes as argument a file identifier of the form returned by the \fBopen\fR command or \fBTcl_EnterFile\fR and returns at \fI*filePtr\fR a pointer to the FILE structure for the file. The \fIwrite\fR argument indicates whether the FILE pointer will be used for reading or writing. In some cases, such as a file that connects to a pipeline of subprocesses, different FILE pointers will be returned for reading and writing. \fBTcl_GetOpenFile\fR normally returns TCL_OK. If an error occurs in \fBTcl_GetOpenFile\fR (e.g. \fIstring\fR didn't make any sense or \fIcheckUsage\fR was set and the file wasn't opened for the access specified by \fIwrite\fR) then TCL_ERROR is returned and \fIinterp->result\fR will contain an error message. If \fIcheckUsage\fR is zero and the file wasn't opened for the access specified by \fIwrite\fR, then the FILE pointer returned at \fI*filePtr\fR may not correspond to \fIwrite\fR. .PP \fBTcl_FilePermissions\fR returns an OR-ed combination of the mask bits TCL_FILE_READABLE and TCL_FILE_WRITABLE; these indicate whether the given file was opened for reading or writing or both. If \fIfile\fR does not refer to a file in Tcl's file table then \-1 is returned. .SH KEYWORDS file table, permissions, pipeline, read, write tcl7.4b4/doc/Eval.3010044400630510000012000000077270575277301000145650ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1989-1993 The Regents of the University of California. '\" Copyright (c) 1994 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) Eval.3 1.15 95/05/06 15:18:10 '\" .so man.macros .TH Tcl_Eval 3 7.0 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_Eval, Tcl_VarEval, Tcl_EvalFile, Tcl_GlobalEval \- execute Tcl commands .SH SYNOPSIS .nf \fB#include \fR .sp int .VS \fBTcl_Eval\fR(\fIinterp, cmd\fR) .VE .sp int \fBTcl_VarEval\fR(\fIinterp, string, string, ... \fB(char *) NULL\fR) .sp int \fBTcl_EvalFile\fR(\fIinterp, fileName\fR) .sp int \fBTcl_GlobalEval\fR(\fIinterp, cmd\fR) .SH ARGUMENTS .AS Tcl_Interp **termPtr; .AP Tcl_Interp *interp in Interpreter in which to execute the command. String result will be stored in \fIinterp->result\fR. .AP char *cmd in Command (or sequence of commands) to execute. Must be in writable memory (\fBTcl_Eval\fR makes temporary modifications to the command). .AP char *string in String forming part of Tcl command. .AP char *fileName in Name of file containing Tcl command string. .BE .SH DESCRIPTION .PP All four of these procedures execute Tcl commands. \fBTcl_Eval\fR is the core procedure: it parses commands from \fIcmd\fR and executes them in .VS order until either an error occurs or it reaches the end of the string. .VE The return value from \fBTcl_Eval\fR is one of the Tcl return codes \fBTCL_OK\fR, \fBTCL_ERROR\fR, \fBTCL_RETURN\fR, \fBTCL_BREAK\fR, or \fBTCL_CONTINUE\fR, and \fIinterp->result\fR will point to a string with additional information (result value or error message). This return information corresponds to the last command executed from \fIcmd\fR. .PP \fBTcl_VarEval\fR takes any number of string arguments of any length, concatenates them into a single string, then calls \fBTcl_Eval\fR to execute that string as a Tcl command. It returns the result of the command and also modifies \fIinterp->result\fR in the usual fashion for Tcl commands. The last argument to \fBTcl_VarEval\fR must be NULL to indicate the end of arguments. .PP \fBTcl_EvalFile\fR reads the file given by \fIfileName\fR and evaluates its contents as a Tcl command by calling \fBTcl_Eval\fR. It returns a standard Tcl result that reflects the result of evaluating the file. If the file couldn't be read then a Tcl error is returned to describe why the file couldn't be read. .PP \fBTcl_GlobalEval\fR is similar to \fBTcl_Eval\fR except that it processes the command at global level. This means that the variable context for the command consists of global variables only (it ignores any Tcl procedure that is active). This produces an effect similar to the Tcl command ``\fBuplevel 0\fR''. .PP During the processing of a Tcl command it is legal to make nested calls to evaluate other commands (this is how conditionals, loops, and procedures are implemented). If a code other than \fBTCL_OK\fR is returned from a nested \fBTcl_Eval\fR invocation, then the caller should normally return immediately, passing that same return code back to its caller, and so on until the top-level application is reached. A few commands, like \fBfor\fR, will check for certain return codes, like \fBTCL_BREAK\fR and \fBTCL_CONTINUE\fR, and process them specially without returning. .PP \fBTcl_Eval\fR keeps track of how many nested Tcl_Eval invocations are in progress for \fIinterp\fR. If a code of \fBTCL_RETURN\fR, \fBTCL_BREAK\fR, or \fBTCL_CONTINUE\fR is about to be returned from the topmost \fBTcl_Eval\fR invocation for \fIinterp\fR, then \fBTcl_Eval\fR converts the return code to \fBTCL_ERROR\fR and sets \fIinterp->result\fR to point to an error message indicating that the \fBreturn\fR, \fBbreak\fR, or \fBcontinue\fR command was invoked in an inappropriate place. This means that top-level applications should never see a return code from \fBTcl_Eval\fR other then \fBTCL_OK\fR or \fBTCL_ERROR\fR. .SH KEYWORDS command, execute, file, global, interpreter, variable tcl7.4b4/doc/ExprLong.3010044400630510000012000000074250575277301000154270ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1989-1993 The Regents of the University of California. '\" Copyright (c) 1994-1995 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) ExprLong.3 1.15 95/05/06 15:18:11 '\" .so man.macros .TH Tcl_ExprLong 3 7.0 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_ExprLong, Tcl_ExprDouble, Tcl_ExprBoolean, Tcl_ExprString \- evaluate an expression .SH SYNOPSIS .nf \fB#include \fR .sp int \fBTcl_ExprLong\fR(\fIinterp, string, longPtr\fR) .sp int \fBTcl_ExprDouble\fR(\fIinterp, string, doublePtr\fR) .sp int \fBTcl_ExprBoolean\fR(\fIinterp, string, booleanPtr\fR) .sp int \fBTcl_ExprString\fR(\fIinterp, string\fR) .SH ARGUMENTS .AS Tcl_Interp *booleanPtr .AP Tcl_Interp *interp in Interpreter in whose context to evaluate \fIstring\fR. .AP char *string in Expression to be evaluated. Must be in writable memory (the expression parser makes temporary modifications to the string during parsing, which it undoes before returning). .AP long *longPtr out Pointer to location in which to store the integer value of the expression. .AP int *doublePtr out Pointer to location in which to store the floating-point value of the expression. .AP int *booleanPtr out Pointer to location in which to store the 0/1 boolean value of the expression. .BE .SH DESCRIPTION .PP These four procedures all evaluate an expression, returning the result in one of four different forms. The expression is given by the \fIstring\fR argument, and it can have any of the forms accepted by the \fBexpr\fR command. The \fIinterp\fR argument refers to an interpreter used to evaluate the expression (e.g. for variables and nested Tcl commands) and to return error information. \fIInterp->result\fR is assumed to be initialized in the standard fashion when any of the procedures are invoked. .PP For all of these procedures the return value is a standard Tcl result: \fBTCL_OK\fR means the expression was successfully evaluated, and \fBTCL_ERROR\fR means that an error occurred while evaluating the expression. If \fBTCL_ERROR\fR is returned then \fIinterp->result\fR will hold a message describing the error. If an error occurs while executing a Tcl command embedded in the expression then that error will be returned. .PP If the expression is successfully evaluated, then its value is returned in one of four forms, depending on which procedure is invoked. \fBTcl_ExprLong\fR stores an integer value at \fI*longPtr\fR. If the expression's actual value is a floating-point number, then it is truncated to an integer. If the expression's actual value is a non-numeric string then an error is returned. .PP \fBTcl_ExprDouble\fR stores a floating-point value at \fI*doublePtr\fR. If the expression's actual value is an integer, it is converted to floating-point. If the expression's actual value is a non-numeric string then an error is returned. .PP \fBTcl_ExprBoolean\fR stores a 0/1 integer value at \fI*booleanPtr\fR. If the expression's actual value is an integer or floating-point number, then \fBTcl_ExprBoolean\fR stores 0 at \fI*booleanPtr\fR if the value was zero and 1 otherwise. .VS If the expression's actual value is a non-numeric string then it must be one of the values accepted by \fBTcl_GetBoolean\fR, such as ``yes'' or ``no'', or else an error occurs. .VE .PP \fBTcl_ExprString\fR returns the value of the expression as a string stored in \fIinterp->result\fR. .VS If the expression's actual value is an integer then \fBTcl_ExprString\fR converts it to a string using \fBsprintf\fR with a ``%d'' converter. If the expression's actual value is a floating-point number, then \fBTcl_ExprString\fR calls \fBTcl_PrintDouble\fR to convert it to a string. .VE .SH KEYWORDS boolean, double, evaluate, expression, integer, string tcl7.4b4/doc/GetInt.3010044400630510000012000000061070575277301000150570ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1989-1993 The Regents of the University of California. '\" Copyright (c) 1994 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) GetInt.3 1.10 95/05/06 15:18:12 '\" .so man.macros .TH Tcl_GetInt 3 "" Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_GetInt, Tcl_GetDouble, Tcl_GetBoolean \- convert from string to integer, double, or boolean .SH SYNOPSIS .nf \fB#include \fR .sp int \fBTcl_GetInt\fR(\fIinterp, string, intPtr\fR) .sp int \fBTcl_GetDouble\fR(\fIinterp, string, doublePtr\fR) .sp int \fBTcl_GetBoolean\fR(\fIinterp, string, boolPtr\fR) .SH ARGUMENTS .AS Tcl_Interp *doublePtr .AP Tcl_Interp *interp in Interpreter to use for error reporting. .AP char *string in Textual value to be converted. .AP int *intPtr out Points to place to store integer value converted from \fIstring\fR. .AP double *doublePtr out Points to place to store double-precision floating-point value converted from \fIstring\fR. .AP int *boolPtr out Points to place to store boolean value (0 or 1) converted from \fIstring\fR. .BE .SH DESCRIPTION .PP These procedures convert from strings to integers or double-precision floating-point values or booleans (represented as 0- or 1-valued integers). Each of the procedures takes a \fIstring\fR argument, converts it to an internal form of a particular type, and stores the converted value at the location indicated by the procedure's third argument. If all goes well, each of the procedures returns TCL_OK. If \fIstring\fR doesn't have the proper syntax for the desired type then TCL_ERROR is returned, an error message is left in \fIinterp->result\fR, and nothing is stored at *\fIintPtr\fR or *\fIdoublePtr\fR or *\fIboolPtr\fR. .PP \fBTcl_GetInt\fR expects \fIstring\fR to consist of a collection of integer digits, optionally signed and optionally preceded by white space. If the first two characters of \fIstring\fR are ``0x'' then \fIstring\fR is expected to be in hexadecimal form; otherwise, if the first character of \fIstring\fR is ``0'' then \fIstring\fR is expected to be in octal form; otherwise, \fIstring\fR is expected to be in decimal form. .PP \fBTcl_GetDouble\fR expects \fIstring\fR to consist of a floating-point number, which is: white space; a sign; a sequence of digits; a decimal point; a sequence of digits; the letter ``e''; and a signed decimal exponent. Any of the fields may be omitted, except that the digits either before or after the decimal point must be present and if the ``e'' is present then it must be followed by the exponent number. .PP \fBTcl_GetBoolean\fR expects \fIstring\fR to specify a boolean value. If \fIstring\fR is any of \fB0\fR, \fBfalse\fR, \fBno\fR, or \fBoff\fR, then \fBTcl_GetBoolean\fR stores a zero value at \fI*boolPtr\fR. If \fIstring\fR is any of \fB1\fR, \fBtrue\fR, \fByes\fR, or \fBon\fR, then 1 is stored at \fI*boolPtr\fR. Any of these values may be abbreviated, and upper-case spellings are also acceptable. .SH KEYWORDS boolean, conversion, double, floating-point, integer tcl7.4b4/doc/Hash.3010044400630510000012000000202040575277301000145420ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1989-1993 The Regents of the University of California. '\" Copyright (c) 1994-1995 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) Hash.3 1.12 95/05/06 15:18:12 '\" .so man.macros .TH Tcl_Hash 3 "" Tcl "Tcl Library Procedures" .BS .SH NAME .na Tcl_InitHashTable, Tcl_DeleteHashTable, Tcl_CreateHashEntry, Tcl_DeleteHashEntry, Tcl_FindHashEntry, Tcl_GetHashValue, Tcl_SetHashValue, Tcl_GetHashKey, Tcl_FirstHashEntry, Tcl_NextHashEntry, Tcl_HashStats \- procedures to manage hash tables .SH SYNOPSIS .nf \fB#include \fR .sp \fBTcl_InitHashTable\fR(\fItablePtr, keyType\fR) .sp \fBTcl_DeleteHashTable\fR(\fItablePtr\fR) .sp Tcl_HashEntry * \fBTcl_CreateHashEntry\fR(\fItablePtr, key, newPtr\fR) .sp \fBTcl_DeleteHashEntry\fR(\fIentryPtr\fR) .sp Tcl_HashEntry * \fBTcl_FindHashEntry\fR(\fItablePtr, key\fR) .sp ClientData \fBTcl_GetHashValue\fR(\fIentryPtr\fR) .sp \fBTcl_SetHashValue\fR(\fIentryPtr, value\fR) .sp char * \fBTcl_GetHashKey\fR(\fItablePtr, entryPtr\fR) .sp Tcl_HashEntry * \fBTcl_FirstHashEntry\fR(\fItablePtr, searchPtr\fR) .sp Tcl_HashEntry * \fBTcl_NextHashEntry\fR(\fIsearchPtr\fR) .sp char * \fBTcl_HashStats\fR(\fItablePtr\fR) .SH ARGUMENTS .AS Tcl_HashSearch *searchPtr .AP Tcl_HashTable *tablePtr in Address of hash table structure (for all procedures but \fBTcl_InitHashTable\fR, this must have been initialized by previous call to \fBTcl_InitHashTable\fR). .AP int keyType in Kind of keys to use for new hash table. Must be either TCL_STRING_KEYS, TCL_ONE_WORD_KEYS, or an integer value greater than 1. .AP char *key in Key to use for probe into table. Exact form depends on \fIkeyType\fR used to create table. .AP int *newPtr out The word at \fI*newPtr\fR is set to 1 if a new entry was created and 0 if there was already an entry for \fIkey\fR. .AP Tcl_HashEntry *entryPtr in Pointer to hash table entry. .AP ClientData value in New value to assign to hash table entry. Need not have type ClientData, but must fit in same space as ClientData. .AP Tcl_HashSearch *searchPtr in Pointer to record to use to keep track of progress in enumerating all the entries in a hash table. .BE .SH DESCRIPTION .PP A hash table consists of zero or more entries, each consisting of a key and a value. Given the key for an entry, the hashing routines can very quickly locate the entry, and hence its value. There may be at most one entry in a hash table with a particular key, but many entries may have the same value. Keys can take one of three forms: strings, one-word values, or integer arrays. All of the keys in a given table have the same form, which is specified when the table is initialized. .PP The value of a hash table entry can be anything that fits in the same space as a ``char *'' pointer. Values for hash table entries are managed entirely by clients, not by the hash module itself. Typically each entry's value is a pointer to a data structure managed by client code. .PP Hash tables grow gracefully as the number of entries increases, so that there are always less than three entries per hash bucket, on average. This allows for fast lookups regardless of the number of entries in a table. .PP \fBTcl_InitHashTable\fR initializes a structure that describes a new hash table. The space for the structure is provided by the caller, not by the hash module. The value of \fIkeyType\fR indicates what kinds of keys will be used for all entries in the table. \fIKeyType\fR must have one of the following values: .IP \fBTCL_STRING_KEYS\fR 25 Keys are null-terminated ASCII strings. They are passed to hashing routines using the address of the first character of the string. .IP \fBTCL_ONE_WORD_KEYS\fR 25 Keys are single-word values; they are passed to hashing routines and stored in hash table entries as ``char *'' values. The pointer value is the key; it need not (and usually doesn't) actually point to a string. .IP \fIother\fR 25 If \fIkeyType\fR is not TCL_STRING_KEYS or TCL_ONE_WORD_KEYS, then it must be an integer value greater than 1. In this case the keys will be arrays of ``int'' values, where \fIkeyType\fR gives the number of ints in each key. This allows structures to be used as keys. All keys must have the same size. Array keys are passed into hashing functions using the address of the first int in the array. .PP \fBTcl_DeleteHashTable\fR deletes all of the entries in a hash table and frees up the memory associated with the table's bucket array and entries. It does not free the actual table structure (pointed to by \fItablePtr\fR), since that memory is assumed to be managed by the client. \fBTcl_DeleteHashTable\fR also does not free or otherwise manipulate the values of the hash table entries. If the entry values point to dynamically-allocated memory, then it is the client's responsibility to free these structures before deleting the table. .PP \fBTcl_CreateHashEntry\fR locates the entry corresponding to a particular key, creating a new entry in the table if there wasn't already one with the given key. If an entry already existed with the given key then \fI*newPtr\fR is set to zero. If a new entry was created, then \fI*newPtr\fR is set to a non-zero value and the value of the new entry will be set to zero. The return value from \fBTcl_CreateHashEntry\fR is a pointer to the entry, which may be used to retrieve and modify the entry's value or to delete the entry from the table. .PP \fBTcl_DeleteHashEntry\fR will remove an existing entry from a table. The memory associated with the entry itself will be freed, but the client is responsible for any cleanup associated with the entry's value, such as freeing a structure that it points to. .PP \fBTcl_FindHashEntry\fR is similar to \fBTcl_CreateHashEntry\fR except that it doesn't create a new entry if the key doesn't exist; instead, it returns NULL as result. .PP \fBTcl_GetHashValue\fR and \fBTcl_SetHashValue\fR are used to read and write an entry's value, respectively. Values are stored and retrieved as type ``ClientData'', which is large enough to hold a pointer value. On almost all machines this is large enough to hold an integer value too. .PP \fBTcl_GetHashKey\fR returns the key for a given hash table entry, either as a pointer to a string, a one-word (``char *'') key, or as a pointer to the first word of an array of integers, depending on the \fIkeyType\fR used to create a hash table. In all cases \fBTcl_GetHashKey\fR returns a result with type ``char *''. When the key is a string or array, the result of \fBTcl_GetHashKey\fR points to information in the table entry; this information will remain valid until the entry is deleted or its table is deleted. .PP \fBTcl_FirstHashEntry\fR and \fBTcl_NextHashEntry\fR may be used to scan all of the entries in a hash table. A structure of type ``Tcl_HashSearch'', provided by the client, is used to keep track of progress through the table. \fBTcl_FirstHashEntry\fR initializes the search record and returns the first entry in the table (or NULL if the table is empty). Each subsequent call to \fBTcl_NextHashEntry\fR returns the next entry in the table or NULL if the end of the table has been reached. A call to \fBTcl_FirstHashEntry\fR followed by calls to \fBTcl_NextHashEntry\fR will return each of the entries in the table exactly once, in an arbitrary order. It is unadvisable to modify the structure of the table, e.g. by creating or deleting entries, while the search is in progress. .PP \fBTcl_HashStats\fR returns a dynamically-allocated string with overall information about a hash table, such as the number of entries it contains, the number of buckets in its hash array, and the utilization of the buckets. It is the caller's responsibility to free the result string by passing it to \fBfree\fR. .PP The header file \fBtcl.h\fR defines the actual data structures used to implement hash tables. This is necessary so that clients can allocate Tcl_HashTable structures and so that macros can be used to read and write the values of entries. However, users of the hashing routines should never refer directly to any of the fields of any of the hash-related data structures; use the procedures and macros defined here. .SH KEYWORDS hash table, key, lookup, search, value tcl7.4b4/doc/Interp.3010044400630510000012000000124640575277301000151310ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1989-1993 The Regents of the University of California. '\" Copyright (c) 1994 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) Interp.3 1.12 95/05/06 15:18:13 '\" .so man.macros .TH Tcl_Interp 3 "" Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_Interp \- client-visible fields of interpreter structures .SH SYNOPSIS .nf \fB#include \fR .sp typedef struct { char *\fIresult\fR; Tcl_FreeProc *\fIfreeProc\fR; int \fIerrorLine\fR; } Tcl_Interp; typedef void Tcl_FreeProc(char *\fIblockPtr\fR); .BE .SH DESCRIPTION .PP The \fBTcl_CreateInterp\fR procedure returns a pointer to a Tcl_Interp structure. This pointer is then passed into other Tcl procedures to process commands in the interpreter and perform other operations on the interpreter. Interpreter structures contain many many fields that are used by Tcl, but only three that may be accessed by clients: \fIresult\fR, \fIfreeProc\fR, and \fIerrorLine\fR. .PP The \fIresult\fR and \fIfreeProc\fR fields are used to return results or error messages from commands. This information is returned by command procedures back to \fBTcl_Eval\fR, and by \fBTcl_Eval\fR back to its callers. The \fIresult\fR field points to the string that represents the result or error message, and the \fIfreeProc\fR field tells how to dispose of the storage for the string when it isn't needed anymore. The easiest way for command procedures to manipulate these fields is to call procedures like \fBTcl_SetResult\fR or \fBTcl_AppendResult\fR; they will hide all the details of managing the fields. The description below is for those procedures that manipulate the fields directly. .PP Whenever a command procedure returns, it must ensure that the \fIresult\fR field of its interpreter points to the string being returned by the command. The \fIresult\fR field must always point to a valid string. If a command wishes to return no result then \fIinterp->result\fR should point to an empty string. Normally, results are assumed to be statically allocated, which means that the contents will not change before the next time \fBTcl_Eval\fR is called or some other command procedure is invoked. In this case, the \fIfreeProc\fR field must be zero. Alternatively, a command procedure may dynamically allocate its return value (e.g. using \fBmalloc\fR) and store a pointer to it in \fIinterp->result\fR. In this case, the command procedure must also set \fIinterp->freeProc\fR to the address of a procedure that can free the value (usually \fBfree\fR). If \fIinterp->freeProc\fR is non-zero, then Tcl will call \fIfreeProc\fR to free the space pointed to by \fIinterp->result\fR before it invokes the next command. If a client procedure overwrites \fIinterp->result\fR when \fIinterp->freeProc\fR is non-zero, then it is responsible for calling \fIfreeProc\fR to free the old \fIinterp->result\fR (the \fBTcl_FreeResult\fR macro should be used for this purpose). .PP \fIFreeProc\fR should have arguments and result that match the \fBTcl_FreeProc\fR declaration above: it receives a single argument which is a pointer to the result value to free. In most applications \fBfree\fR is the only non-zero value ever used for \fIfreeProc\fR. However, an application may store a different procedure address in \fIfreeProc\fR in order to use an alternate memory allocator or in order to do other cleanup when the result memory is freed. .PP As part of processing each command, \fBTcl_Eval\fR initializes \fIinterp->result\fR and \fIinterp->freeProc\fR just before calling the command procedure for the command. The \fIfreeProc\fR field will be initialized to zero, and \fIinterp->result\fR will point to an empty string. Commands that do not return any value can simply leave the fields alone. Furthermore, the empty string pointed to by \fIresult\fR is actually part of an array of \fBTCL_RESULT_SIZE\fR characters (approximately 200). If a command wishes to return a short string, it can simply copy it to the area pointed to by \fIinterp->result\fR. Or, it can use the sprintf procedure to generate a short result string at the location pointed to by \fIinterp->result\fR. .PP It is a general convention in Tcl-based applications that the result of an interpreter is normally in the initialized state described in the previous paragraph. Procedures that manipulate an interpreter's result (e.g. by returning an error) will generally assume that the result has been initialized when the procedure is called. If such a procedure is to be called after the result has been changed, then \fBTcl_ResetResult\fR should be called first to reset the result to its initialized state. .PP The \fIerrorLine\fR field is valid only after \fBTcl_Eval\fR returns a \fBTCL_ERROR\fR return code. In this situation the \fIerrorLine\fR field identifies the line number of the command being executed when the error occurred. The line numbers are relative to the command being executed: 1 means the first line of the command passed to \fBTcl_Eval\fR, 2 means the second line, and so on. The \fIerrorLine\fR field is typically used in conjunction with \fBTcl_AddErrorInfo\fR to report information about where an error occurred. \fIErrorLine\fR should not normally be modified except by \fBTcl_Eval\fR. .SH KEYWORDS free, initialized, interpreter, malloc, result result\fR field of its interpreter points to the string being returned by the command. The \fIresult\fR field must always point to a valid string. If a command wishes to return no result then \fIinterp->rtcl7.4b4/doc/LinkVar.3010044400630510000012000000071300575277301000152300ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1995 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) LinkVar.3 1.8 95/05/06 15:18:14 '\" .so man.macros .TH Tcl_LinkVar 3 7.0 Tcl "Tcl Library Procedures" .BS .SH NAME .na Tcl_LinkVar, Tcl_UnlinkVar \- link Tcl variable to C variable .ad .SH SYNOPSIS .nf \fB#include \fR .sp int \fBTcl_LinkVar\fR(\fIinterp, varName, addr, type\fR) .sp \fBTcl_UnlinkVar\fR(\fIinterp, varName\fR) .SH ARGUMENTS .AS Tcl_Interp writable .AP Tcl_Interp *interp in Interpreter that contains \fIvarName\fR. Also used by \fBTcl_LinkVar\fR to return error messages. .AP char *varName in Name of global variable. .AP char *addr in Address of C variable that is to be linked to \fIvarName\fR. .AP int type in .na Type of C variable. Must be one of TCL_LINK_INT, TCL_LINK_DOUBLE, TCL_LINK_BOOLEAN, or TCL_LINK_STRING, optionally OR'ed with TCL_LINK_READ_ONLY to make Tcl variable read-only. .ad .BE .SH DESCRIPTION .PP \fBTcl_LinkVar\fR uses variable traces to keep the Tcl variable named by \fIvarName\fR in sync with the C variable at the address given by \fIaddr\fR. Whenever the Tcl variable is read the value of the C variable will be returned, and whenever the Tcl variable is written the C variable will be updated to have the same value. \fBTcl_LinkVar\fR normally returns TCL_OK; if an error occurs while setting up the link (e.g. because \fIvarName\fR is the name of array) then TCL_ERROR is returned and \fIinterp->result\fR contains an error message. .PP The \fItype\fR argument specifies the type of the C variable, and must have one of the following values, optionally OR'ed with TCL_LINK_READ_ONLY: .TP \fBTCL_LINK_INT\fR The C variable is of type \fBint\fR. Any value written into the Tcl variable must have a proper integer form acceptable to \fBTcl_GetInt\fR; attempts to write non-integer values into \fIvarName\fR will be rejected with Tcl errors. .TP \fBTCL_LINK_DOUBLE\fR The C variable is of type \fBdouble\fR. Any value written into the Tcl variable must have a proper real form acceptable to \fBTcl_GetDouble\fR; attempts to write non-real values into \fIvarName\fR will be rejected with Tcl errors. .TP \fBTCL_LINK_BOOLEAN\fR The C variable is of type \fBint\fR. If its value is zero then it will read from Tcl as ``0''; otherwise it will read from Tcl as ``1''. Whenever \fIvarName\fR is modified, the C variable will be set to a 0 or 1 value. Any value written into the Tcl variable must have a proper boolean form acceptable to \fBTcl_GetBoolean\fR; attempts to write non-boolean values into \fIvarName\fR will be rejected with Tcl errors. .TP \fBTCL_LINK_STRING\fR The C variable is of type \fBchar *\fR. If its value is not null then it must be a pointer to a string allocated with \fBmalloc\fR. Whenever the Tcl variable is modified the current C string will be freed and new memory will be allocated to hold a copy of the variable's new value. If the C variable contains a null pointer then the Tcl variable will read as ``NULL''. .PP If the TCL_LINK_READ_ONLY flag is present in \fItype\fR then the variable will be read-only from Tcl, so that its value can only be changed by modifying the C variable. Attempts to write the variable from Tcl will be rejected with errors. .PP \fBTcl_UnlinkVar\fR removes the link previously set up for the variable given by \fIvarName\fR. If there does not exist a link for \fIvarName\fR then the procedure has no effect. .SH KEYWORDS boolean, integer, link, read-only, real, string, variable tcl7.4b4/doc/Tcl.n010044400630510000012000000156170576215603200145100ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1995 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) Tcl.n 1.123 95/05/28 13:24:41 ' .so man.macros .de UL \\$1\l'|0\(ul'\\$2 .. .TH Tcl n "" Tcl "Tcl Built-In Commands" .BS .SH NAME Tcl \- Summary of Tcl language syntax. .BE .SH DESCRIPTION .LP The following rules define the syntax and semantics of the Tcl language: .IP [1] A Tcl script is a string containing one or more commands. Semi-colons and newlines are command separators unless quoted as described below. Close brackets are command terminators during command substitution (see below) unless quoted. .IP [2] A command is evaluated in two steps. First, the Tcl interpreter breaks the command into \fIwords\fR and performs substitutions as described below. These substitutions are performed in the same way for all commands. The first word is used to locate a command procedure to carry out the command, then all of the words of the command are passed to the command procedure. The command procedure is free to interpret each of its words in any way it likes, such as an integer, variable name, list, or Tcl script. Different commands interpret their words differently. .IP [3] Words of a command are separated by white space (except for newlines, which are command separators). .IP [4] If the first character of a word is double-quote (``"'') then the word is terminated by the next double-quote character. If semi-colons, close brackets, or white space characters (including newlines) appear between the quotes then they are treated as ordinary characters and included in the word. Command substitution, variable substitution, and backslash substitution are performed on the characters between the quotes as described below. The double-quotes are not retained as part of the word. .IP [5] If the first character of a word is an open brace (``{'') then the word is terminated by the matching close brace (``}''). Braces nest within the word: for each additional open brace there must be an additional close brace (however, if an open brace or close brace within the word is quoted with a backslash then it is not counted in locating the matching close brace). No substitutions are performed on the characters between the braces except for backslash-newline substitutions described below, nor do semi-colons, newlines, close brackets, or white space receive any special interpretation. The word will consist of exactly the characters between the outer braces, not including the braces themselves. .IP [6] If a word contains an open bracket (``['') then Tcl performs \fIcommand substitution\fR. To do this it invokes the Tcl interpreter recursively to process the characters following the open bracket as a Tcl script. The script may contain any number of commands and must be terminated by a close bracket (``]''). The result of the script (i.e. the result of its last command) is substituted into the word in place of the brackets and all of the characters between them. There may be any number of command substitutions in a single word. Command substitution is not performed on words enclosed in braces. .IP [7] If a word contains a dollar-sign (``$'') then Tcl performs \fIvariable substitution\fR: the dollar-sign and the following characters are replaced in the word by the value of a variable. Variable substitution may take any of the following forms: .RS .TP 15 \fB$\fIname\fR \fIName\fR is the name of a scalar variable; the name is terminated by any character that isn't a letter, digit, or underscore. .TP 15 \fB$\fIname\fB(\fIindex\fB)\fR \fIName\fR gives the name of an array variable and \fIindex\fR gives the name of an element within that array. \fIName\fR must contain only letters, digits, and underscores. Command substitutions, variable substitutions, and backslash substitutions are performed on the characters of \fIindex\fR. .TP 15 \fB${\fIname\fB}\fR \fIName\fR is the name of a scalar variable. It may contain any characters whatsoever except for close braces. .RE .LP There may be any number of variable substitutions in a single word. Variable substitution is not performed on words enclosed in braces. .IP [8] If a backslash (``\e'') appears within a word then \fIbackslash substitution\fR occurs. .VS In all cases but those described below the backslash is dropped and the following character is treated as an ordinary character and included in the word. .VE This allows characters such as double quotes, close brackets, and dollar signs to be included in words without triggering special processing. The following table lists the backslash sequences that are handled specially, along with the value that replaces each sequence. .RS .VS .TP 6 \e\fBa\fR Audible alert (bell) (0x7). .VE .TP 6 \e\fBb\fR Backspace (0x8). .TP 6 \e\fBf\fR Form feed (0xc). .TP 6 \e\fBn\fR Newline (0xa). .TP 6 \e\fBr\fR Carriage-return (0xd). .TP 6 \e\fBt\fR Tab (0x9). .TP 6 \e\fBv\fR Vertical tab (0xb). .TP 6 \e\fB\fIwhiteSpace\fR .VS A single space character replaces the backslash, newline, and all white space after the newline. This backslash sequence is unique in that it is replaced in a separate pre-pass before the command is actually parsed. This means that it will be replaced even when it occurs between braces, and the resulting space will be treated as a word separator if it isn't in braces or quotes. .VE .TP 6 \e\e Backslash (``\e''). .TP 6 \e\fIooo\fR The digits \fIooo\fR (one, two, or three of them) give the octal value of the character. .TP 6 \e\fBx\fIhh\fR .VS The hexadecimal digits \fIhh\fR give the hexadecimal value of the character. Any number of digits may be present. .VE .RE .LP Backslash substitution is not performed on words enclosed in braces, except for backslash-newline as described above. .IP [9] If a hash character (``#'') appears at a point where Tcl is expecting the first character of the first word of a command, then the hash character and the characters that follow it, up through the next newline, are treated as a comment and ignored. The comment character only has significance when it appears at the beginning of a command. .IP [10] Each character is processed exactly once by the Tcl interpreter as part of creating the words of a command. For example, if variable substitution occurs then no further substitutions are performed on the value of the variable; the value is inserted into the word verbatim. If command substitution occurs then the nested command is processed entirely by the recursive call to the Tcl interpreter; no substitutions are performed before making the recursive call and no additional substitutions are performed on the result of the nested script. .IP [11] Substitutions do not affect the word boundaries of a command. For example, during variable substitution the entire value of the variable becomes part of a single word, even if the variable's value contains spaces. tcl7.4b4/doc/PrintDbl.3010044400630510000012000000030100575277301100153720ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1989-1993 The Regents of the University of California. '\" Copyright (c) 1994 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) PrintDbl.3 1.4 95/05/06 15:18:15 '\" .so man.macros .TH Tcl_PrintDouble 3 7.0 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_PrintDouble \- Convert floating value to string .SH SYNOPSIS .nf \fB#include \fR .sp \fBTcl_PrintDouble\fR(\fIinterp, value, dst\fR) .SH ARGUMENTS .AS Tcl_Interp *interp .AP Tcl_Interp *interp in Interpreter that controls the conversion. .AP double value in Floating-point value to be converted. .AP char *dst out Where to store string representing \fIvalue\fR. Must have at least TCL_DOUBLE_SPACE characters of storage. .BE .SH DESCRIPTION .PP \fBTcl_PrintDouble\fR generates a string that represents the value of \fIvalue\fR and stores it in memory at the location given by \fIdst\fR. It uses %g format to generate the string, with two special twists. First, the string is guaranteed to contain either a ``.'' or an ``e'' so that it doesn't look like an integer (where %g would generate an integer with no decimal point, \fBTcl_PrintDouble\fR adds ``.0''). Second, the number of significant digits printed at \fIdst\fR is controlled by the \fBtcl_precision\fR variable in \fIinterp\fR; if \fBtcl_precision\fR is undefined then 6 significant digits are printed. .SH KEYWORDS conversion, double-precision, floating-point, string tcl7.4b4/doc/RecordEval.3010044400630510000012000000034230575277301100157120ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1989-1993 The Regents of the University of California. '\" Copyright (c) 1994-1995 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) RecordEval.3 1.14 95/05/06 15:18:16 '\" .so man.macros .TH Tcl_RecordAndEval 3 7.4 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_RecordAndEval \- save command on history list before evaluating .SH SYNOPSIS .nf \fB#include \fR .sp int \fBTcl_RecordAndEval\fR(\fIinterp, cmd, eval\fR) .SH ARGUMENTS .AS Tcl_Interp *interp; .AP Tcl_Interp *interp in Tcl interpreter in which to evaluate command. .AP char *cmd in Command (or sequence of commands) to execute. .AP int flags in .VS An OR'ed combination of flag bits. TCL_NO_EVAL means record the command but don't evaluate it. TCL_EVAL_GLOBAL means evaluate the command at global level instead of the current stack level. .VE .BE .SH DESCRIPTION .PP \fBTcl_RecordAndEval\fR is invoked to record a command as an event on the history list and then execute it using \fBTcl_Eval\fR .VS (or \fBTcl_GlobalEval\fR if the TCL_EVAL_GLOBAL bit is set in \fIflags\fR). .VE It returns a completion code such as TCL_OK just like \fBTcl_Eval\fR and it leaves information in \fIinterp->result\fR. If you don't want the command recorded on the history list then you should invoke \fBTcl_Eval\fR instead of \fBTcl_RecordAndEval\fR. Normally \fBTcl_RecordAndEval\fR is only called with top-level commands typed by the user, since the purpose of history is to allow the user to re-issue recently-invoked commands. If the \fIflags\fR argument contains the TCL_NO_EVAL bit then the command is recorded without being evaluated. .SH KEYWORDS command, event, execute, history, interpreter, record tcl7.4b4/doc/RegExp.3010044400630510000012000000114540576547321300150660ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1994 The Regents of the University of California. '\" Copyright (c) 1994 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) RegExp.3 1.6 95/06/07 21:03:23 '\" .so man.macros .TH Tcl_RegExpMatch 3 7.4 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_RegExpMatch, Tcl_RegExpCompile, Tcl_RegExpExec, Tcl_RegExpRange \- Pattern matching with regular expressions .SH SYNOPSIS .nf \fB#include \fR .sp int \fBTcl_RegExpMatch\fR(\fIinterp\fR, \fIstring\fR, \fIpattern\fR) .sp .VS Tcl_RegExp \fBTcl_RegExpCompile\fR(\fIinterp\fR, \fIpattern\fR) .sp int \fBTcl_RegExpExec\fR(\fIinterp\fR, \fIregexp\fR, \fIstring\fR, \fIstart\fR) .sp \fBTcl_RegExpRange\fR(\fIregexp\fR, \fIindex\fR, \fIstartPtr\fR, \fIendPtr\fR) .VE .SH ARGUMENTS .AS Tcl_Interp *interp .AP Tcl_Interp *interp in Tcl interpreter to use for error reporting. .AP char *string in String to check for a match with a regular expression. .AP char *pattern in String in the form of a regular expression pattern. .AP Tcl_RegExp regexp in .VS Compiled regular expression. Must have been returned previously by \fBTcl_RegExpCompile\fR. .AP char *start in If \fIstring\fR is just a portion of some other string, this argument identifies the beginning of the larger string. If it isn't the same as \fIstring\fR, then no \fB^\fR matches will be allowed. .AP int index in Specifies which range is desired: 0 means the range of the entire match, 1 or greater means the range that matched a parenthesized sub-expression. .AP char **startPtr out The address of the first character in the range is stored here, or NULL if there is no such range. .AP char **endPtr out The address of the character just after the last one in the range is stored here, or NULL if there is no such range. .VE .BE .SH DESCRIPTION .PP \fBTcl_RegExpMatch\fR determines whether its \fIpattern\fR argument matches \fIregexp\fR, where \fIregexp\fR is interpreted as a regular expression using the same rules as for the \fBregexp\fR Tcl command. If there is a match then \fBTcl_RegExpMatch\fR returns 1. If there is no match then \fBTcl_RegExpMatch\fR returns 0. If an error occurs in the matching process (e.g. \fIpattern\fR is not a valid regular expression) then \fBTcl_RegExpMatch\fR returns \-1 and leaves an error message in \fIinterp->result\fR. .PP .VS \fBTcl_RegExpCompile\fR, \fBTcl_RegExpExec\fR, and \fBTcl_RegExpRange\fR provide lower-level access to the regular expression pattern matcher. \fBTcl_RegExpCompile\fR compiles a regular expression string into the internal form used for efficient pattern matching. The return value is a token for this compiled form, which can be used in subsequent calls to \fBTcl_RegExpExec\fR or \fBTcl_RegExpRange\fR. If an error occurs while compiling the regular expression then \fBTcl_RegExpCompile\fR returns NULL and leaves an error message in \fIinterp->result\fR. .PP \fBTcl_RegExpExec\fR executes the regular expression pattern matcher. It returns 1 if \fIstring\fR contains a range of characters that match \fIregexp\fR, 0 if no match is found, and \-1 if an error occurs. In the case of an error, \fBTcl_RegExpExec\fR leaves an error message in \fIinterp->result\fR. When searching a string for multiple matches of a pattern, it is important to distinguish between the start of the original string and the start of the current search. For example, when searching for the second occurrence of a match, the \fIstring\fR argument might point to the character just after the first match; however, it is important for the pattern matcher to know that this is not the start of the entire string, so that it doesn't allow \fB^\fR atoms in the pattern to match. The \fIstart\fR argument provides this information by pointing to the start of the overall string containing \fIstring\fR. \fIStart\fR will be less than or equal to \fIstring\fR; if it is less than \fIstring\fR then no \fB^\fR matches will be allowed. .PP \fBTcl_RegExpRange\fR may be invoked after \fBTcl_RegExpExec\fR returns; it provides detailed information about what ranges of the string matched what parts of the pattern. \fBTcl_RegExpRange\fR returns a pair of pointers in \fI*startPtr\fR and \fI*endPtr\fR that identify a range of characters in the source string for the most recent call to \fBTcl_RegExpExec\fR. \fIIndex\fR indicates which of several ranges is desired: if \fIindex\fR is 0, information is returned about the overall range of characters that matched the entire pattern; otherwise, information is returned about the range of characters that matched the \fIindex\fR'th parenthesized subexpression within the pattern. If there is no range corresponding to \fIindex\fR then NULL is stored in \fI*firstPtr\fR and \fI*lastPtr\fR. .VE .SH KEYWORDS match, pattern, regular expression, string, subexpression tcl7.4b4/doc/SetRecLmt.3010044400630510000012000000027110575277301100155250ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1989-1993 The Regents of the University of California. '\" Copyright (c) 1994 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) SetRecLmt.3 1.3 95/05/06 15:18:18 '\" .so man.macros .TH Tcl_SetRecursionLimit 3 7.0 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_SetRecursionLimit \- set maximum allowable nesting depth in interpreter .SH SYNOPSIS .nf \fB#include \fR .sp int \fBTcl_SetRecursionLimit\fR(\fIinterp, depth\fR) .SH ARGUMENTS .AS Tcl_Interp *interp .AP Tcl_Interp *interp in Interpreter whose recursion limit is to be set. Must be greater than zero. .AP int depth in New limit for nested calls to \fBTcl_Eval\fR for \fIinterp\fR. .BE .SH DESCRIPTION .PP At any given time Tcl enforces a limit on the number of recursive calls that may be active for \fBTcl_Eval\fR and related procedures such as \fBTcl_GlobalEval\fR. Any call to \fBTcl_Eval\fR that exceeds this depth is aborted with an error. By default the recursion limit is 1000. .PP \fBTcl_SetRecursionLimit\fR may be used to change the maximum allowable nesting depth for an interpreter. The \fIdepth\fR argument specifies a new limit for \fIinterp\fR, and \fBTcl_SetRecursionLimit\fR returns the old limit. To read out the old limit without modifying it, invoke \fBTcl_SetRecursionDepth\fR with \fIdepth\fR equal to 0. .SH KEYWORDS nesting depth, recursion tcl7.4b4/doc/SetResult.3010044400630510000012000000136060575277301100156220ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1989-1993 The Regents of the University of California. '\" Copyright (c) 1994 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) SetResult.3 1.14 95/05/06 15:18:19 '\" .so man.macros .TH Tcl_SetResult 3 7.0 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_SetResult, Tcl_AppendResult, Tcl_AppendElement, Tcl_ResetResult \- manipulate Tcl result string .SH SYNOPSIS .nf \fB#include \fR .sp \fBTcl_SetResult\fR(\fIinterp, string, freeProc\fR) .sp \fBTcl_AppendResult(\fIinterp, string, string, ... , \fB(char *) NULL\fR) .sp .VS \fBTcl_AppendElement\fR(\fIinterp, string\fR) .VE .sp \fBTcl_ResetResult\fR(\fIinterp\fR) .sp \fBTcl_FreeResult\fR(\fIinterp\fR) .SH ARGUMENTS .AS Tcl_FreeProc freeProc .AP Tcl_Interp *interp out Interpreter whose result is to be modified. .AP char *string in String value to become result for \fIinterp\fR or to be appended to existing result. .AP Tcl_FreeProc freeProc in Address of procedure to call to release storage at \fIstring\fR, or \fBTCL_STATIC\fR, \fBTCL_DYNAMIC\fR, or \fBTCL_VOLATILE\fR. .BE .SH DESCRIPTION .PP The procedures described here are utilities for setting the result/error string in a Tcl interpreter. .PP \fBTcl_SetResult\fR arranges for \fIstring\fR to be the return string for the current Tcl command in \fIinterp\fR, replacing any existing result. If \fIfreeProc\fR is \fBTCL_STATIC\fR it means that \fIstring\fR refers to an area of static storage that is guaranteed not to be modified until at least the next call to \fBTcl_Eval\fR. If \fIfreeProc\fR is \fBTCL_DYNAMIC\fR it means that \fIstring\fR was allocated with a call to \fBmalloc()\fR and is now the property of the Tcl system. \fBTcl_SetResult\fR will arrange for the string's storage to be released by calling \fBfree()\fR when it is no longer needed. If \fIfreeProc\fR is \fBTCL_VOLATILE\fR it means that \fIstring\fR points to an area of memory that is likely to be overwritten when \fBTcl_SetResult\fR returns (e.g. it points to something in a stack frame). In this case \fBTcl_SetResult\fR will make a copy of the string in dynamically allocated storage and arrange for the copy to be the return string for the current Tcl command. .PP If \fIfreeProc\fR isn't one of the values \fBTCL_STATIC\fR, \fBTCL_DYNAMIC\fR, and \fBTCL_VOLATILE\fR, then it is the address of a procedure that Tcl should call to free the string. This allows applications to use non-standard storage allocators. When Tcl no longer needs the storage for the string, it will call \fIfreeProc\fR. \fIFreeProc\fR should have arguments and result that match the type \fBTcl_FreeProc\fR: .nf .RS typedef void Tcl_FreeProc(char *\fIblockPtr\fR); .RE .fi When \fIfreeProc\fR is called, its \fIblockPtr\fR will be set to the value of \fIstring\fR passed to \fBTcl_SetResult\fR. .PP If \fIstring\fR is \fBNULL\fR, then \fIfreeProc\fR is ignored and \fBTcl_SetResult\fR re-initializes \fIinterp\fR's result to point to the pre-allocated result area, with an empty string in the result area. .PP If \fBTcl_SetResult\fR is called at a time when \fIinterp\fR holds a result, \fBTcl_SetResult\fR does whatever is necessary to dispose of the old result (see the \fBTcl_Interp\fR manual entry for details on this). .PP \fBTcl_AppendResult\fR makes it easy to build up Tcl results in pieces. It takes each of its \fIstring\fR arguments and appends them in order to the current result associated with \fIinterp\fR. If the result is in its initialized empty state (e.g. a command procedure was just invoked or \fBTcl_ResetResult\fR was just called), then \fBTcl_AppendResult\fR sets the result to the concatenation of its \fIstring\fR arguments. \fBTcl_AppendResult\fR may be called repeatedly as additional pieces of the result are produced. \fBTcl_AppendResult\fR takes care of all the storage management issues associated with managing \fIinterp\fR's result, such as allocating a larger result area if necessary. Any number of \fIstring\fR arguments may be passed in a single call; the last argument in the list must be a NULL pointer. .PP \fBTcl_AppendElement\fR is similar to \fBTcl_AppendResult\fR in that it allows results to be built up in pieces. However, \fBTcl_AppendElement\fR takes only a single \fIstring\fR argument and it appends that argument to the current result as a proper Tcl list element. \fBTcl_AppendElement\fR adds backslashes or braces if necessary to ensure that \fIinterp\fR's result can be parsed as a list and that \fIstring\fR will be extracted as a single element. Under normal conditions, \fBTcl_AppendElement\fR will add a space character to \fIinterp\fR's result just before adding the new list element, so that the list elements in the result are properly separated. .VS However if the new list element is the first in a list or sub-list (i.e. \fIinterp\fR's current result is empty, or consists of the single character ``{'', or ends in the characters `` {'') then no space is added. .VE .PP \fBTcl_ResetResult\fR clears the result for \fIinterp\fR, freeing the memory associated with it if the current result was dynamically allocated. It leaves the result in its normal initialized state with \fIinterp->result\fR pointing to a static buffer containing \fBTCL_RESULT_SIZE\fR characters, of which the first character is zero. \fBTcl_ResetResult\fR also clears the error state managed by \fBTcl_AddErrorInfo\fR and \fBTcl_SetErrorCode\fR. .PP \fBTcl_FreeResult\fR is a macro that performs part of the work of \fBTcl_ResetResult\fR. It frees up the memory associated with \fIinterp\fR's result and sets \fIinterp->freeProc\fR to zero, but it doesn't change \fIinterp->result\fR or clear error state. \fBTcl_FreeResult\fR is most commonly used when a procedure is about to replace one result value with another. .SH "SEE ALSO" Tcl_AddErrorInfo, Tcl_SetErrorCode, Tcl_Interp .SH KEYWORDS append, command, element, list, result, return value, interpreter fR, then \fIfreeProc\fR is ignored and \fBTcl_SetResult\fR re-initializes \fIinterp\fR's result to point to the pre-allocatcl7.4b4/doc/SetVar.3010044400630510000012000000134720575277301100150750ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1989-1993 The Regents of the University of California. '\" Copyright (c) 1994 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) SetVar.3 1.19 95/05/06 15:18:19 '\" .so man.macros .TH Tcl_SetVar 3 7.4 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_SetVar, Tcl_SetVar2, Tcl_GetVar, Tcl_GetVar2, Tcl_UnsetVar, Tcl_UnsetVar2 \- manipulate Tcl variables .SH SYNOPSIS .nf \fB#include \fR .sp char * \fBTcl_SetVar\fR(\fIinterp, varName, newValue, flags\fR) .sp char * \fBTcl_SetVar2\fR(\fIinterp, name1, name2, newValue, flags\fR) .sp char * \fBTcl_GetVar\fR(\fIinterp, varName, flags\fR) .sp char * \fBTcl_GetVar2\fR(\fIinterp, name1, name2, flags\fR) .sp int \fBTcl_UnsetVar\fR(\fIinterp, varName, flags\fR) .sp int \fBTcl_UnsetVar2\fR(\fIinterp, name1, name2, flags\fR) .SH ARGUMENTS .AS Tcl_Interp *newValue .AP Tcl_Interp *interp in Interpreter containing variable. .AP char *varName in Name of variable. May refer to a scalar variable or an element of an array variable. .VS If the name references an element of an array, then it must be in writable memory: Tcl will make temporary modifications to it while looking up the name. .VE .AP char *newValue in New value for variable. .AP int flags in OR-ed combination of bits providing additional information for operation. See below for valid values. .AP char *name1 in Name of scalar variable, or name of array variable if \fIname2\fR is non-NULL. .AP char *name2 in If non-NULL, gives name of element within array and \fIname1\fR must refer to an array variable. .BE .SH DESCRIPTION .PP These procedures may be used to create, modify, read, and delete Tcl variables from C code. \fBTcl_SetVar\fR and \fBTcl_SetVar2\fR will create a new variable or modify an existing one. Both of these procedures set the given variable to the value given by \fInewValue\fR, and they return a pointer to a copy of the variable's new value, which is stored in Tcl's variable structure. Tcl keeps a private copy of the variable's value, so the caller may change \fInewValue\fR after these procedures return without affecting the value of the variable. If an error occurs in setting the variable (e.g. an array variable is referenced without giving an index into the array), then NULL is returned. .PP The name of the variable may be specified in either of two ways. If \fBTcl_SetVar\fR is called, the variable name is given as a single string, \fIvarName\fR. If \fIvarName\fR contains an open parenthesis and ends with a close parenthesis, then the value between the parentheses is treated as an index (which can have any string value) and the characters before the first open parenthesis are treated as the name of an array variable. If \fIvarName\fR doesn't have parentheses as described above, then the entire string is treated as the name of a scalar variable. If \fBTcl_SetVar2\fR is called, then the array name and index have been separated by the caller into two separate strings, \fIname1\fR and \fIname2\fR respectively; if \fIname2\fR is zero it means that a scalar variable is being referenced. .PP The \fIflags\fR argument may be used to specify any of several options to the procedures. It consists of an OR-ed combination of any of the following bits: .IP TCL_GLOBAL_ONLY Under normal circumstances the procedures look up variables at the current level of procedure call for \fIinterp\fR, or at global level if there is no call active. However, if this bit is set in \fIflags\fR then the variable is looked up at global level even if there is a procedure call active. .IP TCL_LEAVE_ERR_MSG If an error is returned and this bit is set in \fIflags\fR, then an error message will be left in \fI\%interp->result\fR. If this flag bit isn't set then no error message is left (\fI\%interp->result\fR will not be modified). .IP TCL_APPEND_VALUE If this bit is set then \fInewValue\fR is appended to the current value, instead of replacing it. If the variable is currently undefined, then this bit is ignored. .IP TCL_LIST_ELEMENT If this bit is set, then \fInewValue\fR is converted to a valid Tcl list element before setting (or appending to) the variable. A separator space is appended before the new list element unless .VS the list element is going to be the first element in a list or sublist (i.e. the variable's current value is empty, or contains the single character ``{'', or ends in `` }''). .VE .PP \fBTcl_GetVar\fR and \fBTcl_GetVar2\fR return the current value of a variable. The arguments to these procedures are treated in the same way as the arguments to \fBTcl_SetVar\fR and \fBTcl_SetVar2\fR. Under normal circumstances, the return value is a pointer to the variable's value (which is stored in Tcl's variable structure and will not change before the next call to \fBTcl_SetVar\fR or \fBTcl_SetVar2\fR). The only bits of \fIflags\fR that are used are TCL_GLOBAL_ONLY and TCL_LEAVE_ERR_MSG, both of which have the same meaning as for \fBTcl_SetVar\fR. If an error occurs in reading the variable (e.g. the variable doesn't exist or an array element is specified for a scalar variable), then NULL is returned. .PP \fBTcl_UnsetVar\fR and \fBTcl_UnsetVar2\fR may be used to remove a variable, so that future calls to \fBTcl_GetVar\fR or \fBTcl_GetVar2\fR for the variable will return an error. The arguments to these procedures are treated in the same way as the arguments to \fBTcl_GetVar\fR and \fBTcl_GetVar2\fR. .VS If the variable is successfully removed then TCL_OK is returned. If the variable cannot be removed because it doesn't exist then TCL_ERROR is returned. .VE If an array element is specified, the given element is removed but the array remains. If an array name is specified without an index, then the entire array is removed. .SH "SEE ALSO" Tcl_TraceVar .SH KEYWORDS array, interpreter, scalar, set, unset, variable tcl7.4b4/doc/SplitList.3010044400630510000012000000146260575277301100156220ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1989-1993 The Regents of the University of California. '\" Copyright (c) 1994 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) SplitList.3 1.16 95/05/06 15:18:20 '\" .so man.macros .TH Tcl_SplitList 3 7.4 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_SplitList, Tcl_Merge, Tcl_ScanElement, Tcl_ConvertElement \- manipulate Tcl lists .SH SYNOPSIS .nf \fB#include \fR .sp int \fBTcl_SplitList\fR(\fIinterp, list, argcPtr, argvPtr\fR) .sp char * \fBTcl_Merge\fR(\fIargc, argv\fR) .sp int \fBTcl_ScanElement\fR(\fIsrc, flagsPtr\fR) .sp int \fBTcl_ConvertElement\fR(\fIsrc, dst, flags\fR) .SH ARGUMENTS .AS Tcl_Interp ***argvPtr .AP Tcl_Interp *interp out .VS Interpreter to use for error reporting. If NULL, then no error message is left. .VE .AP char *list in Pointer to a string with proper list structure. .AP int *argcPtr out Filled in with number of elements in \fIlist\fR. .AP char ***argvPtr out \fI*argvPtr\fR will be filled in with the address of an array of pointers to the strings that are the extracted elements of \fIlist\fR. There will be \fI*argcPtr\fR valid entries in the array, followed by a NULL entry. .AP int argc in Number of elements in \fIargv\fR. .AP char **argv in Array of strings to merge together into a single list. Each string will become a separate element of the list. .AP char *src in String that is to become an element of a list. .AP int *flagsPtr in Pointer to word to fill in with information about \fIsrc\fR. The value of *\fIflagsPtr\fR must be passed to \fBTcl_ConvertElement\fR. .AP char *dst in Place to copy converted list element. Must contain enough characters to hold converted string. .AP int flags in Information about \fIsrc\fR. Must be value returned by previous call to \fBTcl_ScanElement\fR, possibly OR-ed with \fBTCL_DONT_USE_BRACES\fR. .BE .SH DESCRIPTION .PP These procedures may be used to disassemble and reassemble Tcl lists. \fBTcl_SplitList\fR breaks a list up into its constituent elements, returning an array of pointers to the elements using \fIargcPtr\fR and \fIargvPtr\fR. While extracting the arguments, \fBTcl_SplitList\fR obeys the usual rules for backslash substitutions and braces. The area of memory pointed to by \fI*argvPtr\fR is dynamically allocated; in addition to the array of pointers, it also holds copies of all the list elements. It is the caller's responsibility to free up all of this storage. For example, suppose that you have called \fBTcl_SplitList\fR with the following code: .DS \fCint argc, code; char *string; char **argv; \&... code = Tcl_SplitList(interp, string, &argc, &argv);\fR .DE Then you should eventually free the storage with a call like the following: .DS \fCfree((char *) argv);\fR .DE .PP \fBTcl_SplitList\fR normally returns \fBTCL_OK\fR, which means the list was successfully parsed. If there was a syntax error in \fIlist\fR, then \fBTCL_ERROR\fR is returned and \fIinterp->result\fR will point to an error message describing the .VS problem (if \fIinterp\fR was not NULL). .VE If \fBTCL_ERROR\fR is returned then no memory is allocated and \fI*argvPtr\fR is not modified. .PP \fBTcl_Merge\fR is the inverse of \fBTcl_SplitList\fR: it takes a collection of strings given by \fIargc\fR and \fIargv\fR and generates a result string that has proper list structure. This means that commands like \fBindex\fR may be used to extract the original elements again. In addition, if the result of \fBTcl_Merge\fR is passed to \fBTcl_Eval\fR, it will be parsed into \fIargc\fR words whose values will be the same as the \fIargv\fR strings passed to \fBTcl_Merge\fR. \fBTcl_Merge\fR will modify the list elements with braces and/or backslashes in order to produce proper Tcl list structure. The result string is dynamically allocated using \fBmalloc()\fR; the caller must eventually release the space using \fBfree()\fR. .PP If the result of \fBTcl_Merge\fR is passed to \fBTcl_SplitList\fR, the elements returned by \fBTcl_SplitList\fR will be identical to those passed into \fBTcl_Merge\fR. However, the converse is not true: if \fBTcl_SplitList\fR is passed a given string, and the resulting \fIargc\fR and \fIargv\fR are passed to \fBTcl_Merge\fR, the resulting string may not be the same as the original string passed to \fBTcl_SplitList\fR. This is because \fBTcl_Merge\fR may use backslashes and braces differently than the original string. .PP \fBTcl_ScanElement\fR and \fBTcl_ConvertElement\fR are the procedures that do all of the real work of \fBTcl_Merge\fR. \fBTcl_ScanElement\fR scans its \fIsrc\fR argument and determines how to use backslashes and braces when converting it to a list element. It returns an overestimate of the number of characters required to represent \fIsrc\fR as a list element, and it stores information in \fI*flagsPtr\fR that is needed by \fBTcl_ConvertElement\fR. .PP \fBTcl_ConvertElement\fR is a companion procedure to \fBTcl_ScanElement\fR. It does the actual work of converting a string to a list element. Its \fIflags\fR argument must be the same as the value returned by \fBTcl_ScanElement\fR. \fBTcl_ConvertElement\fR writes a proper list element to memory starting at *\fIdst\fR and returns a count of the total number of characters written, which will be no more than the result returned by \fBTcl_ScanElement\fR. \fBTcl_ConvertElement\fR writes out only the actual list element without any leading or trailing spaces: it is up to the caller to include spaces between adjacent list elements. .PP \fBTcl_ConvertElement\fR uses one of two different approaches to handle the special characters in \fIsrc\fR. Wherever possible, it handles special characters by surrounding the string with braces. This produces clean-looking output, but can't be used in some situations, such as when \fIsrc\fR contains unmatched braces. In these situations, \fBTcl_ConvertElement\fR handles special characters by generating backslash sequences for them. The caller may insist on the second approach by OR-ing the flag value returned by \fBTcl_ScanElement\fR with \fBTCL_DONT_USE_BRACES\fR. Although this will produce an uglier result, it is useful in some special situations, such as when \fBTcl_ConvertElement\fR is being used to generate a portion of an argument for a Tcl command. In this case, surrounding \fIsrc\fR with curly braces would cause the command not to be parsed correctly. .SH KEYWORDS backslash, convert, element, list, merge, split, strings tcl7.4b4/doc/StrMatch.3010044400630510000012000000022030575277301100154040ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1989-1993 The Regents of the University of California. '\" Copyright (c) 1994 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) StrMatch.3 1.9 95/05/06 15:18:21 '\" .so man.macros .TH Tcl_StringMatch 3 "" Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_StringMatch \- test whether a string matches a pattern .SH SYNOPSIS .nf \fB#include \fR .sp int \fBTcl_StringMatch\fR(\fIstring\fR, \fIpattern\fR) .SH ARGUMENTS .AP char *string in String to test. .AP char *pattern in Pattern to match against string. May contain special characters from the set *?\e[]. .BE .SH DESCRIPTION .PP This utility procedure determines whether a string matches a given pattern. If it does, then \fBTcl_StringMatch\fR returns 1. Otherwise \fBTcl_StringMatch\fR returns 0. The algorithm used for matching is the same algorithm used in the ``string match'' Tcl command and is similar to the algorithm used by the C-shell for file name matching; see the Tcl manual entry for details. .SH KEYWORDS match, pattern, string tcl7.4b4/doc/Tcl_Main.3010044400630510000012000000042370576564010400153560ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1994 The Regents of the University of California. '\" Copyright (c) 1994-1995 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) Main.3 1.5 95/06/08 11:24:04 '\" .so man.macros .TH Tcl_Main 3 7.4 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_Main \- main program for Tcl-based applications .SH SYNOPSIS .nf \fB#include \fR .sp \fBTcl_Main\fR(\fIargc, argv, appInitProc\fR) .SH ARGUMENTS .AS Tcl_AppInitProc *appInitProc .AP int argc in Number of elements in \fIargv\fR. .AP char *argv[] in Array of strings containing command-line arguments. .AP Tcl_AppInitProc *appInitProc in Address of an application-specific initialization procedure. The value for this argument is usually \fBTcl_AppInit\fR. .BE .SH DESCRIPTION .PP \fBTcl_Main\fR acts as the main program for most Tcl-based applications. Starting with Tcl 7.4 it is not called \fBmain\fR anymore because it is part of the Tcl library and having a function \fBmain\fR in a library (particularly a shared library) causes problems on many systems. Having \fBmain\fR in the Tcl library would also make it hard to use Tcl in C++ programs, since C++ programs must have special C++ \fBmain\fR functions. .PP Normally each application contains a small \fBmain\fR function that does nothing but invoke \fBTcl_Main\fR. \fBTcl_Main\fR then does all the work of creating and running a \fBtclsh\fR-like application. .PP When it is has finished its own initialization, but before it processes commands, \fBTcl_Main\fR calls the procedure given by the \fIappInitProc\fR argument. This procedure provides a ``hook'' for the application to perform its own initialization, such as defining application-specific commands. The procedure must have an interface that matches the type \fBTcl_AppInitProc\fR: .nf .RS typedef int Tcl_AppInitProc(Tcl_Interp *\fIinterp\fR); .RE .fi \fIAppInitProc\fR is almost always a pointer to \fBTcl_AppInit\fR; for more details on this procedure, see the documentation for \fBTcl_AppInit\fR. .SH KEYWORDS application-specific initialization, command-line arguments, main program tcl7.4b4/doc/TildeSubst.3010044400630510000012000000054420576537252600157630ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1989-1993 The Regents of the University of California. '\" Copyright (c) 1994-1995 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) TildeSubst.3 1.15 95/06/07 11:52:02 '\" .so man.macros .TH Tcl_TildeSubst 3 7.0 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_TildeSubst \- replace tilde with home directory in a file name .SH SYNOPSIS .nf \fB#include \fR .sp char * .VS \fBTcl_TildeSubst\fR(\fIinterp\fR, \fIname\fR, \fIbufferPtr\fR) .VE .SH ARGUMENTS .AS Tcl_DString *bufferPtr .AP Tcl_Interp *interp in Interpreter in which to report an error, if any. .AP char *name in File name, which may start with a ``~''. .AP Tcl_DString *bufferPtr .VS If needed, this dynamic string is used to store the new file name. At the time of the call it should be uninitialized or empty. The caller must eventually call \fBTcl_DStringFree\fR to free up anything stored here. .VE .BE .SH DESCRIPTION .PP This utility procedure does tilde substitution. If \fIname\fR doesn't start with a ``~'' character, then the procedure returns \fIname\fR. If \fIname\fR does start with a tilde, then \fBTcl_TildeSubst\fR returns a new string identical to \fIname\fR except that the first element of \fIname\fR is replaced with the location of the home directory for the given user. The substitution is carried out in the same way that it would be done by \fIcsh\fR. If the tilde is followed immediately by a slash, then the \fB$HOME\fR environment variable is substituted. Otherwise the characters between the tilde and the next slash are taken as a user name, which is looked up in the password file; the user's home directory is retrieved from the password file and substituted. .PP If .VS \fBTcl_TildeSubst\fR has to do tilde substitution then it uses the dynamic string at \fI*bufferPtr\fR to hold the new string it generates. After \fBTcl_TildeSubst\fR returns a non-NULL result, the caller must eventually invoke \fBTcl_DStringFree\fR to free up any information placed in \fI*bufferPtr\fR. The caller need not know whether or not \fBTcl_TildeSubst\fR actually used the string; \fBTcl_TildeSubst\fR initializes \fI*bufferPtr\fR even if it doesn't use it, so the call to \fBTcl_DStringFree\fR will be safe in either case. .VE .PP If an error occurs (e.g. because there was no user by the given name) then NULL is returned and an error message will be left at \fIinterp->result\fR. .VS When an error occurs, \fBTcl_TildeSubst\fR frees the dynamic string itself so that the caller need not call \fBTcl_DStringFree\fR. .VE .PP The caller is responsible for making sure that \fIinterp->result\fR has its default empty value when \fBTcl_TildeSubst\fR is invoked. .SH KEYWORDS file name, home directory, tilde, user tcl7.4b4/doc/TraceVar.3010044400630510000012000000335650576762647500154260ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1989-1993 The Regents of the University of California. '\" Copyright (c) 1994-1995 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) TraceVar.3 1.21 95/06/14 11:40:59 '\" .so man.macros .TH Tcl_TraceVar 3 7.4 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_TraceVar, Tcl_TraceVar2, Tcl_UntraceVar, Tcl_UntraceVar2, Tcl_VarTraceInfo, Tcl_VarTraceInfo2 \- monitor accesses to a variable .SH SYNOPSIS .nf \fB#include \fR .sp int \fBTcl_TraceVar(\fIinterp, varName, flags, proc, clientData\fB)\fR .sp int \fBTcl_TraceVar2(\fIinterp, name1, name2, flags, proc, clientData\fB)\fR .sp \fBTcl_UntraceVar(\fIinterp, varName, flags, proc, clientData\fB)\fR .sp \fBTcl_UntraceVar2(\fIinterp, name1, name2, flags, proc, clientData\fB)\fR .sp ClientData \fBTcl_VarTraceInfo(\fIinterp, varName, flags, proc, prevClientData\fB)\fR .sp ClientData \fBTcl_VarTraceInfo2(\fIinterp, name1, name2, flags, proc, prevClientData\fB)\fR .SH ARGUMENTS .AS Tcl_VarTraceProc prevClientData .AP Tcl_Interp *interp in Interpreter containing variable. .AP char *varName in Name of variable. May refer to a scalar variable, to an array variable with no index, or to an array variable with a parenthesized index. .VS If the name references an element of an array, then it must be in writable memory: Tcl will make temporary modifications to it while looking up the name. .VE .AP int flags in OR-ed combination of the values TCL_TRACE_READS, TCL_TRACE_WRITES, and TCL_TRACE_UNSETS, and TCL_GLOBAL_ONLY. Not all flags are used by all procedures. See below for more information. .AP Tcl_VarTraceProc *proc in Procedure to invoke whenever one of the traced operations occurs. .AP ClientData clientData in Arbitrary one-word value to pass to \fIproc\fR. .AP char *name1 in Name of scalar or array variable (without array index). .AP char *name2 in For a trace on an element of an array, gives the index of the element. For traces on scalar variables or on whole arrays, is NULL. .AP ClientData prevClientData in If non-NULL, gives last value returned by \fBTcl_VarTraceInfo\fR or \fBTcl_VarTraceInfo2\fR, so this call will return information about next trace. If NULL, this call will return information about first trace. .BE .SH DESCRIPTION .PP \fBTcl_TraceVar\fR allows a C procedure to monitor and control access to a Tcl variable, so that the C procedure is invoked whenever the variable is read or written or unset. If the trace is created successfully then \fBTcl_TraceVar\fR returns TCL_OK. If an error occurred (e.g. \fIvarName\fR specifies an element of an array, but the actual variable isn't an array) then TCL_ERROR is returned and an error message is left in \fIinterp->result\fR. .PP The \fIflags\fR argument to \fBTcl_TraceVar\fR indicates when the trace procedure is to be invoked and provides information for setting up the trace. It consists of an OR-ed combination of any of the following values: .TP \fBTCL_GLOBAL_ONLY\fR Normally, the variable will be looked up at the current level of procedure call; if this bit is set then the variable will be looked up at global level, ignoring any active procedures. .TP \fBTCL_TRACE_READS\fR Invoke \fIproc\fR whenever an attempt is made to read the variable. .TP \fBTCL_TRACE_WRITES\fR Invoke \fIproc\fR whenever an attempt is made to modify the variable. .TP \fBTCL_TRACE_UNSETS\fR Invoke \fIproc\fR whenever the variable is unset. A variable may be unset either explicitly by an \fBunset\fR command, or implicitly when a procedure returns (its local variables are automatically unset) or when the interpreter is deleted (all variables are automatically unset). .PP Whenever one of the specified operations occurs on the variable, \fIproc\fR will be invoked. It should have arguments and result that match the type \fBTcl_VarTraceProc\fR: .nf .RS typedef char *Tcl_VarTraceProc( .RS ClientData \fIclientData\fR, Tcl_Interp *\fIinterp\fR, char *\fIname1\fR, char *\fIname2\fR, int \fIflags\fR); .RE .RE .fi The \fIclientData\fP and \fIinterp\fP parameters will have the same values as those passed to \fBTcl_TraceVar\fR when the trace was created. \fIClientData\fR typically points to an application-specific data structure that describes what to do when \fIproc\fR is invoked. \fIName1\fR and \fIname2\fR give the name of the traced variable in the normal two-part form (see the description of \fBTcl_TraceVar2\fR below for details). \fIFlags\fR is an OR-ed combination of bits providing several pieces of information. One of the bits TCL_TRACE_READS, TCL_TRACE_WRITES, or TCL_TRACE_UNSETS will be set in \fIflags\fR to indicate which operation is being performed on the variable. The bit TCL_GLOBAL_ONLY will be set whenever the variable being accessed is a global one not accessible from the current level of procedure call: the trace procedure will need to pass this flag back to variable-related procedures like \fBTcl_GetVar\fR if it attempts to access the variable. The bit TCL_TRACE_DESTROYED will be set in \fIflags\fR if the trace is about to be destroyed; this information may be useful to \fIproc\fR so that it can clean up its own internal data structures (see the section TCL_TRACE_DESTROYED below for more details). Lastly, the bit TCL_INTERP_DESTROYED will be set if the entire interpreter is being destroyed. When this bit is set, \fIproc\fR must be especially careful in the things it does (see the section TCL_INTERP_DESTROYED below). The trace procedure's return value should normally be NULL; see ERROR RETURNS below for information on other possibilities. .PP \fBTcl_UntraceVar\fR may be used to remove a trace. If the variable specified by \fIinterp\fR, \fIvarName\fR, and \fIflags\fR has a trace set with \fIflags\fR, \fIproc\fR, and \fIclientData\fR, then the corresponding trace is removed. If no such trace exists, then the call to \fBTcl_UntraceVar\fR has no effect. The same bits are valid for \fIflags\fR as for calls to \fBTcl_TraceVar\fR. .PP \fBTcl_VarTraceInfo\fR may be used to retrieve information about traces set on a given variable. The return value from \fBTcl_VarTraceInfo\fR is the \fIclientData\fR associated with a particular trace. The trace must be on the variable specified by the \fIinterp\fR, \fIvarName\fR, and \fIflags\fR arguments (only the TCL_GLOBAL_ONLY bit from \fIflags\fR is used; other bits are ignored) and its trace procedure must the same as the \fIproc\fR argument. If the \fIprevClientData\fR argument is NULL then the return value corresponds to the first (most recently created) matching trace, or NULL if there are no matching traces. If the \fIprevClientData\fR argument isn't NULL, then it should be the return value from a previous call to \fBTcl_VarTraceInfo\fR. In this case, the new return value will correspond to the next matching trace after the one whose \fIclientData\fR matches \fIprevClientData\fR, or NULL if no trace matches \fIprevClientData\fR or if there are no more matching traces after it. This mechanism makes it possible to step through all of the traces for a given variable that have the same \fIproc\fR. .SH "TWO-PART NAMES" .PP The procedures \fBTcl_TraceVar2\fR, \fBTcl_UntraceVar2\fR, and \fBTcl_VarTraceInfo2\fR are identical to \fBTcl_TraceVar\fR, \fBTcl_UntraceVar\fR, and \fBTcl_VarTraceInfo\fR, respectively, except that the name of the variable has already been separated by the caller into two parts. \fIName1\fR gives the name of a scalar variable or array, and \fIname2\fR gives the name of an element within an array. If \fIname2\fR is NULL it means that either the variable is a scalar or the trace is to be set on the entire array rather than an individual element (see WHOLE-ARRAY TRACES below for more information). .SH "ACCESSING VARIABLES DURING TRACES" .PP During read and write traces, the trace procedure can read, write, or unset the traced variable using \fBTcl_GetVar2\fR, \fBTcl_SetVar2\fR, and other procedures. While \fIproc\fR is executing, traces are temporarily disabled for the variable, so that calls to \fBTcl_GetVar2\fR and \fBTcl_SetVar2\fR will not cause \fIproc\fR or other trace procedures to be invoked again. Disabling only occurs for the variable whose trace procedure is active; accesses to other variables will still be traced. .VS However, if a variable is unset during a read or write trace then unset traces will be invoked. .VE .PP During unset traces the variable has already been completely expunged. It is possible for the trace procedure to read or write the variable, but this will be a new version of the variable. Traces are not disabled during unset traces as they are for read and write traces, but existing traces have been removed from the variable before any trace procedures are invoked. If new traces are set by unset trace procedures, these traces will be invoked on accesses to the variable by the trace procedures. .SH "CALLBACK TIMING" .PP When read tracing has been specified for a variable, the trace procedure will be invoked whenever the variable's value is read. This includes \fBset\fR Tcl commands, \fB$\fR-notation in Tcl commands, and invocations of the \fBTcl_GetVar\fR and \fBTcl_GetVar2\fR procedures. \fIProc\fR is invoked just before the variable's value is returned. It may modify the value of the variable to affect what is returned by the traced access. .VS If it unsets the variable then the access will return an error just as if the variable never existed. .VE .PP When write tracing has been specified for a variable, the trace procedure will be invoked whenever the variable's value is modified. This includes \fBset\fR commands, commands that modify variables as side effects (such as \fBcatch\fR and \fBscan\fR), and calls to the \fBTcl_SetVar\fR and \fBTcl_SetVar2\fR procedures). \fIProc\fR will be invoked after the variable's value has been modified, but before the new value of the variable has been returned. It may modify the value of the variable to override the change and to determine the value actually returned by the traced access. .VS If it deletes the variable then the traced access will return an empty string. .VE .PP When unset tracing has been specified, the trace procedure will be invoked whenever the variable is destroyed. The traces will be called after the variable has been completely unset. .SH "WHOLE-ARRAY TRACES" .PP If a call to \fBTcl_TraceVar\fR or \fBTcl_TraceVar2\fR specifies the name of an array variable without an index into the array, then the trace will be set on the array as a whole. This means that \fIproc\fR will be invoked whenever any element of the array is accessed in the ways specified by \fIflags\fR. When an array is unset, a whole-array trace will be invoked just once, with \fIname1\fR equal to the name of the array and \fIname2\fR NULL; it will not be invoked once for each element. .SH "MULTIPLE TRACES" .PP It is possible for multiple traces to exist on the same variable. When this happens, all of the trace procedures will be invoked on each access, in order from most-recently-created to least-recently-created. When there exist whole-array traces for an array as well as traces on individual elements, the whole-array traces are invoked before the individual-element traces. .VS If a read or write trace unsets the variable then all of the unset traces will be invoked but the remainder of the read and write traces will be skipped. .VE .SH "ERROR RETURNS" .PP Under normal conditions trace procedures should return NULL, indicating successful completion. If \fIproc\fR returns a non-NULL value it signifies that an error occurred. The return value must be a pointer to a static character string containing an error message. If a trace procedure returns an error, no further traces are invoked for the access and the traced access aborts with the given message. Trace procedures can use this facility to make variables read-only, for example (but note that the value of the variable will already have been modified before the trace procedure is called, so the trace procedure will have to restore the correct value). .PP The return value from \fIproc\fR is only used during read and write tracing. During unset traces, the return value is ignored and all relevant trace procedures will always be invoked. .SH "RESTRICTIONS" .PP A trace procedure can be called at any time, even when there is a partially-formed result in the interpreter's result area. If the trace procedure does anything that could damage this result (such as calling \fBTcl_Eval\fR) then it must save the original values of the interpreter's \fBresult\fR and \fBfreeProc\fR fields and restore them before it returns. .SH "UNDEFINED VARIABLES" .PP It is legal to set a trace on an undefined variable. The variable will still appear to be undefined until the first time its value is set. If an undefined variable is traced and then unset, the unset will fail with an error (``no such variable''), but the trace procedure will still be invoked. .SH "TCL_TRACE_DESTROYED FLAG" .PP In an unset callback to \fIproc\fR, the TCL_TRACE_DESTROYED bit is set in \fIflags\fR if the trace is being removed as part of the deletion. Traces on a variable are always removed whenever the variable is deleted; the only time TCL_TRACE_DESTROYED isn't set is for a whole-array trace invoked when only a single element of an array is unset. .SH "TCL_INTERP_DESTROYED" .PP When an interpreter is destroyed, unset traces are called for all of its variables. The TCL_INTERP_DESTROYED bit will be set in the \fIflags\fR argument passed to the trace procedures. Trace procedures must be extremely careful in what they do if the TCL_INTERP_DESTROYED bit is set. It is not safe for the procedures to invoke any Tcl procedures on the interpreter, since its state is partially deleted. All that trace procedures should do under these circumstances is to clean up and free their own internal data structures. .SH BUGS .PP Tcl doesn't do any error checking to prevent trace procedures from misusing the interpreter during traces with TCL_INTERP_DESTROYED set. .SH KEYWORDS clientData, trace, variable tcl7.4b4/doc/UpVar.3010044400630510000012000000053770575277301200147340ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1994 The Regents of the University of California. '\" Copyright (c) 1994-1995 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) UpVar.3 1.4 95/05/06 15:18:26 '\" .so man.macros .TH Tcl_UpVar 3 7.4 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_UpVar, Tcl_UpVar2 \- link one variable to another .SH SYNOPSIS .nf \fB#include \fR .sp int \fBTcl_UpVar(\fIinterp, frameName, sourceName, destName, flags\fB)\fR .sp int \fBTcl_UpVar2(\fIinterp, frameName, name1, name2, destName, flags\fB)\fR .SH ARGUMENTS .AS Tcl_VarTraceProc prevClientData .AP Tcl_Interp *interp in Interpreter containing variables; also used for error reporting. .AP char *frameName in Identifies the stack frame containing source variable. May have any of the forms accepted by the \fBupvar\fR command, such as \fB#0\fR or \fB1\fR. .AP char *sourceName in Name of source variable, in the frame given by \fIframeName\fR. May refer to a scalar variable or to an array variable with a parenthesized index. .AP char *destName in Name of destination variable, which is to be linked to source variable so that references to \fIdestName\fR refer to the other variable. Must not currently exist except as an upvar-ed variable. .AP int flags in Either TCL_GLOBAL_ONLY or 0; if non-zero, then \fIdestName\fR is a global variable; otherwise it is a local to the current procedure (or global if no procedure is active). .AP char *name1 in First part of source variable's name (scalar name, or name of array without array index). .AP char *name2 in If source variable is an element of an array, gives the index of the element. For scalar source variables, is NULL. .BE .SH DESCRIPTION .PP \fBTcl_UpVar\fR and \fBTcl_UpVar2\fR provide the same functionality as the \fBupvar\fR command: they make a link from a source variable to a destination variable, so that references to the destination are passed transparently through to the source. The name of the source variable may be specified either as a single string such as \fBxyx\fR or \fBa(24)\fR (by calling \fBTcl_UpVar\fR) or in two parts where the array name has been separated from the element name (by calling \fBTcl_UpVar2\fR). The destination variable name is specified in a single string; it may not be an array element. .PP Both procedures return either TCL_OK or TCL_ERROR, and they leave an error message in \fIinterp->result\fR if an error occurs. .PP As with the \fBupvar\fR command, the source variable need not exist; if it does exist, unsetting it later does not destroy the link. The destination variable may exist at the time of the call, but if so it must exist as a linked variable. .SH KEYWORDS linked variable, upvar, variable tcl7.4b4/doc/append.n010044400630510000012000000017250575277301200152320ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) append.n 1.4 95/05/06 15:18:27 '\" .so man.macros .TH append n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME append \- Append to variable .SH SYNOPSIS \fBappend \fIvarName \fR?\fIvalue value value ...\fR? .BE .SH DESCRIPTION .PP Append all of the \fIvalue\fR arguments to the current value of variable \fIvarName\fR. If \fIvarName\fR doesn't exist, it is given a value equal to the concatenation of all the \fIvalue\fR arguments. This command provides an efficient way to build up long variables incrementally. For example, ``\fBappend a $b\fR'' is much more efficient than ``\fBset a $a$b\fR'' if \fB$a\fR is long. .SH KEYWORDS append, variable tcl7.4b4/doc/array.n010044400630510000012000000113220575277301200150730ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1993-1994 The Regents of the University of California. '\" Copyright (c) 1994-1995 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) array.n 1.5 95/05/06 15:18:27 '\" .so man.macros .TH array n 7.4 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME array \- Manipulate array variables .SH SYNOPSIS \fBarray \fIoption arrayName\fR ?\fIarg arg ...\fR? .BE .SH DESCRIPTION .PP This command performs one of several operations on the variable given by \fIarrayName\fR. Unless otherwise specified for individual commands below, \fIarrayName\fR must be the name of an existing array variable. The \fIoption\fR argument determines what action is carried out by the command. The legal \fIoptions\fR (which may be abbreviated) are: .TP \fBarray anymore \fIarrayName searchId\fR Returns 1 if there are any more elements left to be processed in an array search, 0 if all elements have already been returned. \fISearchId\fR indicates which search on \fIarrayName\fR to check, and must have been the return value from a previous invocation of \fBarray startsearch\fR. This option is particularly useful if an array has an element with an empty name, since the return value from \fBarray nextelement\fR won't indicate whether the search has been completed. .TP \fBarray donesearch \fIarrayName searchId\fR This command terminates an array search and destroys all the state associated with that search. \fISearchId\fR indicates which search on \fIarrayName\fR to destroy, and must have been the return value from a previous invocation of \fBarray startsearch\fR. Returns an empty string. .TP \fBarray exists \fIarrayName\fR .VS Returns 1 if \fIarrayName\fR is an array variable, 0 if there is no variable by that name or if it is a scalar variable. .VE .TP \fBarray get \fIarrayName\fR ?\fIpattern\fR? .VS Returns a list containing pairs of elements. The first element in each pair is the name of an element in \fIarrayName\fR and the second element of each pair is the value of the array element. The order of the pairs is undefined. .VS If \fIpattern\fR is not specified, then all of the elements of the array are included in the result. If \fIpattern\fR is specified, then only those elements whose names match \fIpattern\fR (using the glob-style matching rules of \fBstring match\fR) are included. .VE If \fIarrayName\fR isn't the name of an array variable, or if the array contains no elements, then an empty list is returned. .VE .TP \fBarray names \fIarrayName\fR ?\fIpattern\fR? Returns a list containing the names of all of the elements in .VS the array that match \fIpattern\fR (using the glob-style matching rules of \fBstring match\fR). If \fIpattern\fR is omitted then the command returns all of the element names in the array. If there are no (matching) elements in the array, or if \fIarrayName\fR isn't the name of an array variable, then an empty string is returned. .VE .TP \fBarray nextelement \fIarrayName searchId\fR Returns the name of the next element in \fIarrayName\fR, or an empty string if all elements of \fIarrayName\fR have already been returned in this search. The \fIsearchId\fR argument identifies the search, and must have been the return value of an \fBarray startsearch\fR command. Warning: if elements are added to or deleted from the array, then all searches are automatically terminated just as if \fBarray donesearch\fR had been invoked; this will cause \fBarray nextelement\fR operations to fail for those searches. .TP \fBarray set \fIarrayName list\fR .VS Sets the values of one or more elements in \fIarrayName\fR. \fIlist\fR must have a form like that returned by \fBarray get\fR, consisting of an even number of elements. Each odd-numbered element in \fIlist\fR is treated as an element name within \fIarrayName\fR, and the following element in \fIlist\fR is used as a new value for that array element. .VE .TP \fBarray size \fIarrayName\fR Returns a decimal string giving the number of elements in the array. .VS If \fIarrayName\fR isn't the name of an array then 0 is returned. .VE .TP \fBarray startsearch \fIarrayName\fR This command initializes an element-by-element search through the array given by \fIarrayName\fR, such that invocations of the \fBarray nextelement\fR command will return the names of the individual elements in the array. When the search has been completed, the \fBarray donesearch\fR command should be invoked. The return value is a search identifier that must be used in \fBarray nextelement\fR and \fBarray donesearch\fR commands; it allows multiple searches to be underway simultaneously for the same array. .SH KEYWORDS array, element names, search tcl7.4b4/doc/break.n010044400630510000012000000020540575277301200150430ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1993-1994 The Regents of the University of California. '\" Copyright (c) 1994 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) break.n 1.4 95/05/06 15:18:28 '\" .so man.macros .TH break n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME break \- Abort looping command .SH SYNOPSIS \fBbreak\fR .BE .SH DESCRIPTION .PP This command is typically invoked inside the body of a looping command such as \fBfor\fR or \fBforeach\fR or \fBwhile\fR. It returns a TCL_BREAK code, which causes a break exception to occur. The exception causes the current script to be aborted out to the the innermost containing loop command, which then aborts its execution and returns normally. Break exceptions are also handled in a few other situations, such as the \fBcatch\fR command, Tk event bindings, and the outermost scripts of procedure bodies. .SH KEYWORDS abort, break, loop tcl7.4b4/doc/case.n010044400630510000012000000050120575277301300146700ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) case.n 1.5 95/05/06 15:18:29 '\" .so man.macros .TH case n 7.0 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME case \- Evaluate one of several scripts, depending on a given value .SH SYNOPSIS \fBcase\fI string \fR?\fBin\fR? \fIpatList body \fR?\fIpatList body \fR...? .br \fBcase\fI string \fR?\fBin\fR? {\fIpatList body \fR?\fIpatList body \fR...?} .BE .SH DESCRIPTION .PP \fINote: the \fBcase\fI command is obsolete and is supported only for backward compatibility. At some point in the future it may be removed entirely. You should use the \fBswitch\fI command instead.\fR .PP The \fBcase\fR command matches \fIstring\fR against each of the \fIpatList\fR arguments in order. Each \fIpatList\fR argument is a list of one or more patterns. If any of these patterns matches \fIstring\fR then \fBcase\fR evaluates the following \fIbody\fR argument by passing it recursively to the Tcl interpreter and returns the result of that evaluation. Each \fIpatList\fR argument consists of a single pattern or list of patterns. Each pattern may contain any of the wild-cards described under \fBstring match\fR. If a \fIpatList\fR argument is \fBdefault\fR, the corresponding body will be evaluated if no \fIpatList\fR matches \fIstring\fR. If no \fIpatList\fR argument matches \fIstring\fR and no default is given, then the \fBcase\fR command returns an empty string. .PP Two syntaxes are provided for the \fIpatList\fR and \fIbody\fR arguments. The first uses a separate argument for each of the patterns and commands; this form is convenient if substitutions are desired on some of the patterns or commands. The second form places all of the patterns and commands together into a single argument; the argument must have proper list structure, with the elements of the list being the patterns and commands. The second form makes it easy to construct multi-line case commands, since the braces around the whole list make it unnecessary to include a backslash at the end of each line. Since the \fIpatList\fR arguments are in braces in the second form, no command or variable substitutions are performed on them; this makes the behavior of the second form different than the first form in some cases. .SH KEYWORDS case, match, regular expression tcl7.4b4/doc/catch.n010044400630510000012000000030060575277301300150400ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1993-1994 The Regents of the University of California. '\" Copyright (c) 1994 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) catch.n 1.4 95/05/06 15:18:30 '\" .so man.macros .TH catch n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME catch \- Evaluate script and trap exceptional returns .SH SYNOPSIS \fBcatch\fI script \fR?\fIvarName\fR? .BE .SH DESCRIPTION .PP The \fBcatch\fR command may be used to prevent errors from aborting command interpretation. \fBCatch\fR calls the Tcl interpreter recursively to execute \fIscript\fR, and always returns a TCL_OK code, regardless of any errors that might occur while executing \fIscript\fR. The return value from \fBcatch\fR is a decimal string giving the code returned by the Tcl interpreter after executing \fIscript\fR. This will be \fB0\fR (TCL_OK) if there were no errors in \fIscript\fR; otherwise it will have a non-zero value corresponding to one of the exceptional return codes (see tcl.h for the definitions of code values). If the \fIvarName\fR argument is given, then it gives the name of a variable; \fBcatch\fR will set the variable to the string returned from \fIscript\fR (either a result or an error message). .PP Note that \fBcatch\fR catches all exceptions, including those generated by \fBbreak\fR and \fBcontinue\fR as well as errors. .SH KEYWORDS catch, error tcl7.4b4/doc/cd.n010044400630510000012000000015210575277301300143440ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) cd.n 1.3 95/05/06 15:18:31 '\" .so man.macros .TH cd n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME cd \- Change working directory .SH SYNOPSIS \fBcd \fR?\fIdirName\fR? .BE .SH DESCRIPTION .PP Change the current working directory to \fIdirName\fR, or to the home directory (as specified in the HOME environment variable) if \fIdirName\fR is not given. If \fIdirName\fR starts with a tilde, then tilde-expansion is done as described for \fBTcl_TildeSubst\fR. Returns an empty string. .SH KEYWORDS working directory tcl7.4b4/doc/close.n010044400630510000012000000017610575277301300150710ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) close.n 1.3 95/05/06 15:18:31 '\" .so man.macros .TH close n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME close \- Close an open file .SH SYNOPSIS \fBclose \fIfileId\fR .BE .SH DESCRIPTION .PP Closes the file given by \fIfileId\fR. \fIFileId\fR must be the return value from a previous invocation of the \fBopen\fR command; after this command, it should not be used anymore. If \fIfileId\fR refers to a command pipeline instead of a file, then \fBclose\fR waits for the children to complete. The normal result of this command is an empty string, but errors are returned if there are problems in closing the file or waiting for children to complete. .SH KEYWORDS close, file tcl7.4b4/doc/concat.n010044400630510000012000000020150575277301300152240ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) concat.n 1.4 95/05/06 15:18:32 '\" .so man.macros .TH concat n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME concat \- Join lists together .SH SYNOPSIS .VS \fBconcat\fI \fR?\fIarg arg ...\fR? .VE .BE .SH DESCRIPTION .PP This command treats each argument as a list and concatenates them into a single list. It also eliminates leading and trailing spaces in the \fIarg\fR's and adds a single separator space between \fIarg\fR's. It permits any number of arguments. For example, the command .DS \fBconcat a b {c d e} {f {g h}}\fR .DE will return .DS \fBa b c d e f {g h}\fR .DE as its result. .PP .VS If no \fIarg\fRs are supplied, the result is an empty string. .VE .SH KEYWORDS concatenate, join, lists tcl7.4b4/doc/continue.n010044400630510000012000000021040575277301300156000ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1993-1994 The Regents of the University of California. '\" Copyright (c) 1994 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) continue.n 1.4 95/05/06 15:18:33 '\" .so man.macros .TH continue n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME continue \- Skip to the next iteration of a loop .SH SYNOPSIS \fBcontinue\fR .BE .SH DESCRIPTION .PP This command is typically invoked inside the body of a looping command such as \fBfor\fR or \fBforeach\fR or \fBwhile\fR. It returns a TCL_CONTINUE code, which causes a continue exception to occur. The exception causes the current script to be aborted out to the the innermost containing loop command, which then continues with the next iteration of the loop. Catch exceptions are also handled in a few other situations, such as the \fBcatch\fR command and the outermost scripts of procedure bodies. .SH KEYWORDS continue, iteration, loop tcl7.4b4/doc/eof.n010044400630510000012000000015010575277301300145250ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) eof.n 1.3 95/05/06 15:18:34 '\" .so man.macros .TH eof n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME eof \- Check for end-of-file condition on open file .SH SYNOPSIS \fBeof \fIfileId\fR .BE .SH DESCRIPTION .PP Returns 1 if an end-of-file condition has occurred on \fIfileId\fR, 0 otherwise. \fIFileId\fR must have been the return value from a previous call to \fBopen\fR, or it may be \fBstdin\fR, \fBstdout\fR, or \fBstderr\fR to refer to one of the standard I/O channels. .SH KEYWORDS end, file tcl7.4b4/doc/error.n010044400630510000012000000042200575277301300151060ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) error.n 1.4 95/05/06 15:18:35 '\" .so man.macros .TH error n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME error \- Generate an error .SH SYNOPSIS \fBerror \fImessage\fR ?\fIinfo\fR? ?\fIcode\fR? .BE .SH DESCRIPTION .PP Returns a TCL_ERROR code, which causes command interpretation to be unwound. \fIMessage\fR is a string that is returned to the application to indicate what went wrong. .PP If the \fIinfo\fR argument is provided and is non-empty, it is used to initialize the global variable \fBerrorInfo\fR. \fBerrorInfo\fR is used to accumulate a stack trace of what was in progress when an error occurred; as nested commands unwind, the Tcl interpreter adds information to \fBerrorInfo\fR. If the \fIinfo\fR argument is present, it is used to initialize \fBerrorInfo\fR and the first increment of unwind information will not be added by the Tcl interpreter. In other words, the command containing the \fBerror\fR command will not appear in \fBerrorInfo\fR; in its place will be \fIinfo\fR. This feature is most useful in conjunction with the \fBcatch\fR command: if a caught error cannot be handled successfully, \fIinfo\fR can be used to return a stack trace reflecting the original point of occurrence of the error: .DS \fBcatch {...} errMsg set savedInfo $errorInfo \&... error $errMsg $savedInfo\fR .DE .PP If the \fIcode\fR argument is present, then its value is stored in the \fBerrorCode\fR global variable. This variable is intended to hold a machine-readable description of the error in cases where such information is available; see the \fBtclvars\fR manual page for information on the proper format for the variable. If the \fIcode\fR argument is not present, then \fBerrorCode\fR is automatically reset to ``NONE'' by the Tcl interpreter as part of processing the error generated by the command. .SH KEYWORDS error, errorCode, errorInfo tcl7.4b4/doc/eval.n010044400630510000012000000016350575277301400147140ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) eval.n 1.3 95/05/06 15:18:36 '\" .so man.macros .TH eval n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME eval \- Evaluate a Tcl script .SH SYNOPSIS \fBeval \fIarg \fR?\fIarg ...\fR? .BE .SH DESCRIPTION .PP \fBEval\fR takes one or more arguments, which together comprise a Tcl script containing one or more commands. \fBEval\fR concatenates all its arguments in the same fashion as the \fBconcat\fR command, passes the concatenated string to the Tcl interpreter recursively, and returns the result of that evaluation (or any error generated by it). .SH KEYWORDS concatenate, evaluate, script tcl7.4b4/doc/exec.n010044400630510000012000000152170576215603300147070ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) exec.n 1.9 95/05/28 13:24:44 '\" .so man.macros .TH exec n 7.0 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME exec \- Invoke subprocess(es) .SH SYNOPSIS \fBexec \fR?\fIswitches\fR? \fIarg \fR?\fIarg ...\fR? .BE .SH DESCRIPTION .PP This command treats its arguments as the specification of one or more subprocesses to execute. The arguments take the form of a standard shell pipeline where each \fIarg\fR becomes one word of a command, and each distinct command becomes a subprocess. .PP If the initial arguments to \fBexec\fR start with \fB\-\fR then .VS they are treated as command-line switches and are not part of the pipeline specification. The following switches are currently supported: .TP 13 \fB\-keepnewline\fR Retains a trailing newline in the pipeline's output. Normally a trailing newline will be deleted. .TP 13 \fB\-\|\-\fR Marks the end of switches. The argument following this one will be treated as the first \fIarg\fR even if it starts with a \fB\-\fR\fR. .VE .PP If an \fIarg\fR (or pair of \fIarg\fR's) has one of the forms described below then it is used by \fBexec\fR to control the flow of input and output among the subprocess(es). Such arguments will not be passed to the subprocess(es). In forms .VS such as ``< \fIfileName\fR'' \fIfileName\fR may either be in a separate argument from ``<'' or in the same argument with no intervening space (i.e. ``<\fIfileName\fR''). .VE .TP 15 | Separates distinct commands in the pipeline. The standard output of the preceding command will be piped into the standard input of the next command. .TP 15 | Separates distinct commands in the pipeline. Both standard output and standard error of the preceding command will be piped into the standard input of the next command. This form of redirection overrides forms such as 2> and >&. .TP 15 <\0\fIfileName\fR The file named by \fIfileName\fR is opened and used as the standard input for the first command in the pipeline. .TP 15 <@\0\fIfileId\fR .VS \fIFileId\fR must be the identifier for an open file, such as the return value from a previous call to \fBopen\fR. It is used as the standard input for the first command in the pipeline. \fIFileId\fR must have been opened for reading. .VE .TP 15 <<\0\fIvalue\fR \fIValue\fR is passed to the first command as its standard input. .TP 15 >\0\fIfileName\fR Standard output from the last command is redirected to the file named \fIfileName\fR, overwriting its previous contents. .TP 15 2>\0\fIfileName\fR .VS Standard error from all commands in the pipeline is redirected to the file named \fIfileName\fR, overwriting its previous contents. .TP 15 >&\0\fIfileName\fR Both standard output from the last command and standard error from all commands are redirected to the file named \fIfileName\fR, overwriting its previous contents. .VE .TP 15 >>\0\fIfileName\fR Standard output from the last command is redirected to the file named \fIfileName\fR, appending to it rather than overwriting it. .TP 15 2>>\0\fIfileName\fR .VS Standard error from all commands in the pipeline is redirected to the file named \fIfileName\fR, appending to it rather than overwriting it. .TP 15 >>&\0\fIfileName\fR Both standard output from the last command and standard error from all commands are redirected to the file named \fIfileName\fR, appending to it rather than overwriting it. .TP 15 >@\0\fIfileId\fR \fIFileId\fR must be the identifier for an open file, such as the return value from a previous call to \fBopen\fR. Standard output from the last command is redirected to \fIfileId\fR's file, which must have been opened for writing. .TP 15 2>@\0\fIfileId\fR \fIFileId\fR must be the identifier for an open file, such as the return value from a previous call to \fBopen\fR. Standard error from all commands in the pipeline is redirected to \fIfileId\fR's file. The file must have been opened for writing. .TP 15 >&@\0\fIfileId\fR \fIFileId\fR must be the identifier for an open file, such as the return value from a previous call to \fBopen\fR. Both standard output from the last command and standard error from all commands are redirected to \fIfileId\fR's file. The file must have been opened for writing. .VE .PP If standard output has not been redirected then the \fBexec\fR command returns the standard output from the last command in the pipeline. If any of the commands in the pipeline exit abnormally or are killed or suspended, then \fBexec\fR will return an error and the error message will include the pipeline's output followed by error messages describing the abnormal terminations; the \fBerrorCode\fR variable will contain additional information about the last abnormal termination encountered. If any of the commands writes to its standard error file and that standard error isn't redirected, then \fBexec\fR will return an error; the error message will include the pipeline's standard output, followed by messages about abnormal terminations (if any), followed by the standard error output. .PP If the last character of the result or error message is a newline then that character is normally deleted from the result or error message. This is consistent with other Tcl return values, which don't normally end with newlines. .VS However, if \fB\-keepnewline\fR is specified then the trailing newline is retained. .VE .PP If standard input isn't redirected with ``<'' or ``<<'' or ``<@'' then the standard input for the first command in the pipeline is taken from the application's current standard input. .PP If the last \fIarg\fR is ``&'' then the pipeline will be executed in background. .VS In this case the \fBexec\fR command will return a list whose elements are the process identifiers for all of the subprocesses in the pipeline. .VE The standard output from the last command in the pipeline will go to the application's standard output if it hasn't been redirected, and error output from all of the commands in the pipeline will go to the application's standard error file unless redirected. .PP The first word in each command is taken as the command name; tilde-substitution is performed on it, and if the result contains no slashes then the directories in the PATH environment variable are searched for an executable by the given name. If the name contains a slash then it must refer to an executable reachable from the current directory. No ``glob'' expansion or other shell-like substitutions are performed on the arguments to commands. .SH KEYWORDS execute, pipeline, redirection, subprocess tcl7.4b4/doc/exit.n010044400630510000012000000013000575277301400147230ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) exit.n 1.4 95/05/06 15:18:38 '\" .so man.macros .TH exit n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME exit \- End the application .SH SYNOPSIS \fBexit \fR?\fIreturnCode\fR? .BE .SH DESCRIPTION .PP Terminate the process, returning \fIreturnCode\fR to the system as the exit status. If \fIreturnCode\fR isn't specified then it defaults to 0. .SH KEYWORDS exit, process tcl7.4b4/doc/expr.n010044400630510000012000000251330576215603300147370ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1995 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) expr.n 1.12 95/05/28 13:24:45 '\" .so man.macros .TH expr n 7.4 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME expr \- Evaluate an expression .SH SYNOPSIS \fBexpr \fIarg \fR?\fIarg arg ...\fR? .BE .SH DESCRIPTION .PP .VS Concatenates \fIarg\fR's (adding separator spaces between them), evaluates the result as a Tcl expression, and returns the value. .VE The operators permitted in Tcl expressions are a subset of the operators permitted in C expressions, and they have the same meaning and precedence as the corresponding C operators. Expressions almost always yield numeric results (integer or floating-point values). For example, the expression .DS \fBexpr 8.2 + 6\fR .DE evaluates to 14.2. Tcl expressions differ from C expressions in the way that operands are specified. Also, Tcl expressions support non-numeric operands and string comparisons. .SH OPERANDS .PP A Tcl expression consists of a combination of operands, operators, and parentheses. White space may be used between the operands and operators and parentheses; it is ignored by the expression processor. Where possible, operands are interpreted as integer values. Integer values may be specified in decimal (the normal case), in octal (if the first character of the operand is \fB0\fR), or in hexadecimal (if the first two characters of the operand are \fB0x\fR). If an operand does not have one of the integer formats given above, then it is treated as a floating-point number if that is possible. Floating-point numbers may be specified in any of the ways accepted by an ANSI-compliant C compiler (except that the ``f'', ``F'', ``l'', and ``L'' suffixes will not be permitted in most installations). For example, all of the following are valid floating-point numbers: 2.1, 3., 6e4, 7.91e+16. If no numeric interpretation is possible, then an operand is left as a string (and only a limited set of operators may be applied to it). .PP Operands may be specified in any of the following ways: .IP [1] As an numeric value, either integer or floating-point. .IP [2] As a Tcl variable, using standard \fB$\fR notation. The variable's value will be used as the operand. .IP [3] As a string enclosed in double-quotes. The expression parser will perform backslash, variable, and command substitutions on the information between the quotes, and use the resulting value as the operand .IP [4] As a string enclosed in braces. The characters between the open brace and matching close brace will be used as the operand without any substitutions. .IP [5] As a Tcl command enclosed in brackets. The command will be executed and its result will be used as the operand. .IP [6] .VS As a mathematical function whose arguments have any of the above forms for operands, such as ``\fBsin($x)\fR''. See below for a list of defined functions. .VE .LP Where substitutions occur above (e.g. inside quoted strings), they are performed by the expression processor. However, an additional layer of substitution may already have been performed by the command parser before the expression processor was called. As discussed below, it is usually best to enclose expressions in braces to prevent the command parser from performing substitutions on the contents. .PP For some examples of simple expressions, suppose the variable \fBa\fR has the value 3 and the variable \fBb\fR has the value 6. Then the command on the left side of each of the lines below will produce the value on the right side of the line: .DS .ta 6c \fBexpr 3.1 + $a 6.1 expr 2 + "$a.$b" 5.6 expr 4*[llength "6 2"] 8 expr {{word one} < "word $a"} 0\fR .DE .SH OPERATORS .PP The valid operators are listed below, grouped in decreasing order of precedence: .TP 20 \fB\-\0\0+\0\0~\0\0!\fR .VS Unary minus, unary plus, bit-wise NOT, logical NOT. None of these operands .VE may be applied to string operands, and bit-wise NOT may be applied only to integers. .TP 20 \fB*\0\0/\0\0%\fR Multiply, divide, remainder. None of these operands may be applied to string operands, and remainder may be applied only to integers. .VS The remainder will always have the same sign as the divisor and an absolute value smaller than the divisor. .VE .TP 20 \fB+\0\0\-\fR Add and subtract. Valid for any numeric operands. .TP 20 \fB<<\0\0>>\fR Left and right shift. Valid for integer operands only. .TP 20 \fB<\0\0>\0\0<=\0\0>=\fR Boolean less, greater, less than or equal, and greater than or equal. Each operator produces 1 if the condition is true, 0 otherwise. These operators may be applied to strings as well as numeric operands, in which case string comparison is used. .TP 20 \fB==\0\0!=\fR Boolean equal and not equal. Each operator produces a zero/one result. Valid for all operand types. .TP 20 \fB&\fR Bit-wise AND. Valid for integer operands only. .TP 20 \fB^\fR Bit-wise exclusive OR. Valid for integer operands only. .TP 20 \fB|\fR Bit-wise OR. Valid for integer operands only. .TP 20 \fB&&\fR Logical AND. Produces a 1 result if both operands are non-zero, 0 otherwise. Valid for numeric operands only (integers or floating-point). .TP 20 \fB||\fR Logical OR. Produces a 0 result if both operands are zero, 1 otherwise. Valid for numeric operands only (integers or floating-point). .TP 20 \fIx\fB?\fIy\fB:\fIz\fR If-then-else, as in C. If \fIx\fR evaluates to non-zero, then the result is the value of \fIy\fR. Otherwise the result is the value of \fIz\fR. The \fIx\fR operand must have a numeric value. .LP See the C manual for more details on the results produced by each operator. All of the binary operators group left-to-right within the same precedence level. For example, the command .DS \fBexpr 4*2 < 7\fR .DE returns 0. .PP The \fB&&\fP, \fB||\fP, and \fB?:\fP operators have ``lazy evaluation'', just as in C, which means that operands are not evaluated if they are not needed to determine the outcome. For example, in the command .DS \fBexpr {$v ? [a] : [b]}\fR .DE only one of \fB[a]\fR or \fB[b]\fR will actually be evaluated, depending on the value of \fB$v\fP. Note, however, that this is only true if the entire expression is enclosed in braces; otherwise the Tcl parser will evaluate both \fB[a]\fR and \fB[b]\fR before invoking the \fBexpr\fR command. .SH "MATH FUNCTIONS" .PP .VS Tcl supports the following mathematical functions in expressions: .DS .ta 3c 6c 9c \fBacos\fR \fBcos\fR \fBhypot\fR \fBsinh\fR \fBasin\fR \fBcosh\fR \fBlog\fR \fBsqrt\fR \fBatan\fR \fBexp\fR \fBlog10\fR \fBtan\fR \fBatan2\fR \fBfloor\fR \fBpow\fR \fBtanh\fR \fBceil\fR \fBfmod\fR \fBsin\fR .DE Each of these functions invokes the math library function of the same name; see the manual entries for the library functions for details on what they do. Tcl also implements the following functions for conversion between integers and floating-point numbers: .TP \fBabs(\fIarg\fB)\fR Returns the absolute value of \fIarg\fR. \fIArg\fR may be either integer or floating-point, and the result is returned in the same form. .TP \fBdouble(\fIarg\fB)\fR If \fIarg\fR is a floating value, returns \fIarg\fR, otherwise converts \fIarg\fR to floating and returns the converted value. .TP \fBint(\fIarg\fB)\fR If \fIarg\fR is an integer value, returns \fIarg\fR, otherwise converts \fIarg\fR to integer by truncation and returns the converted value. .TP \fBround(\fIarg\fB)\fR If \fIarg\fR is an integer value, returns \fIarg\fR, otherwise converts \fIarg\fR to integer by rounding and returns the converted value. .PP In addition to these predefined functions, applications may define additional functions using \fBTcl_CreateMathFunc\fR(). .VE .SH "TYPES, OVERFLOW, AND PRECISION" .PP All internal computations involving integers are done with the C type \fIlong\fP, and all internal computations involving floating-point are done with the C type \fIdouble\fP. When converting a string to floating-point, exponent overflow is detected and results in a Tcl error. For conversion to integer from string, detection of overflow depends on the behavior of some routines in the local C library, so it should be regarded as unreliable. In any case, integer overflow and underflow are generally not detected reliably for intermediate results. Floating-point overflow and underflow are detected to the degree supported by the hardware, which is generally pretty reliable. .PP Conversion among internal representations for integer, floating-point, and string operands is done automatically as needed. For arithmetic computations, integers are used until some floating-point number is introduced, after which floating-point is used. For example, .DS \fBexpr 5 / 4\fR .DE returns 1, while .DS \fBexpr 5 / 4.0\fR \fBexpr 5 / ( [string length "abcd"] + 0.0 )\fR .DE both return 1.25. .VS Floating-point values are always returned with a ``.'' or an ``e'' so that they will not look like integer values. For example, .DS \fBexpr 20.0/5.0\fR .DE returns ``4.0'', not ``4''. The global variable \fBtcl_precision\fR determines the the number of significant digits that are retained when floating values are converted to strings (except that trailing zeroes are omitted). If \fBtcl_precision\fR is unset then 6 digits of precision are used. To retain all of the significant bits of an IEEE floating-point number set \fBtcl_precision\fR to 17; if a value is converted to string with 17 digits of precision and then converted back to binary for some later calculation, the resulting binary value is guaranteed to be identical to the original one. .VE .SH "STRING OPERATIONS" .PP String values may be used as operands of the comparison operators, although the expression evaluator tries to do comparisons as integer or floating-point when it can. If one of the operands of a comparison is a string and the other has a numeric value, the numeric operand is converted back to a string using the C \fIsprintf\fP format specifier \fB%d\fR for integers and \fB%g\fR for floating-point values. For example, the commands .DS \fBexpr {"0x03" > "2"}\fR \fBexpr {"0y" < "0x12"}\fR .DE both return 1. The first comparison is done using integer comparison, and the second is done using string comparison after the second operand is converted to the string ``18''. .VS Because of Tcl's tendency to treat values as numbers whenever possible, it isn't generally a good idea to use operators like \fB==\fR when you really want string comparison and the values of the operands could be arbitrary; it's better in these cases to use the \fBstring compare\fR command instead. .VE .SH KEYWORDS arithmetic, boolean, compare, expression , Tcl expressions support non-numeric operands and string comparisons. .SH OPERANDS .PP A Tcl expression consists of a combination of operands, operators, and parentheses. White space may be used between the operands and operators and parentheses; it is ignored by the expression processor. Where possible, operands are interpreted as integer values. Integer values may be specified in decimal (the normal case), in octaltcl7.4b4/doc/file.n010044400630510000012000000122220575277301400146760ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) file.n 1.4 95/05/06 15:18:40 '\" .so man.macros .TH file n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME file \- Manipulate file names and attributes .SH SYNOPSIS \fBfile \fIoption\fR \fIname\fR ?\fIarg arg ...\fR? .BE .SH DESCRIPTION .PP This command provides several operations on a file's name or attributes. \fIName\fR is the name of a file; if it starts with a tilde, then tilde substitution is done before executing the command (see the manual entry for \fBTcl_TildeSubst\fR for details). \fIOption\fR indicates what to do with the file name. Any unique abbreviation for \fIoption\fR is acceptable. The valid options are: .TP \fBfile \fBatime \fIname\fR Returns a decimal string giving the time at which file \fIname\fR was last accessed. The time is measured in the standard POSIX fashion as seconds from a fixed starting time (often January 1, 1970). If the file doesn't exist or its access time cannot be queried then an error is generated. .TP \fBfile \fBdirname \fIname\fR Returns all of the characters in \fIname\fR up to but not including the last slash character. If there are no slashes in \fIname\fR then returns ``.''. If the last slash in \fIname\fR is its first character, then return ``/''. .TP \fBfile \fBexecutable \fIname\fR Returns \fB1\fR if file \fIname\fR is executable by the current user, \fB0\fR otherwise. .TP \fBfile \fBexists \fIname\fR Returns \fB1\fR if file \fIname\fR exists and the current user has search privileges for the directories leading to it, \fB0\fR otherwise. .TP \fBfile \fBextension \fIname\fR Returns all of the characters in \fIname\fR after and including the last dot in the last element of \fIname\fR. If there is no dot in the last element of \fIname\fR then returns the empty string. .TP \fBfile \fBisdirectory \fIname\fR Returns \fB1\fR if file \fIname\fR is a directory, \fB0\fR otherwise. .TP \fBfile \fBisfile \fIname\fR Returns \fB1\fR if file \fIname\fR is a regular file, \fB0\fR otherwise. .TP \fBfile lstat \fIname varName\fR Same as \fBstat\fR option (see below) except uses the \fIlstat\fR kernel call instead of \fIstat\fR. This means that if \fIname\fR refers to a symbolic link the information returned in \fIvarName\fR is for the link rather than the file it refers to. On systems that don't support symbolic links this option behaves exactly the same as the \fBstat\fR option. .TP \fBfile \fBmtime \fIname\fR Returns a decimal string giving the time at which file \fIname\fR was last modified. The time is measured in the standard POSIX fashion as seconds from a fixed starting time (often January 1, 1970). If the file doesn't exist or its modified time cannot be queried then an error is generated. .TP \fBfile \fBowned \fIname\fR Returns \fB1\fR if file \fIname\fR is owned by the current user, \fB0\fR otherwise. .TP \fBfile \fBreadable \fIname\fR Returns \fB1\fR if file \fIname\fR is readable by the current user, \fB0\fR otherwise. .TP \fBfile readlink \fIname\fR Returns the value of the symbolic link given by \fIname\fR (i.e. the name of the file it points to). If \fIname\fR isn't a symbolic link or its value cannot be read, then an error is returned. On systems that don't support symbolic links this option is undefined. .TP \fBfile \fBrootname \fIname\fR Returns all of the characters in \fIname\fR up to but not including the last ``.'' character in the name. If \fIname\fR doesn't contain a dot, then returns \fIname\fR. .TP \fBfile \fBsize \fIname\fR Returns a decimal string giving the size of file \fIname\fR in bytes. If the file doesn't exist or its size cannot be queried then an error is generated. .TP \fBfile \fBstat \fIname varName\fR Invokes the \fBstat\fR kernel call on \fIname\fR, and uses the variable given by \fIvarName\fR to hold information returned from the kernel call. \fIVarName\fR is treated as an array variable, and the following elements of that variable are set: \fBatime\fR, \fBctime\fR, \fBdev\fR, \fBgid\fR, \fBino\fR, \fBmode\fR, \fBmtime\fR, \fBnlink\fR, \fBsize\fR, \fBtype\fR, \fBuid\fR. Each element except \fBtype\fR is a decimal string with the value of the corresponding field from the \fBstat\fR return structure; see the manual entry for \fBstat\fR for details on the meanings of the values. The \fBtype\fR element gives the type of the file in the same form returned by the command \fBfile type\fR. This command returns an empty string. .TP \fBfile \fBtail \fIname\fR Returns all of the characters in \fIname\fR after the last slash. If \fIname\fR contains no slashes then returns \fIname\fR. .TP \fBfile \fBtype \fIname\fR Returns a string giving the type of file \fIname\fR, which will be one of \fBfile\fR, \fBdirectory\fR, \fBcharacterSpecial\fR, \fBblockSpecial\fR, \fBfifo\fR, \fBlink\fR, or \fBsocket\fR. .TP \fBfile \fBwritable \fIname\fR Returns \fB1\fR if file \fIname\fR is writable by the current user, \fB0\fR otherwise. .SH KEYWORDS attributes, directory, file, name, stat tcl7.4b4/doc/flush.n010044400630510000012000000016030575277301400151010ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) flush.n 1.3 95/05/06 15:18:41 '\" .so man.macros .TH flush n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME flush \- Flush buffered output for a file .SH SYNOPSIS \fBflush \fIfileId\fR .BE .SH DESCRIPTION .PP Flushes any output that has been buffered for \fIfileId\fR. \fIFileId\fR must have been the return value from a previous call to \fBopen\fR, or it may be \fBstdout\fR or \fBstderr\fR to access one of the standard I/O streams; it must refer to a file that was opened for writing. The command returns an empty string. .SH KEYWORDS buffer, file, flush, output tcl7.4b4/doc/for.n010044400630510000012000000031120575277301400145430ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) for.n 1.3 95/05/06 15:18:41 '\" .so man.macros .TH for n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME for \- ``For'' loop .SH SYNOPSIS \fBfor \fIstart test next body\fR .BE .SH DESCRIPTION .PP \fBFor\fR is a looping command, similar in structure to the C \fBfor\fR statement. The \fIstart\fR, \fInext\fR, and \fIbody\fR arguments must be Tcl command strings, and \fItest\fR is an expression string. The \fBfor\fR command first invokes the Tcl interpreter to execute \fIstart\fR. Then it repeatedly evaluates \fItest\fR as an expression; if the result is non-zero it invokes the Tcl interpreter on \fIbody\fR, then invokes the Tcl interpreter on \fInext\fR, then repeats the loop. The command terminates when \fItest\fR evaluates to 0. If a \fBcontinue\fR command is invoked within \fIbody\fR then any remaining commands in the current execution of \fIbody\fR are skipped; processing continues by invoking the Tcl interpreter on \fInext\fR, then evaluating \fItest\fR, and so on. If a \fBbreak\fR command is invoked within \fIbody\fR or \fInext\fR, then the \fBfor\fR command will return immediately. The operation of \fBbreak\fR and \fBcontinue\fR are similar to the corresponding statements in C. \fBFor\fR returns an empty string. .SH KEYWORDS for, iteration, looping tcl7.4b4/doc/foreach.n010044400630510000012000000022320575277301500153670ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) foreach.n 1.3 95/05/06 15:18:42 '\" .so man.macros .TH foreach n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME foreach \- Iterate over all elements in a list .SH SYNOPSIS \fBforeach \fIvarname list body\fR .BE .SH DESCRIPTION .PP In this command \fIvarname\fR is the name of a variable, \fIlist\fR is a list of values to assign to \fIvarname\fR, and \fIbody\fR is a Tcl script. For each element of \fIlist\fR (in order from left to right), \fBforeach\fR assigns the contents of the field to \fIvarname\fR as if the \fBlindex\fR command had been used to extract the field, then calls the Tcl interpreter to execute \fIbody\fR. The \fBbreak\fR and \fBcontinue\fR statements may be invoked inside \fIbody\fR, with the same effect as in the \fBfor\fR command. \fBForeach\fR returns an empty string. .SH KEYWORDS foreach, iteration, list, looping tcl7.4b4/doc/format.n010044400630510000012000000210230575277301500152470ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1995 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) format.n 1.8 95/05/06 15:18:43 '\" .so man.macros .TH format n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME format \- Format a string in the style of sprintf .SH SYNOPSIS \fBformat \fIformatString \fR?\fIarg arg ...\fR? .BE .SH INTRODUCTION .PP This command generates a formatted string in the same way as the ANSI C \fBsprintf\fR procedure (it uses \fBsprintf\fR in its implementation). \fIFormatString\fR indicates how to format the result, using \fB%\fR conversion specifiers as in \fBsprintf\fR, and the additional arguments, if any, provide values to be substituted into the result. The return value from \fBformat\fR is the formatted string. .SH "DETAILS ON FORMATTING" .PP The command operates by scanning \fIformatString\fR from left to right. Each character from the format string is appended to the result string unless it is a percent sign. If the character is a \fB%\fR then it is not copied to the result string. Instead, the characters following the \fB%\fR character are treated as a conversion specifier. The conversion specifier controls the conversion of the next successive \fIarg\fR to a particular format and the result is appended to the result string in place of the conversion specifier. If there are multiple conversion specifiers in the format string, then each one controls the conversion of one additional \fIarg\fR. The \fBformat\fR command must be given enough \fIarg\fRs to meet the needs of all of the conversion specifiers in \fIformatString\fR. .PP Each conversion specifier may contain up to six different parts: .VS an XPG3 position specifier, .VE a set of flags, a minimum field width, a precision, a length modifier, and a conversion character. Any of these fields may be omitted except for the conversion character. The fields that are present must appear in the order given above. The paragraphs below discuss each of these fields in turn. .PP .VS If the \fB%\fR is followed by a decimal number and a \fB$\fR, as in ``\fB%2$d\fR'', then the value to convert is not taken from the next sequential argument. Instead, it is taken from the argument indicated by the number, where 1 corresponds to the first \fIarg\fR. If the conversion specifier requires multiple arguments because of \fB*\fR characters in the specifier then successive arguments are used, starting with the argument given by the number. This follows the XPG3 conventions for positional specifiers. If there are any positional specifiers in \fIformatString\fR then all of the specifiers must be positional. .VE .PP The second portion of a conversion specifier may contain any of the following flag characters, in any order: .TP 10 \fB\-\fR Specifies that the converted argument should be left-justified in its field (numbers are normally right-justified with leading spaces if needed). .TP 10 \fB+\fR Specifies that a number should always be printed with a sign, even if positive. .TP 10 \fIspace\fR Specifies that a space should be added to the beginning of the number if the first character isn't a sign. .TP 10 \fB0\fR Specifies that the number should be padded on the left with zeroes instead of spaces. .TP 10 \fB#\fR Requests an alternate output form. For \fBo\fR and \fBO\fR conversions it guarantees that the first digit is always \fB0\fR. For \fBx\fR or \fBX\fR conversions, \fB0x\fR or \fB0X\fR (respectively) will be added to the beginning of the result unless it is zero. For all floating-point conversions (\fBe\fR, \fBE\fR, \fBf\fR, \fBg\fR, and \fBG\fR) it guarantees that the result always has a decimal point. For \fBg\fR and \fBG\fR conversions it specifies that trailing zeroes should not be removed. .PP The third portion of a conversion specifier is a number giving a minimum field width for this conversion. It is typically used to make columns line up in tabular printouts. If the converted argument contains fewer characters than the minimum field width then it will be padded so that it is as wide as the minimum field width. Padding normally occurs by adding extra spaces on the left of the converted argument, but the \fB0\fR and \fB\-\fR flags may be used to specify padding with zeroes on the left or with spaces on the right, respectively. If the minimum field width is specified as \fB*\fR rather than a number, then the next argument to the \fBformat\fR command determines the minimum field width; it must be a numeric string. .PP The fourth portion of a conversion specifier is a precision, which consists of a period followed by a number. The number is used in different ways for different conversions. For \fBe\fR, \fBE\fR, and \fBf\fR conversions it specifies the number of digits to appear to the right of the decimal point. For \fBg\fR and \fBG\fR conversions it specifies the total number of digits to appear, including those on both sides of the decimal point (however, trailing zeroes after the decimal point will still be omitted unless the \fB#\fR flag has been specified). For integer conversions, it specifies a minimum number of digits to print (leading zeroes will be added if necessary). For \fBs\fR conversions it specifies the maximum number of characters to be printed; if the string is longer than this then the trailing characters will be dropped. If the precision is specified with \fB*\fR rather than a number then the next argument to the \fBformat\fR command determines the precision; it must be a numeric string. .PP The fifth part of a conversion specifier is a length modifier, which must be \fBh\fR or \fBl\fR. If it is \fBh\fR it specifies that the numeric value should be truncated to a 16-bit value before converting. This option is rarely useful. The \fBl\fR modifier is ignored. .PP The last thing in a conversion specifier is an alphabetic character that determines what kind of conversion to perform. The following conversion characters are currently supported: .TP 10 \fBd\fR Convert integer to signed decimal string. .TP 10 \fBu\fR Convert integer to unsigned decimal string. .TP 10 \fBi\fR Convert integer to signed decimal string; the integer may either be in decimal, in octal (with a leading \fB0\fR) or in hexadecimal (with a leading \fB0x\fR). .TP 10 \fBo\fR Convert integer to unsigned octal string. .TP 10 \fBx\fR or \fBX\fR Convert integer to unsigned hexadecimal string, using digits ``0123456789abcdef'' for \fBx\fR and ``0123456789ABCDEF'' for \fBX\fR). .TP 10 \fBc\fR Convert integer to the 8-bit character it represents. .TP 10 \fBs\fR No conversion; just insert string. .TP 10 \fBf\fR Convert floating-point number to signed decimal string of the form \fIxx.yyy\fR, where the number of \fIy\fR's is determined by the precision (default: 6). If the precision is 0 then no decimal point is output. .TP 10 \fBe\fR or \fBe\fR Convert floating-point number to scientific notation in the form \fIx.yyy\fBe\(+-\fIzz\fR, where the number of \fIy\fR's is determined by the precision (default: 6). If the precision is 0 then no decimal point is output. If the \fBE\fR form is used then \fBE\fR is printed instead of \fBe\fR. .TP 10 \fBg\fR or \fBG\fR If the exponent is less than \-4 or greater than or equal to the precision, then convert floating-point number as for \fB%e\fR or \fB%E\fR. Otherwise convert as for \fB%f\fR. Trailing zeroes and a trailing decimal point are omitted. .TP 10 \fB%\fR No conversion: just insert \fB%\fR. .LP For the numerical conversions the argument being converted must be an integer or floating-point string; format converts the argument to binary and then converts it back to a string according to the conversion specifier. .SH "DIFFERENCES FROM ANSI SPRINTF" .PP .VS The behavior of the format command is the same as the ANSI C \fBsprintf\fR procedure except for the following differences: .IP [1] \fB%p\fR and \fB%n\fR specifiers are not currently supported. .VE .IP [2] For \fB%c\fR conversions the argument must be a decimal string, which will then be converted to the corresponding character value. .IP [3] .VS The \fBl\fR modifier is ignored; integer values are always converted as if there were no modifier present and real values are always converted as if the \fBl\fR modifier were present (i.e. type \fBdouble\fR is used for the internal representation). If the \fBh\fR modifier is specified then integer values are truncated to \fBshort\fR before conversion. .VE .SH KEYWORDS conversion specifier, format, sprintf, string, substitution rs in the specifier then successive arguments are used, starting with the argument given by the number. This follows the XPG3 conventions for positional specifiers. If there are any positional specifiers in \fIformatString\fR then all of the specifiers must be positional. .VE .PP The second portion of a conversion specifier may contain any of the following flag characters, in any order: .TP 10 \fB\-\fR Specifies that the converted argument should be left-justified in its field (numbers atcl7.4b4/doc/gets.n010044400630510000012000000033440575277301500147270ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) gets.n 1.4 95/05/06 15:18:44 '\" .so man.macros .TH gets n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME gets \- Read a line from a file .SH SYNOPSIS \fBgets \fIfileId\fR ?\fIvarName\fR? .BE .SH DESCRIPTION .PP This command reads the next line from the file given by \fIfileId\fR and discards the terminating newline character. If \fIvarName\fR is specified then the line is placed in the variable by that name and the return value is a count of the number of characters read (not including the newline). If the end of the file is reached before reading any characters then \-1 is returned and \fIvarName\fR is set to an empty string. If \fIvarName\fR is not specified then the return value will be the line (minus the newline character) or an empty string if the end of the file is reached before reading any characters. An empty string will also be returned if a line contains no characters except the newline, so \fBeof\fR may have to be used to determine what really happened. If the last character in the file is not a newline character then \fBgets\fR behaves as if there were an additional newline character at the end of the file. \fIFileId\fR must be \fBstdin\fR or the return value from a previous call to \fBopen\fR; it must refer to a file that was opened for reading. .VS Any existing end-of-file or error condition on the file is cleared at the beginning of the \fBgets\fR command. .VE .SH KEYWORDS file, line, read tcl7.4b4/doc/glob.n010044400630510000012000000050070576215603300147020ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) glob.n 1.6 95/05/28 13:24:46 '\" .so man.macros .TH glob n 7.0 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME glob \- Return names of files that match patterns .SH SYNOPSIS \fBglob \fR?\fIswitches\fR? \fIpattern \fR?\fIpattern ...\fR? .BE .SH DESCRIPTION .PP This command performs file name ``globbing'' in a fashion similar to the csh shell. It returns a list of the files whose names match any of the \fIpattern\fR arguments. .LP If the initial arguments to \fBglob\fR start with \fB\-\fR then .VS they are treated as switches. The following switches are currently supported: .TP 15 \fB\-nocomplain\fR Allows an empty list to be returned without error; without this switch an error is returned if the result list would be empty. .TP 15 \fB\-\|\-\fR Marks the end of switches. The argument following this one will be treated as a \fIpattern\fR even if it starts with a \fB\-\fR. .VE .PP The \fIpattern\fR arguments may contain any of the following special characters: .TP 10 \fB?\fR Matches any single character. .TP 10 \fB*\fR Matches any sequence of zero or more characters. .TP 10 \fB[\fIchars\fB]\fR Matches any single character in \fIchars\fR. If \fIchars\fR contains a sequence of the form \fIa\fB\-\fIb\fR then any character between \fIa\fR and \fIb\fR (inclusive) will match. .TP 10 \fB\e\fIx\fR Matches the character \fIx\fR. .TP 10 \fB{\fIa\fB,\fIb\fB,\fI...\fR} Matches any of the strings \fIa\fR, \fIb\fR, etc. .LP As with csh, a ``.'' at the beginning of a file's name or just after a ``/'' must be matched explicitly or with a {} construct. In addition, all ``/'' characters must be matched explicitly. .LP If the first character in a \fIpattern\fR is ``~'' then it refers to the home directory for the user whose name follows the ``~''. If the ``~'' is followed immediately by ``/'' then the value of the HOME environment variable is used. .LP The \fBglob\fR command differs from csh globbing in two ways. First, it does not sort its result list (use the \fBlsort\fR command if you want the list sorted). .VS Second, \fBglob\fR only returns the names of files that actually exist; in csh no check for existence is made unless a pattern contains a ?, *, or [] construct. .VE .SH KEYWORDS exist, file, glob, pattern tcl7.4b4/doc/global.n010044400630510000012000000016730575277301500152300ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) global.n 1.3 95/05/06 15:18:46 '\" .so man.macros .TH global n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME global \- Access global variables .SH SYNOPSIS \fBglobal \fIvarname \fR?\fIvarname ...\fR? .BE .SH DESCRIPTION .PP This command is ignored unless a Tcl procedure is being interpreted. If so then it declares the given \fIvarname\fR's to be global variables rather than local ones. For the duration of the current procedure (and only while executing in the current procedure), any reference to any of the \fIvarname\fRs will refer to the global variable by the same name. .SH KEYWORDS global, procedure, variable obal \- Access global variables .SH SYNOPSIS \fBglobal \fIvarname \fRtcl7.4b4/doc/history.n010044400630510000012000000146260575277301500154730ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) history.n 1.3 95/05/06 15:18:47 '\" .so man.macros .TH history n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME history \- Manipulate the history list .SH SYNOPSIS \fBhistory \fR?\fIoption\fR? ?\fIarg arg ...\fR? .BE .SH DESCRIPTION .PP The \fBhistory\fR command performs one of several operations related to recently-executed commands recorded in a history list. Each of these recorded commands is referred to as an ``event''. When specifying an event to the \fBhistory\fR command, the following forms may be used: .IP [1] A number: if positive, it refers to the event with that number (all events are numbered starting at 1). If the number is negative, it selects an event relative to the current event (\fB\-1\fR refers to the previous event, \fB\-2\fR to the one before that, and so on). .IP [2] A string: selects the most recent event that matches the string. An event is considered to match the string either if the string is the same as the first characters of the event, or if the string matches the event in the sense of the \fBstring match\fR command. .LP The \fBhistory\fR command can take any of the following forms: .TP \fBhistory\fR Same as \fBhistory info\fR, described below. .TP \fBhistory add\fI command \fR?\fBexec\fR? Adds the \fIcommand\fR argument to the history list as a new event. If \fBexec\fR is specified (or abbreviated) then the command is also executed and its result is returned. If \fBexec\fR isn't specified then an empty string is returned as result. .TP \fBhistory change\fI newValue\fR ?\fIevent\fR? Replaces the value recorded for an event with \fInewValue\fR. \fIEvent\fR specifies the event to replace, and defaults to the \fIcurrent\fR event (not event \fB\-1\fR). This command is intended for use in commands that implement new forms of history substitution and wish to replace the current event (which invokes the substitution) with the command created through substitution. The return value is an empty string. .TP \fBhistory event\fR ?\fIevent\fR? Returns the value of the event given by \fIevent\fR. \fIEvent\fR defaults to \fB\-1\fR. This command causes history revision to occur: see below for details. .TP \fBhistory info \fR?\fIcount\fR? Returns a formatted string (intended for humans to read) giving the event number and contents for each of the events in the history list except the current event. If \fIcount\fR is specified then only the most recent \fIcount\fR events are returned. .TP \fBhistory keep \fIcount\fR This command may be used to change the size of the history list to \fIcount\fR events. Initially, 20 events are retained in the history list. This command returns an empty string. .TP \fBhistory nextid\fR Returns the number of the next event to be recorded in the history list. It is useful for things like printing the event number in command-line prompts. .TP \fBhistory redo \fR?\fIevent\fR? Re-executes the command indicated by \fIevent\fR and return its result. \fIEvent\fR defaults to \fB\-1\fR. This command results in history revision: see below for details. .TP \fBhistory substitute \fIold new \fR?\fIevent\fR? Retrieves the command given by \fIevent\fR (\fB\-1\fR by default), replace any occurrences of \fIold\fR by \fInew\fR in the command (only simple character equality is supported; no wild cards), execute the resulting command, and return the result of that execution. This command results in history revision: see below for details. .TP \fBhistory words \fIselector\fR ?\fIevent\fR? Retrieves from the command given by \fIevent\fR (\fB\-1\fR by default) the words given by \fIselector\fR, and return those words in a string separated by spaces. The \fBselector\fR argument has three forms. If it is a single number then it selects the word given by that number (\fB0\fR for the command name, \fB1\fR for its first argument, and so on). If it consists of two numbers separated by a dash, then it selects all the arguments between those two. Otherwise \fBselector\fR is treated as a pattern; all words matching that pattern (in the sense of \fBstring match\fR) are returned. In the numeric forms \fB$\fR may be used to select the last word of a command. For example, suppose the most recent command in the history list is .RS .DS \fBformat {%s is %d years old} Alice [expr $ageInMonths/12]\fR .DE Below are some history commands and the results they would produce: .DS .ta 4c .fi .UL Command " " .UL Result .nf \fBhistory words $ [expr $ageInMonths/12]\fR \fBhistory words 1-2 {%s is %d years old} Alice\fR \fBhistory words *a*o* {%s is %d years old} [expr $ageInMonths/12]\fR .DE \fBHistory words\fR results in history revision: see below for details. .RE .SH "HISTORY REVISION" .PP The history options \fBevent\fR, \fBredo\fR, \fBsubstitute\fR, and \fBwords\fR result in ``history revision''. When one of these options is invoked then the current event is modified to eliminate the history command and replace it with the result of the history command. For example, suppose that the most recent command in the history list is .DS \fBset a [expr $b+2]\fR .DE and suppose that the next command invoked is one of the ones on the left side of the table below. The command actually recorded in the history event will be the corresponding one on the right side of the table. .ne 1.5c .DS .ta 4c .fi .UL "Command Typed" " " .UL "Command Recorded" .nf \fBhistory redo set a [expr $b+2]\fR \fBhistory s a b set b [expr $b+2]\fR \fBset c [history w 2] set c [expr $b+2]\fR .DE History revision is needed because event specifiers like \fB\-1\fR are only valid at a particular time: once more events have been added to the history list a different event specifier would be needed. History revision occurs even when \fBhistory\fR is invoked indirectly from the current event (e.g. a user types a command that invokes a Tcl procedure that invokes \fBhistory\fR): the top-level command whose execution eventually resulted in a \fBhistory\fR command is replaced. If you wish to invoke commands like \fBhistory words\fR without history revision, you can use \fBhistory event\fR to save the current history event and then use \fBhistory change\fR to restore it later. .SH KEYWORDS event, history, record, revision tcl7.4b4/doc/if.n010044400630510000012000000032530576215603300143560ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) if.n 1.4 95/05/28 13:24:47 '\" .so man.macros .TH if n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME if \- Execute scripts conditionally .SH SYNOPSIS \fBif \fIexpr1 \fR?\fBthen\fR? \fIbody1 \fBelseif \fIexpr2 \fR?\fBthen\fR? \fIbody2\fR \fBelseif\fR ... ?\fBelse\fR? ?\fIbodyN\fR? .BE .SH DESCRIPTION .PP The \fIif\fR command evaluates \fIexpr1\fR as an expression (in the same way that \fBexpr\fR evaluates its argument). The value of the expression must be a boolean .VS (a numeric value, where 0 is false and anything is true, or a string value such as \fBtrue\fR or \fByes\fR for true and \fBfalse\fR or \fBno\fR for false); .VE if it is true then \fIbody1\fR is executed by passing it to the Tcl interpreter. Otherwise \fIexpr2\fR is evaluated as an expression and if it is true then \fBbody2\fR is executed, and so on. If none of the expressions evaluates to true then \fIbodyN\fR is executed. The \fBthen\fR and \fBelse\fR arguments are optional ``noise words'' to make the command easier to read. There may be any number of \fBelseif\fR clauses, including zero. \fIBodyN\fR may also be omitted as long as \fBelse\fR is omitted too. The return value from the command is the result of the body script that was executed, or an empty string if none of the expressions was non-zero and there was no \fIbodyN\fR. .SH KEYWORDS boolean, conditional, else, false, if, true tcl7.4b4/doc/incr.n010044400630510000012000000017270575277301600147240ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) incr.n 1.3 95/05/06 15:18:48 '\" .so man.macros .TH incr n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME incr \- Increment the value of a variable .SH SYNOPSIS \fBincr \fIvarName \fR?\fIincrement\fR? .BE .SH DESCRIPTION .PP Increments the value stored in the variable whose name is \fIvarName\fR. The value of the variable must be an integer. If \fIincrement\fR is supplied then its value (which must be an integer) is added to the value of variable \fIvarName\fR; otherwise 1 is added to \fIvarName\fR. The new value is stored as a decimal string in variable \fIvarName\fR and also returned as result. .SH KEYWORDS add, increment, variable, value tcl7.4b4/doc/info.n010044400630510000012000000133020575277301600147140ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) info.n 1.5 95/05/06 15:18:49 '\" .so man.macros .TH info n 7.0 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME info \- Return information about the state of the Tcl interpreter .SH SYNOPSIS \fBinfo \fIoption \fR?\fIarg arg ...\fR? .BE .SH DESCRIPTION .PP This command provides information about various internals of the Tcl interpreter. The legal \fIoption\fR's (which may be abbreviated) are: .TP \fBinfo args \fIprocname\fR Returns a list containing the names of the arguments to procedure \fIprocname\fR, in order. \fIProcname\fR must be the name of a Tcl command procedure. .TP \fBinfo body \fIprocname\fR Returns the body of procedure \fIprocname\fR. \fIProcname\fR must be the name of a Tcl command procedure. .TP \fBinfo cmdcount\fR Returns a count of the total number of commands that have been invoked in this interpreter. .TP \fBinfo commands \fR?\fIpattern\fR? If \fIpattern\fR isn't specified, returns a list of names of all the Tcl commands, including both the built-in commands written in C and the command procedures defined using the \fBproc\fR command. If \fIpattern\fR is specified, only those names matching \fIpattern\fR are returned. Matching is determined using the same rules as for \fBstring match\fR. .TP \fBinfo complete \fIcommand\fR Returns 1 if \fIcommand\fR is a complete Tcl command in the sense of having no unclosed quotes, braces, brackets or array element names, If the command doesn't appear to be complete then 0 is returned. This command is typically used in line-oriented input environments to allow users to type in commands that span multiple lines; if the command isn't complete, the script can delay evaluating it until additional lines have been typed to complete the command. .TP \fBinfo default \fIprocname arg varname\fR \fIProcname\fR must be the name of a Tcl command procedure and \fIarg\fR must be the name of an argument to that procedure. If \fIarg\fR doesn't have a default value then the command returns \fB0\fR. Otherwise it returns \fB1\fR and places the default value of \fIarg\fR into variable \fIvarname\fR. .TP \fBinfo exists \fIvarName\fR Returns \fB1\fR if the variable named \fIvarName\fR exists in the current context (either as a global or local variable), returns \fB0\fR otherwise. .TP \fBinfo globals \fR?\fIpattern\fR? If \fIpattern\fR isn't specified, returns a list of all the names of currently-defined global variables. If \fIpattern\fR is specified, only those names matching \fIpattern\fR are returned. Matching is determined using the same rules as for \fBstring match\fR. .TP \fBinfo level\fR ?\fInumber\fR? If \fInumber\fR is not specified, this command returns a number giving the stack level of the invoking procedure, or 0 if the command is invoked at top-level. If \fInumber\fR is specified, then the result is a list consisting of the name and arguments for the procedure call at level \fInumber\fR on the stack. If \fInumber\fR is positive then it selects a particular stack level (1 refers to the top-most active procedure, 2 to the procedure it called, and so on); otherwise it gives a level relative to the current level (0 refers to the current procedure, -1 to its caller, and so on). See the \fBuplevel\fR command for more information on what stack levels mean. .TP \fBinfo library\fR Returns the name of the library directory in which standard Tcl scripts are stored. .VS This is actually the value of the \fBtcl_library\fR variable and may be changed by setting \fBtcl_library\fR. See the \fBtclvars\fR manual entry for more information. .VE .TP \fBinfo locals \fR?\fIpattern\fR? If \fIpattern\fR isn't specified, returns a list of all the names of currently-defined local variables, including arguments to the current procedure, if any. Variables defined with the \fBglobal\fR and \fBupvar\fR commands will not be returned. If \fIpattern\fR is specified, only those names matching \fIpattern\fR are returned. Matching is determined using the same rules as for \fBstring match\fR. .TP \fBinfo patchlevel\fR .VS Returns a decimal integer giving the current patch level for Tcl. The patch level is incremented for each new release or patch, and it uniquely identifies an official version of Tcl. .VE .TP \fBinfo procs \fR?\fIpattern\fR? If \fIpattern\fR isn't specified, returns a list of all the names of Tcl command procedures. If \fIpattern\fR is specified, only those names matching \fIpattern\fR are returned. Matching is determined using the same rules as for \fBstring match\fR. .TP \fBinfo script\fR If a Tcl script file is currently being evaluated (i.e. there is a call to \fBTcl_EvalFile\fR active or there is an active invocation of the \fBsource\fR command), then this command returns the name of the innermost file being processed. Otherwise the command returns an empty string. .TP \fBinfo tclversion\fR Returns the version number for this version of Tcl in the form \fIx.y\fR, where changes to \fIx\fR represent major changes with probable incompatibilities and changes to \fIy\fR represent small enhancements and bug fixes that retain backward compatibility. .TP \fBinfo vars\fR ?\fIpattern\fR? If \fIpattern\fR isn't specified, returns a list of all the names of currently-visible variables, including both locals and currently-visible globals. If \fIpattern\fR is specified, only those names matching \fIpattern\fR are returned. Matching is determined using the same rules as for \fBstring match\fR. .SH KEYWORDS command, information, interpreter, level, procedure, variable tcl7.4b4/doc/join.n010044400630510000012000000015650575277301600147300ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) join.n 1.3 95/05/06 15:18:50 '\" .so man.macros .TH join n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME join \- Create a string by joining together list elements .SH SYNOPSIS \fBjoin \fIlist \fR?\fIjoinString\fR? .BE .SH DESCRIPTION .PP The \fIlist\fR argument must be a valid Tcl list. This command returns the string formed by joining all of the elements of \fIlist\fR together with \fIjoinString\fR separating each adjacent pair of elements. The \fIjoinString\fR argument defaults to a space character. .SH KEYWORDS element, join, list, separator tcl7.4b4/doc/lappend.n010044400630510000012000000023240575277301600154060ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) lappend.n 1.4 95/05/06 15:18:51 '\" .so man.macros .TH lappend n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME lappend \- Append list elements onto a variable .SH SYNOPSIS \fBlappend \fIvarName \fR?\fIvalue value value ...\fR? .BE .SH DESCRIPTION .PP This command treats the variable given by \fIvarName\fR as a list and appends each of the \fIvalue\fR arguments to that list as a separate element, with spaces between elements. If \fIvarName\fR doesn't exist, it is created as a list with elements given by the \fIvalue\fR arguments. \fBLappend\fR is similar to \fBappend\fR except that the \fIvalue\fRs are appended as list elements rather than raw text. This command provides a relatively efficient way to build up large lists. For example, ``\fBlappend a $b\fR'' is much more efficient than ``\fBset a [concat $a [list $b]]\fR'' when \fB$a\fR is long. .SH KEYWORDS append, element, list, variable tcl7.4b4/doc/library.n010044400630510000012000000205010576215603300154170ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1991-1993 The Regents of the University of California. '\" Copyright (c) 1994-1995 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) library.n 1.15 95/05/28 13:24:47 ' .so man.macros .de UL \\$1\l'|0\(ul'\\$2 .. .TH library n "" Tcl "Tcl Built-In Commands" .BS .SH NAME library \- standard library of Tcl procedures .SH SYNOPSIS .nf \fBauto_execok \fIcmd\fR \fBauto_load \fIcmd\fR \fBauto_mkindex \fIdir pattern pattern ...\fR \fBauto_reset\fR \fBparray \fIarrayName\fR \fBunknown \fIcmd \fR?\fIarg arg ...\fR? .fi .BE .SH INTRODUCTION .PP Tcl includes a library of Tcl procedures for commonly-needed functions. The procedures defined in the Tcl library are generic ones suitable for use by many different applications. The location of the Tcl library is returned by the \fBinfo library\fR command. In addition to the Tcl library, each application will normally have its own library of support procedures as well; the location of this library is normally given by the value of the \fB$\fIapp\fB_library\fR global variable, where \fIapp\fR is the name of the application. For example, the location of the Tk library is kept in the variable \fB$tk_library\fR. .PP To access the procedures in the Tcl library, an application should source the file \fBinit.tcl\fR in the library, for example with the Tcl command .DS \fBsource [info library]/init.tcl\fR .DE This will define the \fBunknown\fR procedure and arrange for the other procedures to be loaded on-demand using the auto-load mechanism defined below. .SH "COMMAND PROCEDURES" .PP The following procedures are provided in the Tcl library: .TP \fBauto_execok \fIcmd\fR Determines whether there is an executable file by the name \fIcmd\fR. This command examines the directories in the current search path (given by the PATH environment variable) to see if there is an executable file named \fIcmd\fR in any of those directories. If so, it returns 1; if not it returns 0. \fBAuto_exec\fR remembers information about previous searches in an array named \fBauto_execs\fR; this avoids the path search in future calls for the same \fIcmd\fR. The command \fBauto_reset\fR may be used to force \fBauto_execok\fR to forget its cached information. .TP \fBauto_load \fIcmd\fR This command attempts to load the definition for a Tcl command named \fIcmd\fR. To do this, it searches an \fIauto-load path\fR, which is a list of one or more directories. The auto-load path is given by the global variable \fB$auto_path\fR if it exists. If there is no \fB$auto_path\fR variable, then the TCLLIBPATH environment variable is used, if it exists. Otherwise the auto-load path consists of just the Tcl library directory. Within each directory in the auto-load path there must be a file \fBtclIndex\fR that describes one .VS or more commands defined in that directory and a script to evaluate to load each of the commands. The \fBtclIndex\fR file should be generated with the \fBauto_mkindex\fR command. If \fIcmd\fR is found in an index file, then the appropriate script is evaluated to create the command. .VE The \fBauto_load\fR command returns 1 if \fIcmd\fR was successfully created. The command returns 0 if there was no index entry for \fIcmd\fR or if the script didn't actually define \fIcmd\fR (e.g. because index information is out of date). If an error occurs while processing the script, then that error is returned. \fBAuto_load\fR only reads the index information once and saves it in the array \fBauto_index\fR; future calls to \fBauto_load\fR check for \fIcmd\fR in the array rather than re-reading the index files. The cached index information may be deleted with the command \fBauto_reset\fR. This will force the next \fBauto_load\fR command to reload the index database from disk. .TP \fBauto_mkindex \fIdir pattern pattern ...\fR .VS Generates an index suitable for use by \fBauto_load\fR. The command searches \fIdir\fR for all files whose names match any of the \fIpattern\fR arguments .VE (matching is done with the \fBglob\fR command), generates an index of all the Tcl command procedures defined in all the matching files, and stores the index information in a file named \fBtclIndex\fR in \fIdir\fR. For example, the command .RS .DS \fBauto_mkindex foo *.tcl\fR .DE .LP will read all the \fB.tcl\fR files in subdirectory \fBfoo\fR and generate a new index file \fBfoo/tclIndex\fR. .PP \fBAuto_mkindex\fR parses the Tcl scripts in a relatively unsophisticated way: if any line contains the word \fBproc\fR as its first characters then it is assumed to be a procedure definition and the next word of the line is taken as the procedure's name. Procedure definitions that don't appear in this way (e.g. they have spaces before the \fBproc\fR) will not be indexed. .RE .TP \fBauto_reset\fR Destroys all the information cached by \fBauto_execok\fR and \fBauto_load\fR. This information will be re-read from disk the next time it is needed. \fBAuto_reset\fR also deletes any procedures listed in the auto-load index, so that fresh copies of them will be loaded the next time that they're used. .TP \fBparray \fIarrayName\fR Prints on standard output the names and values of all the elements in the array \fIarrayName\fR. \fBArrayName\fR must be an array accessible to the caller of \fBparray\fR. It may be either local or global. .TP \fBunknown \fIcmd \fR?\fIarg arg ...\fR? This procedure is invoked automatically by the Tcl interpreter whenever the name of a command doesn't exist. The \fBunknown\fR procedure receives as its arguments the name and arguments of the missing command. .VS \fBUnknown\fR first calls \fBauto_load\fR to load the command. .VE If this succeeds, then it executes the original command with its original arguments. If the auto-load fails then \fBunknown\fR calls \fBauto_execok\fR to see if there is an executable file by the name \fIcmd\fR. If so, it invokes the Tcl \fBexec\fR command with \fIcmd\fR and all the \fIargs\fR as arguments. If \fIcmd\fR can't be auto-executed, \fBunknown\fR checks to see if the command was invoked at top-level and outside of any script. If so, then \fBunknown\fR takes takes two additional steps. First, it sees if \fIcmd\fR has one of the following three forms: \fB!!\fR, \fB!\fIevent\fR, or \fB^\fIold\fB^\fInew\fR?\fB^\fR?. If so, then \fBunknown\fR carries out history substitution in the same way that \fBcsh\fR would for these constructs. Second, and last, \fBunknown\fR checks to see if \fIcmd\fR is a unique abbreviation for an existing Tcl command. If so, it expands the command name and executes the command with the original arguments. If none of the above efforts has been able to execute the command, \fBunknown\fR generates an error return. If the global variable \fBauto_noload\fR is defined, then the auto-load step is skipped. If the global variable \fBauto_noexec\fR is defined then the auto-exec step is skipped. Under normal circumstances the return value from \fBunknown\fR is the return value from the command that was eventually executed. .SH "VARIABLES" .PP The following global variables are defined or used by the procedures in the Tcl library: .TP \fBauto_execs\fR Used by \fBauto_execok\fR to record information about whether particular commands exist as executable files. .TP \fBauto_index\fR Used by \fBauto_load\fR to save the index information read from disk. .TP \fBauto_noexec\fR If set to any value, then \fBunknown\fR will not attempt to auto-exec any commands. .TP \fBauto_noload\fR If set to any value, then \fBunknown\fR will not attempt to auto-load any commands. .TP \fBauto_path\fR If set, then it must contain a valid Tcl list giving directories to search during auto-load operations. .TP \fBenv(TCL_LIBRARY)\fR If set, then it specifies the location of the directory containing library scripts (the value of this variable will be returned by the command \fBinfo library\fR). If this variable isn't set then a default value is used. .TP \fBenv(TCLLIBPATH)\fR If set, then it must contain a valid Tcl list giving directories to search during auto-load operations. This variable is only used if \fBauto_path\fR is not defined. .TP \fBunknown_active\fR This variable is set by \fBunknown\fR to indicate that it is active. It is used to detect errors where \fBunknown\fR recurses on itself infinitely. The variable is unset before \fBunknown\fR returns. .SH KEYWORDS auto-exec, auto-load, library, unknown an.macros .de UL \\$1\l'|0\(ul'\\$2 .. .TH library n "" Tcl "Tcl Built-In Commands" .BS .SH NAME library \- standard library of Tcl procedures .SH SYNOPSIS .nf \fBauto_execok \fIcmd\fR \fBauttcl7.4b4/doc/lindex.n010044400630510000012000000022040575277301600152430ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1995 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) lindex.n 1.5 95/05/06 15:18:53 '\" .so man.macros .TH lindex n 7.4 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME lindex \- Retrieve an element from a list .SH SYNOPSIS \fBlindex \fIlist index\fR .BE .SH DESCRIPTION .PP This command treats \fIlist\fR as a Tcl list and returns the \fIindex\fR'th element from it (0 refers to the first element of the list). In extracting the element, \fIlindex\fR observes the same rules concerning braces and quotes and backslashes as the Tcl command interpreter; however, variable substitution and command substitution do not occur. If \fIindex\fR is negative or greater than or equal to the number of elements in \fIvalue\fR, then an empty string is returned. .VS If \fIindex\fR has the value \fBend\fR, it refers to the last element in the list. .VE .SH KEYWORDS element, index, list tcl7.4b4/doc/linsert.n010044400630510000012000000021570575277301600154470ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1995 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) linsert.n 1.5 95/05/06 15:18:53 '\" .so man.macros .TH linsert n 7.4 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME linsert \- Insert elements into a list .SH SYNOPSIS \fBlinsert \fIlist index element \fR?\fIelement element ...\fR? .BE .SH DESCRIPTION .PP This command produces a new list from \fIlist\fR by inserting all of the \fIelement\fR arguments just before the \fIindex\fRth element of \fIlist\fR. Each \fIelement\fR argument will become a separate element of the new list. If \fIindex\fR is less than or equal to zero, then the new elements are inserted at the beginning of the list. If \fIindex\fR .VS has the value \fBend\fR, .VE or if it is greater than or equal to the number of elements in the list, then the new elements are appended to the list. .SH KEYWORDS element, insert, list tcl7.4b4/doc/list.n010044400630510000012000000025610576215603300147340ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) list.n 1.5 95/05/28 13:24:48 '\" .so man.macros .TH list n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME list \- Create a list .SH SYNOPSIS .VS \fBlist \fR?\fIarg arg ...\fR? .VE .BE .SH DESCRIPTION .PP This command returns a list comprised of all the \fIarg\fRs, .VS or an empty string if no \fIarg\fRs are specified. .VE Braces and backslashes get added as necessary, so that the \fBindex\fR command may be used on the result to re-extract the original arguments, and also so that \fBeval\fR may be used to execute the resulting list, with \fIarg1\fR comprising the command's name and the other \fIarg\fRs comprising its arguments. \fBList\fR produces slightly different results than \fBconcat\fR: \fBconcat\fR removes one level of grouping before forming the list, while \fBlist\fR works directly from the original arguments. For example, the command .DS \fBlist a b {c d e} {f {g h}}\fR .DE will return .DS \fBa b {c d e} {f {g h}}\fR .DE while \fBconcat\fR with the same arguments will return .DS \fBa b c d e f {g h}\fR .DE .SH KEYWORDS element, list tcl7.4b4/doc/llength.n010044400630510000012000000012530575277301700154210ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) llength.n 1.3 95/05/06 15:18:56 '\" .so man.macros .TH llength n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME llength \- Count the number of elements in a list .SH SYNOPSIS \fBllength \fIlist\fR .BE .SH DESCRIPTION .PP Treats \fIlist\fR as a list and returns a decimal string giving the number of elements in it. .SH KEYWORDS element, list, length tcl7.4b4/doc/lrange.n010044400630510000012000000026320576215603300152300ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1995 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) lrange.n 1.6 95/05/28 13:24:49 '\" .so man.macros .TH lrange n 7.4 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME lrange \- Return one or more adjacent elements from a list .SH SYNOPSIS \fBlrange \fIlist first last\fR .BE .SH DESCRIPTION .PP \fIList\fR must be a valid Tcl list. This command will return a new list consisting of elements \fIfirst\fR through \fIlast\fR, inclusive. .VS \fIFirst\fR or \fIlast\fR .VE may be \fBend\fR (or any abbreviation of it) to refer to the last element of the list. If \fIfirst\fR is less than zero, it is treated as if it were zero. If \fIlast\fR is greater than or equal to the number of elements in the list, then it is treated as if it were \fBend\fR. If \fIfirst\fR is greater than \fIlast\fR then an empty string is returned. Note: ``\fBlrange \fIlist first first\fR'' does not always produce the same result as ``\fBlindex \fIlist first\fR'' (although it often does for simple fields that aren't enclosed in braces); it does, however, produce exactly the same results as ``\fBlist [lindex \fIlist first\fB]\fR'' .SH KEYWORDS element, list, range, sublist tcl7.4b4/doc/lreplace.n010044400630510000012000000030630575277301700155540ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1995 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) lreplace.n 1.5 95/05/06 15:19:02 '\" .so man.macros .TH lreplace n 7.4 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME lreplace \- Replace elements in a list with new elements .SH SYNOPSIS \fBlreplace \fIlist first last \fR?\fIelement element ...\fR? .BE .SH DESCRIPTION .PP \fBLreplace\fR returns a new list formed by replacing one or more elements of \fIlist\fR with the \fIelement\fR arguments. \fIFirst\fR gives the index in \fIlist\fR of the first element to be replaced (0 refers to the first element). If \fIfirst\fR is less than zero then it refers to the first element of \fIlist\fR; the element indicated by \fIfirst\fR must exist in the list. \fILast\fR gives the index in \fIlist\fR of the last element to be replaced; it must be greater than or equal to \fIfirst\fR. .VS \fIFirst\fR or \fIlast\fR may be \fBend\fR .VE (or any abbreviation of it) to refer to the last element of the list. The \fIelement\fR arguments specify zero or more new arguments to be added to the list in place of those that were deleted. Each \fIelement\fR argument will become a separate element of the list. If no \fIelement\fR arguments are specified, then the elements between \fIfirst\fR and \fIlast\fR are simply deleted. .SH KEYWORDS element, list, replace tcl7.4b4/doc/lsearch.n010044400630510000012000000027030575277301700154060ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) lsearch.n 1.4 95/05/06 15:18:59 '\" .so man.macros .TH lsearch n 7.0 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME lsearch \- See if a list contains a particular element .SH SYNOPSIS \fBlsearch \fR?\fImode\fR? \fIlist pattern\fR .BE .SH DESCRIPTION .PP This command searches the elements of \fIlist\fR to see if one of them matches \fIpattern\fR. If so, the command returns the index of the first matching element. If not, the command returns \fB\-1\fR. .VS The \fImode\fR argument indicates how the elements of the list are to be matched against \fIpattern\fR and it must have one of the following values: .TP \fB\-exact\fR The list element must contain exactly the same string as \fIpattern\fR. .TP \fB\-glob\fR \fIPattern\fR is a glob-style pattern which is matched against each list element using the same rules as the \fBstring match\fR command. .TP \fB\-regexp\fR \fIPattern\fR is treated as a regular expression and matched against each list element using the same rules as the \fBregexp\fR command. .PP If \fImode\fR is omitted then it defaults to \fB\-glob\fR. .VE .SH KEYWORDS list, match, pattern, regular expression, search, string tcl7.4b4/doc/lsort.n010044400630510000012000000033550575277301700151340ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) lsort.n 1.4 95/05/06 15:19:00 '\" .so man.macros .TH lsort n 7.0 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME lsort \- Sort the elements of a list .SH SYNOPSIS \fBlsort \fR?\fIswitches\fR? \fIlist\fR .BE .SH DESCRIPTION .PP This command sorts the elements of \fIlist\fR, returning a new list in sorted order. By default ASCII sorting is used with the result returned in increasing order. .VS However, any of the following switches may be specified before \fIlist\fR to control the sorting process (unique abbreviations are accepted): .TP 20 \fB\-ascii\fR Use string comparison with ASCII collation order. This is the default. .TP 20 \fB\-integer\fR Convert list elements to integers and use integer comparison. .TP 20 \fB\-real\fR Convert list elements to floating-point values and use floating comparison. .TP 20 \fB\-command\0\fIcommand\fR Use \fIcommand\fR as a comparison command. To compare two elements, evaluate a Tcl script consisting of \fIcommand\fR with the two elements appended as additional arguments. The script should return an integer less than, equal to, or greater than zero if the first element is to be considered less than, equal to, or greater than the second, respectively. .TP 20 \fB\-increasing\fR Sort the list in increasing order (``smallest'' items first). This is the default. .TP 20 \fB\-decreasing\fR Sort the list in decreasing order (``largest'' items first). .VE .SH KEYWORDS element, list, order, sort tcl7.4b4/doc/open.n010044400630510000012000000102570575277301700147310ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) open.n 1.4 95/05/06 15:19:05 '\" .so man.macros .TH open n 7.0 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME open \- Open a file .SH SYNOPSIS .VS \fBopen \fIfileName\fR ?\fIaccess\fR? ?\fIpermissions\fR? .VE .BE .SH DESCRIPTION .PP This command opens a file and returns an identifier that may be used in future invocations of commands like \fBread\fR, \fBputs\fR, and \fBclose\fR. \fIFileName\fR gives the name of the file to open; if it starts with a tilde then tilde substitution is performed as described for \fBTcl_TildeSubst\fR. If the first character of \fIfileName\fR is ``|'' then the remaining characters of \fIfileName\fR are treated as a command pipeline to invoke, in the same style as for \fBexec\fR. In this case, the identifier returned by \fBopen\fR may be used to write to the command's input pipe or read from its output pipe. .PP The \fIaccess\fR argument indicates the way in which the file (or command pipeline) is to be accessed. .VS It may take two forms, either a string in the form that would be passed to the \fBfopen\fR library procedure or a list of POSIX access flags. It defaults to ``\fBr\fR''. In the first form \fIaccess\fR may have any of the following values: .VE .TP 15 \fBr\fR Open the file for reading only; the file must already exist. .TP 15 \fBr+\fR Open the file for both reading and writing; the file must already exist. .TP 15 \fBw\fR Open the file for writing only. Truncate it if it exists. If it doesn't exist, create a new file. .TP 15 \fBw+\fR Open the file for reading and writing. Truncate it if it exists. If it doesn't exist, create a new file. .TP 15 \fBa\fR Open the file for writing only. The file must already exist, and the file is positioned so that new data is appended to the file. .TP 15 \fBa+\fR Open the file for reading and writing. If the file doesn't exist, create a new empty file. Set the initial access position to the end of the file. .PP In the second form, \fIaccess\fR consists of a list of any of the .VS following flags, all of which have the standard POSIX meanings. One of the flags must be either \fBRDONLY\fR, \fBWRONLY\fR or \fBRDWR\fR. .TP 15 \fBRDONLY\fR Open the file for reading only. .TP 15 \fBWRONLY\fR Open the file for writing only. .TP 15 \fBRDWR\fR Open the file for both reading and writing. .TP 15 \fBAPPEND\fR Set the file pointer to the end of the file prior to each write. .TP 15 \fBCREAT\fR Create the file if it doesn't already exist (without this flag it is an error for the file not to exist). .TP 15 \fBEXCL\fR If \fBCREAT\fR is also specified, an error is returned if the file already exists. .TP 15 \fBNOCTTY\fR If the file is a terminal device, this flag prevents the file from becoming the controlling terminal of the process. .TP 15 \fBNONBLOCK\fR Prevents the process from blocking while opening the file. For details refer to your system documentation on the \fBopen\fR system call's \fBO_NONBLOCK\fR flag. .TP 15 \fBTRUNC\fR If the file exists it is truncated to zero length. .PP If a new file is created as part of opening it, \fIpermissions\fR (an integer) is used to set the permissions for the new file in conjunction with the process's file mode creation mask. \fIPermissions\fR defaults to 0666. .VE .PP If a file is opened for both reading and writing then \fBseek\fR must be invoked between a read and a write, or vice versa (this restriction does not apply to command pipelines opened with \fBopen\fR). When \fIfileName\fR specifies a command pipeline and a write-only access is used, then standard output from the pipeline is directed to the current standard output unless overridden by the command. When \fIfileName\fR specifies a command pipeline and a read-only access is used, then standard input from the pipeline is taken from the current standard input unless overridden by the command. .SH KEYWORDS access mode, append, controlling terminal, create, file, non-blocking, open, permissions, pipeline, process en the file for writing only. Truncate it if it exists. If it doesn't exist, create a new file. .TP 15 \fBw+\fR Open the file for reading and writing. Truncate it if it exists. If it doesn't exist, create a new file. .TP 15 \fBa\fR Open the file for writing only. The file must already exist, and the file is positioned so that new dtcl7.4b4/doc/pid.n010044400630510000012000000021230575277301700145350ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) pid.n 1.3 95/05/06 15:19:07 '\" .so man.macros .TH pid n 7.0 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME pid \- Retrieve process id(s) .SH SYNOPSIS \fBpid \fR?\fIfileId\fR? .BE .SH DESCRIPTION .PP If the \fIfileId\fR argument is given then it should normally refer to a process pipeline created with the \fBopen\fR command. In this case the \fBpid\fR command will return a list whose elements are the process identifiers of all the processes in the pipeline, in order. The list will be empty if \fIfileId\fR refers to an open file that isn't a process pipeline. If no \fIfileId\fR argument is given then \fBpid\fR returns the process identifier of the current process. All process identifiers are returned as decimal strings. .SH KEYWORDS file, pipeline, process identifier tcl7.4b4/doc/proc.n010044400630510000012000000055740575277302000147330ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) proc.n 1.3 95/05/06 15:19:08 '\" .so man.macros .TH proc n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME proc \- Create a Tcl procedure .SH SYNOPSIS \fBproc \fIname args body\fR .BE .SH DESCRIPTION .PP The \fBproc\fR command creates a new Tcl procedure named \fIname\fR, replacing any existing command or procedure there may have been by that name. Whenever the new command is invoked, the contents of \fIbody\fR will be executed by the Tcl interpreter. \fIArgs\fR specifies the formal arguments to the procedure. It consists of a list, possibly empty, each of whose elements specifies one argument. Each argument specifier is also a list with either one or two fields. If there is only a single field in the specifier then it is the name of the argument; if there are two fields, then the first is the argument name and the second is its default value. .PP When \fIname\fR is invoked a local variable will be created for each of the formal arguments to the procedure; its value will be the value of corresponding argument in the invoking command or the argument's default value. Arguments with default values need not be specified in a procedure invocation. However, there must be enough actual arguments for all the formal arguments that don't have defaults, and there must not be any extra actual arguments. There is one special case to permit procedures with variable numbers of arguments. If the last formal argument has the name \fBargs\fR, then a call to the procedure may contain more actual arguments than the procedure has formals. In this case, all of the actual arguments starting at the one that would be assigned to \fBargs\fR are combined into a list (as if the \fBlist\fR command had been used); this combined value is assigned to the local variable \fBargs\fR. .PP When \fIbody\fR is being executed, variable names normally refer to local variables, which are created automatically when referenced and deleted when the procedure returns. One local variable is automatically created for each of the procedure's arguments. Global variables can only be accessed by invoking the \fBglobal\fR command or the \fBupvar\fR command. .PP The \fBproc\fR command returns an empty string. When a procedure is invoked, the procedure's return value is the value specified in a \fBreturn\fR command. If the procedure doesn't execute an explicit \fBreturn\fR, then its return value is the value of the last command executed in the procedure's body. If an error occurs while executing the procedure body, then the procedure-as-a-whole will return that same error. .SH KEYWORDS argument, procedure tcl7.4b4/doc/puts.n010044400630510000012000000023310575277302000147470ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) puts.n 1.3 95/05/06 15:19:10 '\" .so man.macros .TH puts n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME puts \- Write to a file .SH SYNOPSIS \fBputs \fR?\fB\-nonewline\fR? ?\fIfileId\fR? \fIstring\fR .BE .SH DESCRIPTION .PP Writes the characters given by \fIstring\fR to the file given by \fIfileId\fR. \fIFileId\fR must have been the return value from a previous call to \fBopen\fR, or it may be \fBstdout\fR or \fBstderr\fR to refer to one of the standard I/O channels; it must refer to a file that was opened for writing. If no \fIfileId\fR is specified then it defaults to \fBstdout\fR. \fBPuts\fR normally outputs a newline character after \fIstring\fR, but this feature may be suppressed by specifying the \fB\-nonewline\fR switch. Output to files is buffered internally by Tcl; the \fBflush\fR command may be used to force buffered characters to be output. .SH KEYWORDS file, newline, output, write tcl7.4b4/doc/pwd.n010044400630510000012000000011470575277302000145520ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) pwd.n 1.3 95/05/06 15:19:11 '\" .so man.macros .TH pwd n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME pwd \- Return the current working directory .SH SYNOPSIS \fBpwd\fR .BE .SH DESCRIPTION .PP Returns the path name of the current working directory. .SH KEYWORDS working directory tcl7.4b4/doc/read.n010044400630510000012000000025210575277302000146700ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) read.n 1.4 95/05/06 15:19:13 '\" .so man.macros .TH read n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME read \- Read from a file .SH SYNOPSIS \fBread \fR?\fB\-nonewline\fR? \fIfileId\fR .br \fBread \fIfileId numBytes\fR .BE .SH DESCRIPTION .PP In the first form, all of the remaining bytes are read from the file given by \fIfileId\fR; they are returned as the result of the command. If the \fB\-nonewline\fR switch is specified then the last character of the file is discarded if it is a newline. In the second form, the extra argument specifies how many bytes to read; exactly this many bytes will be read and returned, unless there are fewer than \fInumBytes\fR bytes left in the file; in this case, all the remaining bytes are returned. \fIFileId\fR must be \fBstdin\fR or the return value from a previous call to \fBopen\fR; it must refer to a file that was opened for reading. .VS Any existing end-of-file or error condition on the file is cleared at the beginning of the \fBread\fR command. .VE .SH KEYWORDS file, read tcl7.4b4/doc/scan.n010044400630510000012000000126500576215603400147060ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) scan.n 1.9 95/05/28 13:24:52 '\" .so man.macros .TH scan n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME scan \- Parse string using conversion specifiers in the style of sscanf .SH SYNOPSIS \fBscan \fIstring format varName \fR?\fIvarName ...\fR? .BE .SH INTRODUCTION .PP This command parses fields from an input string in the same fashion as the ANSI C \fBsscanf\fR procedure and returns a count of the number .VS of conversions performed, or -1 if the end of the input string is reached before any conversions have been performed. .VE \fIString\fR gives the input to be parsed and \fIformat\fR indicates how to parse it, using \fB%\fR conversion specifiers as in \fBsscanf\fR. Each \fIvarName\fR gives the name of a variable; when a field is scanned from \fIstring\fR the result is converted back into a string and assigned to the corresponding variable. .SH "DETAILS ON SCANNING" .PP \fBScan\fR operates by scanning \fIstring\fR and \fIformatString\fR together. If the next character in \fIformatString\fR is a blank or tab then it matches any number of white space characters in \fIstring\fR (including zero). Otherwise, if it isn't a \fB%\fR character then it must match the next character of \fIstring\fR. When a \fB%\fR is encountered in \fIformatString\fR, it indicates the start of a conversion specifier. A conversion specifier contains three fields after the \fB%\fR: a \fB*\fR, which indicates that the converted value is to be discarded instead of assigned to a variable; a number indicating a maximum field width; and a conversion character. All of these fields are optional except for the conversion character. .PP When \fBscan\fR finds a conversion specifier in \fIformatString\fR, it first skips any white-space characters in \fIstring\fR. Then it converts the next input characters according to the conversion specifier and stores the result in the variable given by the next argument to \fBscan\fR. The following conversion characters are supported: .TP 10 \fBd\fR The input field must be a decimal integer. It is read in and the value is stored in the variable as a decimal string. .TP 10 \fBo\fR The input field must be an octal integer. It is read in and the value is stored in the variable as a decimal string. .TP 10 \fBx\fR The input field must be a hexadecimal integer. It is read in and the value is stored in the variable as a decimal string. .TP 10 \fBc\fR A single character is read in and its binary value is stored in the variable as a decimal string. Initial white space is not skipped in this case, so the input field may be a white-space character. This conversion is different from the ANSI standard in that the input field always consists of a single character and no field width may be specified. .TP 10 \fBs\fR The input field consists of all the characters up to the next white-space character; the characters are copied to the variable. .TP 10 \fBe\fR or \fBf\fR or \fBg\fR The input field must be a floating-point number consisting of an optional sign, a string of decimal digits possibly containing a decimal point, and an optional exponent consisting of an \fBe\fR or \fBE\fR followed by an optional sign and a string of decimal digits. It is read in and stored in the variable as a floating-point string. .TP 10 \fB[\fIchars\fB]\fR The input field consists of any number of characters in \fIchars\fR. The matching string is stored in the variable. If the first character between the brackets is a \fB]\fR then it is treated as part of \fIchars\fR rather than the closing bracket for the set. .TP 10 \fB[^\fIchars\fB]\fR The input field consists of any number of characters not in \fIchars\fR. The matching string is stored in the variable. If the character immediately following the \fB^\fR is a \fB]\fR then it is treated as part of the set rather than the closing bracket for the set. .LP The number of characters read from the input for a conversion is the largest number that makes sense for that particular conversion (e.g. as many decimal digits as possible for \fB%d\fR, as many octal digits as possible for \fB%o\fR, and so on). The input field for a given conversion terminates either when a white-space character is encountered or when the maximum field width has been reached, whichever comes first. If a \fB*\fR is present in the conversion specifier then no variable is assigned and the next scan argument is not consumed. .SH "DIFFERENCES FROM ANSI SSCANF" .PP The behavior of the \fBscan\fR command is the same as the behavior of the ANSI C \fBsscanf\fR procedure except for the following differences: .IP [1] .VS \fB%p\fR and \fB%n\fR conversion specifiers are not currently supported. .VE .IP [2] For \fB%c\fR conversions a single character value is converted to a decimal string, which is then assigned to the corresponding \fIvarName\fR; no field width may be specified for this conversion. .IP [3] .VS The \fBl\fR, \fBh\fR, and \fBL\fR modifiers are ignored; integer values are always converted as if there were no modifier present and real values are always converted as if the \fBl\fR modifier were present (i.e. type \fBdouble\fR is used for the internal representation). .VE .SH KEYWORDS conversion specifier, parse, scan tcl7.4b4/doc/regexp.n010044400630510000012000000142130576215603400152510ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1995 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) regexp.n 1.8 95/05/28 13:24:50 '\" .so man.macros .TH regexp n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME regexp \- Match a regular expression against a string .SH SYNOPSIS \fBregexp \fR?\fIswitches\fR? \fIexp string \fR?\fImatchVar\fR? ?\fIsubMatchVar subMatchVar ...\fR? .BE .SH DESCRIPTION .PP Determines whether the regular expression \fIexp\fR matches part or all of \fIstring\fR and returns 1 if it does, 0 if it doesn't. .LP If additional arguments are specified after \fIstring\fR then they are treated as the names of variables in which to return information about which part(s) of \fIstring\fR matched \fIexp\fR. \fIMatchVar\fR will be set to the range of \fIstring\fR that matched all of \fIexp\fR. The first \fIsubMatchVar\fR will contain the characters in \fIstring\fR that matched the leftmost parenthesized subexpression within \fIexp\fR, the next \fIsubMatchVar\fR will contain the characters that matched the next parenthesized subexpression to the right in \fIexp\fR, and so on. .LP If the initial arguments to \fBregexp\fR start with \fB\-\fR then .VS they are treated as switches. The following switches are currently supported: .TP 10 \fB\-nocase\fR Causes upper-case characters in \fIstring\fR to be treated as lower case during the matching process. .TP 10 \fB\-indices\fR Changes what is stored in the \fIsubMatchVar\fRs. Instead of storing the matching characters from \fBstring\fR, each variable will contain a list of two decimal strings giving the indices in \fIstring\fR of the first and last characters in the matching range of characters. .TP 10 \fB\-\|\-\fR Marks the end of switches. The argument following this one will be treated as \fIexp\fR even if it starts with a \fB\-\fR. .VE .LP If there are more \fIsubMatchVar\fR's than parenthesized subexpressions within \fIexp\fR, or if a particular subexpression in \fIexp\fR doesn't match the string (e.g. because it was in a portion of the expression that wasn't matched), then the corresponding \fIsubMatchVar\fR will be set to ``\fB\-1 \-1\fR'' if \fB\-indices\fR has been specified or to an empty string otherwise. .SH "REGULAR EXPRESSIONS" .PP Regular expressions are implemented using Henry Spencer's package (thanks, Henry!), and much of the description of regular expressions below is copied verbatim from his manual entry. .PP A regular expression is zero or more \fIbranches\fR, separated by ``|''. It matches anything that matches one of the branches. .PP A branch is zero or more \fIpieces\fR, concatenated. It matches a match for the first, followed by a match for the second, etc. .PP A piece is an \fIatom\fR possibly followed by ``*'', ``+'', or ``?''. An atom followed by ``*'' matches a sequence of 0 or more matches of the atom. An atom followed by ``+'' matches a sequence of 1 or more matches of the atom. An atom followed by ``?'' matches a match of the atom, or the null string. .PP An atom is a regular expression in parentheses (matching a match for the regular expression), a \fIrange\fR (see below), ``.'' (matching any single character), ``^'' (matching the null string at the beginning of the input string), ``$'' (matching the null string at the end of the input string), a ``\e'' followed by a single character (matching that character), or a single character with no other significance (matching that character). .PP A \fIrange\fR is a sequence of characters enclosed in ``[]''. It normally matches any single character from the sequence. If the sequence begins with ``^'', it matches any single character \fInot\fR from the rest of the sequence. If two characters in the sequence are separated by ``\-'', this is shorthand for the full list of ASCII characters between them (e.g. ``[0-9]'' matches any decimal digit). To include a literal ``]'' in the sequence, make it the first character (following a possible ``^''). To include a literal ``\-'', make it the first or last character. .SH "CHOOSING AMONG ALTERNATIVE MATCHES" .PP In general there may be more than one way to match a regular expression to an input string. For example, consider the command .DS \fBregexp (a*)b* aabaaabb x y\fR .DE Considering only the rules given so far, \fBx\fR and \fBy\fR could end up with the values \fBaabb\fR and \fBaa\fR, \fBaaab\fR and \fBaaa\fR, \fBab\fR and \fBa\fR, or any of several other combinations. To resolve this potential ambiguity \fBregexp\fR chooses among alternatives using the rule ``first then longest''. In other words, it considers the possible matches in order working from left to right across the input string and the pattern, and it attempts to match longer pieces of the input string before shorter ones. More specifically, the following rules apply in decreasing order of priority: .IP [1] If a regular expression could match two different parts of an input string then it will match the one that begins earliest. .IP [2] If a regular expression contains \fB|\fR operators then the leftmost matching sub-expression is chosen. .IP [3] In \fB*\fR, \fB+\fR, and \fB?\fR constructs, longer matches are chosen in preference to shorter ones. .IP [4] In sequences of expression components the components are considered from left to right. .LP In the example from above, \fB(a*)b*\fR matches \fBaab\fR: the \fB(a*)\fR portion of the pattern is matched first and it consumes the leading \fBaa\fR; then the \fBb*\fR portion of the pattern consumes the next \fBb\fR. Or, consider the following example: .DS \fBregexp (ab|a)(b*)c abc x y z\fR .DE After this command \fBx\fR will be \fBabc\fR, \fBy\fR will be \fBab\fR, and \fBz\fR will be an empty string. Rule 4 specifies that \fB(ab|a)\fR gets first shot at the input string and Rule 2 specifies that the \fBab\fR sub-expression is checked before the \fBa\fR sub-expression. Thus the \fBb\fR has already been claimed before the \fB(b*)\fR component is checked and \fB(b*)\fR must match an empty string. .SH KEYWORDS match, regular expression, string tcl7.4b4/doc/regsub.n010044400630510000012000000053510576215603400152510ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) regsub.n 1.6 95/05/28 13:24:51 '\" .so man.macros .TH regsub n 7.4 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME regsub \- Perform substitutions based on regular expression pattern matching .SH SYNOPSIS \fBregsub \fR?\fIswitches\fR? \fIexp string subSpec varName\fR .BE .SH DESCRIPTION .PP This command matches the regular expression \fIexp\fR against \fIstring\fR, .VS and it copies \fIstring\fR to the variable whose name is given by \fIvarName\fR. If there is a match, then while copying \fIstring\fR to \fIvarName\fR the portion of \fIstring\fR that .VE matched \fIexp\fR is replaced with \fIsubSpec\fR. If \fIsubSpec\fR contains a ``&'' or ``\e0'', then it is replaced in the substitution with the portion of \fIstring\fR that matched \fIexp\fR. If \fIsubSpec\fR contains a ``\e\fIn\fR'', where \fIn\fR is a digit between 1 and 9, then it is replaced in the substitution with the portion of \fIstring\fR that matched the \fIn\fR-th parenthesized subexpression of \fIexp\fR. Additional backslashes may be used in \fIsubSpec\fR to prevent special interpretation of ``&'' or ``\e0'' or ``\e\fIn\fR'' or backslash. The use of backslashes in \fIsubSpec\fR tends to interact badly with the Tcl parser's use of backslashes, so it's generally safest to enclose \fIsubSpec\fR in braces if it includes backslashes. .LP If the initial arguments to \fBregexp\fR start with \fB\-\fR then .VS they are treated as switches. The following switches are currently supported: .TP 10 \fB\-all\fR All ranges in \fIstring\fR that match \fIexp\fR are found and substitution is performed for each of these ranges. Without this switch only the first matching range is found and substituted. If \fB\-all\fR is specified, then ``&'' and ``\e\fIn\fR'' sequences are handled for each substitution using the information from the corresponding match. .TP 10 \fB\-nocase\fR Upper-case characters in \fIstring\fR will be converted to lower-case before matching against \fIexp\fR; however, substitutions specified by \fIsubSpec\fR use the original unconverted form of \fIstring\fR. .TP 10 \fB\-\|\-\fR Marks the end of switches. The argument following this one will be treated as \fIexp\fR even if it starts with a \fB\-\fR. .VE .PP .VS The command returns a count of the number of matching ranges that were found and replaced. .VE See the manual entry for \fBregexp\fR for details on the interpretation of regular expressions. .SH KEYWORDS match, pattern, regular expression, substitute tcl7.4b4/doc/rename.n010044400630510000012000000014530575277302000152270ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) rename.n 1.3 95/05/06 15:19:18 '\" .so man.macros .TH rename n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME rename \- Rename or delete a command .SH SYNOPSIS \fBrename \fIoldName newName\fR .BE .SH DESCRIPTION .PP Rename the command that used to be called \fIoldName\fR so that it is now called \fInewName\fR. If \fInewName\fR is an empty string then \fIoldName\fR is deleted. The \fBrename\fR command returns an empty string as result. .SH KEYWORDS command, delete, rename tcl7.4b4/doc/return.n010044400630510000012000000061670575277302000153060ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) return.n 1.10 95/05/06 15:19:20 '\" .so man.macros .TH return n 7.0 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME return \- Return from a procedure .SH SYNOPSIS \fBreturn \fR?\fB\-code \fIcode\fR? ?\fB\-errorinfo \fIinfo\fR? ?\fB\-errorcode\fI code\fR? ?\fIstring\fR? .BE .SH DESCRIPTION .PP Return immediately from the current procedure (or top-level command or \fBsource\fR command), with \fIstring\fR as the return value. If \fIstring\fR is not specified then an empty string will be returned as result. .SH "EXCEPTIONAL RETURNS" .PP In the usual case where the \fB\-code\fR option isn't .VS specified the procedure will return normally (its completion code will be TCL_OK). However, the \fB\-code\fR option may be used to generate an exceptional return from the procedure. \fICode\fR may have any of the following values: .TP 10 \fBok\fR Normal return: same as if the option is omitted. .TP 10 \fBerror\fR Error return: same as if the \fBerror\fR command were used to terminate the procedure, except for handling of \fBerrorInfo\fR and \fBerrorCode\fR variables (see below). .TP 10 \fBreturn\fR The current procedure will return with a completion code of TCL_RETURN, so that the procedure that invoked it will return also. .TP 10 \fBbreak\fR The current procedure will return with a completion code of TCL_BREAK, which will terminate the innermost nested loop in the code that invoked the current procedure. .TP 10 \fBcontinue\fR The current procedure will return with a completion code of TCL_CONTINUE, which will terminate the current iteration of the innermost nested loop in the code that invoked the current procedure. .TP 10 \fIvalue\fR \fIValue\fR must be an integer; it will be returned as the completion code for the current procedure. .LP The \fB\-code\fR option is rarely used. It is provided so that procedures that implement new control structures can reflect exceptional conditions back to their callers. .PP Two additional options, \fB\-errorinfo\fR and \fB\-errorcode\fR, may be used to provide additional information during error returns. These options are ignored unless \fIcode\fR is \fBerror\fR. .PP The \fB\-errorinfo\fR option specifies an initial stack trace for the \fBerrorInfo\fR variable; if it is not specified then the stack trace left in \fBerrorInfo\fR will include the call to the procedure and higher levels on the stack but it will not include any information about the context of the error within the procedure. Typically the \fIinfo\fR value is supplied from the value left in \fBerrorInfo\fR after a \fBcatch\fR command trapped an error within the procedure. .PP If the \fB\-errorcode\fR option is specified then \fIcode\fR provides a value for the \fBerrorCode\fR variable. If the option is not specified then \fBerrorCode\fR will default to \fBNONE\fR. .VE .SH KEYWORDS break, continue, error, procedure, return tcl7.4b4/doc/seek.n010044400630510000012000000032260575277302100147100ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) seek.n 1.3 95/05/06 15:19:23 '\" .so man.macros .TH seek n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME seek \- Change the access position for an open file .SH SYNOPSIS \fBseek \fIfileId offset \fR?\fIorigin\fR? .BE .SH DESCRIPTION .PP Change the current access position for \fIfileId\fR. \fIFileId\fR must have been the return value from a previous call to \fBopen\fR, or it may be \fBstdin\fR, \fBstdout\fR, or \fBstderr\fR to refer to one of the standard I/O channels. The \fIoffset\fR and \fIorigin\fR arguments specify the position at which the next read or write will occur for \fIfileId\fR. \fIOffset\fR must be an integer (which may be negative) and \fIorigin\fR must be one of the following: .TP \fBstart\fR The new access position will be \fIoffset\fR bytes from the start of the file. .TP \fBcurrent\fR The new access position will be \fIoffset\fR bytes from the current access position; a negative \fIoffset\fR moves the access position backwards in the file. .TP \fBend\fR The new access position will be \fIoffset\fR bytes from the end of the file. A negative \fIoffset\fR places the access position before the end-of-file, and a positive \fIoffset\fR places the access position after the end-of-file. .LP The \fIorigin\fR argument defaults to \fBstart\fR. This command returns an empty string. .SH KEYWORDS access position, file, seek tcl7.4b4/doc/set.n010044400630510000012000000025250575277302100145550ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) set.n 1.3 95/05/06 15:19:25 '\" .so man.macros .TH set n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME set \- Read and write variables .SH SYNOPSIS \fBset \fIvarName \fR?\fIvalue\fR? .BE .SH DESCRIPTION .PP Returns the value of variable \fIvarName\fR. If \fIvalue\fR is specified, then set the value of \fIvarName\fR to \fIvalue\fR, creating a new variable if one doesn't already exist, and return its value. If \fIvarName\fR contains an open parenthesis and ends with a close parenthesis, then it refers to an array element: the characters before the first open parenthesis are the name of the array, and the characters between the parentheses are the index within the array. Otherwise \fIvarName\fR refers to a scalar variable. If no procedure is active, then \fIvarName\fR refers to a global variable. If a procedure is active, then \fIvarName\fR refers to a parameter or local variable of the procedure unless the \fIglobal\fR command has been invoked to declare \fIvarName\fR to be global. .SH KEYWORDS read, write, variable tcl7.4b4/doc/source.n010044400630510000012000000023140575277302100152560ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) source.n 1.3 95/05/06 15:19:26 '\" .so man.macros .TH source n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME source \- Evaluate a file as a Tcl script .SH SYNOPSIS \fBsource \fIfileName\fR .BE .SH DESCRIPTION .PP Read file \fIfileName\fR and pass the contents to the Tcl interpreter as a script to evaluate in the normal fashion. The return value from \fBsource\fR is the return value of the last command executed from the file. If an error occurs in evaluating the contents of the file then the \fBsource\fR command will return that error. If a \fBreturn\fR command is invoked from within the file then the remainder of the file will be skipped and the \fBsource\fR command will return normally with the result from the \fBreturn\fR command. If \fIfileName\fR starts with a tilde, then it is tilde-substituted as described in the \fBTcl_TildeSubst\fR manual entry. .SH KEYWORDS file, script tcl7.4b4/doc/split.n010044400630510000012000000025520575277302100151150ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) split.n 1.3 95/05/06 15:19:28 '\" .so man.macros .TH split n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME split \- Split a string into a proper Tcl list .SH SYNOPSIS \fBsplit \fIstring \fR?\fIsplitChars\fR? .BE .SH DESCRIPTION .PP Returns a list created by splitting \fIstring\fR at each character that is in the \fIsplitChars\fR argument. Each element of the result list will consist of the characters from \fIstring\fR that lie between instances of the characters in \fIsplitChars\fR. Empty list elements will be generated if \fIstring\fR contains adjacent characters in \fIsplitChars\fR, or if the first or last character of \fIstring\fR is in \fIsplitChars\fR. If \fIsplitChars\fR is an empty string then each character of \fIstring\fR becomes a separate element of the result list. \fISplitChars\fR defaults to the standard white-space characters. For example, .DS \fBsplit "comp.unix.misc" .\fR .DE returns \fB"comp unix misc"\fR and .DS \fBsplit "Hello world" {}\fR .DE returns \fB"H e l l o { } w o r l d"\fR. .SH KEYWORDS list, split, string tcl7.4b4/doc/string.n010044400630510000012000000122250575277302100152660ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1995 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) string.n 1.5 95/05/06 15:19:29 '\" .so man.macros .TH string n 7.4 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME string \- Manipulate strings .SH SYNOPSIS \fBstring \fIoption arg \fR?\fIarg ...?\fR .BE .SH DESCRIPTION .PP Performs one of several string operations, depending on \fIoption\fR. The legal \fIoption\fRs (which may be abbreviated) are: .TP \fBstring compare \fIstring1 string2\fR Perform a character-by-character comparison of strings \fIstring1\fR and \fIstring2\fR in the same way as the C \fBstrcmp\fR procedure. Return \-1, 0, or 1, depending on whether \fIstring1\fR is lexicographically less than, equal to, or greater than \fIstring2\fR. .TP \fBstring first \fIstring1 string2\fR Search \fIstring2\fR for a sequence of characters that exactly match the characters in \fIstring1\fR. If found, return the index of the first character in the first such match within \fIstring2\fR. If not found, return \-1. .TP \fBstring index \fIstring charIndex\fR Returns the \fIcharIndex\fR'th character of the \fIstring\fR argument. A \fIcharIndex\fR of 0 corresponds to the first character of the string. If \fIcharIndex\fR is less than 0 or greater than or equal to the length of the string then an empty string is returned. .TP \fBstring last \fIstring1 string2\fR Search \fIstring2\fR for a sequence of characters that exactly match the characters in \fIstring1\fR. If found, return the index of the first character in the last such match within \fIstring2\fR. If there is no match, then return \-1. .TP \fBstring length \fIstring\fR Returns a decimal string giving the number of characters in \fIstring\fR. .TP \fBstring match \fIpattern\fR \fIstring\fR See if \fIpattern\fR matches \fIstring\fR; return 1 if it does, 0 if it doesn't. Matching is done in a fashion similar to that used by the C-shell. For the two strings to match, their contents must be identical except that the following special sequences may appear in \fIpattern\fR: .RS .IP \fB*\fR 10 Matches any sequence of characters in \fIstring\fR, including a null string. .IP \fB?\fR 10 Matches any single character in \fIstring\fR. .IP \fB[\fIchars\fB]\fR 10 Matches any character in the set given by \fIchars\fR. If a sequence of the form \fIx\fB\-\fIy\fR appears in \fIchars\fR, then any character between \fIx\fR and \fIy\fR, inclusive, will match. .IP \fB\e\fIx\fR 10 Matches the single character \fIx\fR. This provides a way of avoiding the special interpretation of the characters \fB*?[]\e\fR in \fIpattern\fR. .RE .TP \fBstring range \fIstring first last\fR Returns a range of consecutive characters from \fIstring\fR, starting with the character whose index is \fIfirst\fR and ending with the character whose index is \fIlast\fR. An index of 0 refers to the first character of the string. \fILast\fR may be \fBend\fR (or any abbreviation of it) to refer to the last character of the string. If \fIfirst\fR is less than zero then it is treated as if it were zero, and if \fIlast\fR is greater than or equal to the length of the string then it is treated as if it were \fBend\fR. If \fIfirst\fR is greater than \fIlast\fR then an empty string is returned. .TP \fBstring tolower \fIstring\fR Returns a value equal to \fIstring\fR except that all upper case letters have been converted to lower case. .TP \fBstring toupper \fIstring\fR Returns a value equal to \fIstring\fR except that all lower case letters have been converted to upper case. .TP \fBstring trim \fIstring\fR ?\fIchars\fR? Returns a value equal to \fIstring\fR except that any leading or trailing characters from the set given by \fIchars\fR are removed. If \fIchars\fR is not specified then white space is removed (spaces, tabs, newlines, and carriage returns). .TP \fBstring trimleft \fIstring\fR ?\fIchars\fR? Returns a value equal to \fIstring\fR except that any leading characters from the set given by \fIchars\fR are removed. If \fIchars\fR is not specified then white space is removed (spaces, tabs, newlines, and carriage returns). .TP \fBstring trimright \fIstring\fR ?\fIchars\fR? Returns a value equal to \fIstring\fR except that any trailing characters from the set given by \fIchars\fR are removed. If \fIchars\fR is not specified then white space is removed (spaces, tabs, newlines, and carriage returns). .TP \fBstring wordend \fIstring index\fR .VS Returns the index of the character just after the last one in the word containing character \fIindex\fR of \fIstring\fR. A word is considered to be any contiguous range of alphanumeric or underscore characters, or any single character other than these. .TP \fBstring wordstart \fIstring index\fR Returns the index of the first character in the word containing character \fIindex\fR of \fIstring\fR. A word is considered to be any contiguous range of alphanumeric or underscore characters, or any single character other than these. .VE .SH KEYWORDS case conversion, compare, index, match, pattern, string, word tcl7.4b4/doc/subst.n010044400630510000012000000032630575277302100151220ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1994 The Regents of the University of California. '\" Copyright (c) 1994-1995 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) subst.n 1.6 95/05/06 15:19:31 '\" .so man.macros .TH subst n 7.4 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME subst \- Perform backslash, command, and variable substitutions .SH SYNOPSIS \fBsubst \fR?\fB\-nobackslashes\fR? ?\fB\-nocommands\fR? ?\fB\-novariables\fR? \fIstring\fR .BE .SH DESCRIPTION .PP This command performs variable substitutions, command substitutions, and backslash substitutions on its \fIstring\fR argument and returns the fully-substituted result. The substitutions are performed in exactly the same way as for Tcl commands. As a result, the \fIstring\fR argument is actually substituted twice, once by the Tcl parser in the usual fashion for Tcl commands, and again by the \fIsubst\fR command. .PP If any of the \fB\-nobackslashes\fR, \fB\-nocommands\fR, or \fB\-novariables\fR are specified, then the corresponding substitutions are not performed. For example, if \fB\-nocommands\fR is specified, no command substitution is performed: open and close brackets are treated as ordinary characters with no special interpretation. .PP Note: when it performs its substitutions, \fIsubst\fR does not give any special treatment to double quotes or curly braces. For example, the script .DS \fBset a 44 subst {xyz {$a}}\fR .DE returns ``\fBxyz {44}\fR'', not ``\fBxyz {$a}\fR''. .SH KEYWORDS backslash substitution, command substitution, variable substitution tcl7.4b4/doc/switch.n010044400630510000012000000070240576215603400152620ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) switch.n 1.5 95/05/28 13:24:52 '\" .so man.macros .TH switch n 7.0 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME switch \- Evaluate one of several scripts, depending on a given value .SH SYNOPSIS \fBswitch\fI \fR?\fIoptions\fR?\fI string \fIpattern body \fR?\fIpattern body \fR...? .br \fBswitch\fI \fR?\fIoptions\fR?\fI string \fR{\fIpattern body \fR?\fIpattern body \fR...?} .BE .SH DESCRIPTION .PP The \fBswitch\fR command matches its \fIstring\fR argument against each of the \fIpattern\fR arguments in order. As soon as it finds a \fIpattern\fR that matches \fIstring\fR it evaluates the following \fIbody\fR argument by passing it recursively to the Tcl interpreter and returns the result of that evaluation. If the last \fIpattern\fR argument is \fBdefault\fR then it matches anything. If no \fIpattern\fR argument matches \fIstring\fR and no default is given, then the \fBswitch\fR command returns an empty string. .PP If the initial arguments to \fBswitch\fR start with \fB\-\fR then they are treated as options. The following options are currently supported: .TP 10 \fB\-exact\fR Use exact matching when comparing \fIstring\fR to a pattern. This is the default. .TP 10 \fB\-glob\fR When matching \fIstring\fR to the patterns, use glob-style matching (i.e. the same as implemented by the \fBstring match\fR command). .TP 10 \fB\-regexp\fR When matching \fIstring\fR to the patterns, use regular expression matching (i.e. the same as implemented by the \fBregexp\fR command). .TP 10 \fB\-\|\-\fR Marks the end of options. The argument following this one will be treated as \fIstring\fR even if it starts with a \fB\-\fR. .PP Two syntaxes are provided for the \fIpattern\fR and \fIbody\fR arguments. The first uses a separate argument for each of the patterns and commands; this form is convenient if substitutions are desired on some of the patterns or commands. The second form places all of the patterns and commands together into a single argument; the argument must have proper list structure, with the elements of the list being the patterns and commands. The second form makes it easy to construct multi-line switch commands, since the braces around the whole list make it unnecessary to include a backslash at the end of each line. Since the \fIpattern\fR arguments are in braces in the second form, no command or variable substitutions are performed on them; this makes the behavior of the second form different than the first form in some cases. .PP If a \fIbody\fR is specified as ``\fB\-\fR'' it means that the \fIbody\fR for the next pattern should also be used as the body for this pattern (if the next pattern also has a body of ``\fB\-\fR'' then the body after that is used, and so on). This feature makes it possible to share a single \fIbody\fR among several patterns. .PP Below are some examples of \fBswitch\fR commands: .DS \fBswitch\0abc\0a\0\-\0b\0{format 1}\0abc\0{format 2}\0default\0{format 3}\fR .DE will return \fB2\fR, .DS .ta .5c 1c \fBswitch\0\-regexp\0aaab { ^a.*b$\0\- b\0{format 1} a*\0{format 2} default\0{format 3} }\fR .DE will return \fB1\fR, and .DS .ta .5c 1c \fBswitch\0xyz { a \- b {format 1} a* {format 2} default {format 3} }\fR .DE will return \fB3\fR. .SH KEYWORDS switch, match, regular expression tcl7.4b4/doc/tclsh.1010044400630510000012000000112350576547454100150110ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1995 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) tclsh.1 1.9 95/06/07 21:15:29 '\" .so man.macros .TH tclsh 1 "" Tcl "Tcl Applications" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME tclsh \- Simple shell containing Tcl interpreter .SH SYNOPSIS \fBtclsh\fR ?\fIfileName arg arg ...\fR? .BE .SH DESCRIPTION .PP \fBTclsh\fR is a shell-like application that reads Tcl commands from its standard input or from a file and evaluates them. If invoked with no arguments then it runs interactively, reading Tcl commands from standard input and printing command results and error messages to standard output. It runs until the \fBexit\fR command is invoked or until it reaches end-of-file on its standard input. If there exists a file \fB.tclshrc\fR in the home directory of the user, \fBtclsh\fR evaluates the file as a Tcl script just before reading the first command from standard input. .SH "SCRIPT FILES" .PP If \fBtclsh\fR is invoked with arguments then the first argument is the name of a script file and any additional arguments are made available to the script as variables (see below). Instead of reading commands from standard input \fBtclsh\fR will read Tcl commands from the named file; \fBtclsh\fR will exit when it reaches the end of the file. There is no automatic evaluation of \fB.tclshrc\fR in this case, but the script file can always \fBsource\fR it if desired. .PP If you create a Tcl script in a file whose first line is .DS \fB#!/usr/local/bin/tclsh\fR .DE then you can invoke the script file directly from your shell if you mark the file as executable. This assumes that \fBtclsh\fR has been installed in the default location in /usr/local/bin; if it's installed somewhere else then you'll have to modify the above line to match. .VS Many UNIX systems do not allow the \fB#!\fR line to exceed about 30 characters in length, so be sure that the \fBtclsh\fR executable can be accessed with a short file name. .PP An even better approach is to start your script files with the following three lines: .DS \fB#!/bin/sh # the next line restarts using tclsh \e exec tclsh "$0" "$@"\fR .DE This approach has three advantages over the approach in the previous paragraph. First, the location of the \fBtclsh\fR binary doesn't have to be hard-wired into the script: it can be anywhere in your shell search path. Second, it gets around the 30-character file name limit in the previous approach. Third, this approach will work even if \fBtclsh\fR is itself a shell script (this is done on some systems in order to handle multiple architectures or operating systems: the \fBtclsh\fR script selects one of several binaries to run). The three lines cause both \fBsh\fR and \fBtclsh\fR to process the script, but the \fBexec\fR is only executed by \fBsh\fR. \fBsh\fR processes the script first; it treats the second line as a comment and executes the third line. The \fBexec\fR statement cause the shell to stop processing and instead to start up \fBtclsh\fR to reprocess the entire script. When \fBtclsh\fR starts up, it treats all three lines as comments, since the backslash at the end of the second line causes the third line to be treated as part of the comment on the second line. .VE .SH "VARIABLES" .PP \fBTclsh\fR sets the following Tcl variables: .TP 15 \fBargc\fR Contains a count of the number of \fIarg\fR arguments (0 if none), not including the name of the script file. .TP 15 \fBargv\fR Contains a Tcl list whose elements are the \fIarg\fR arguments, in order, or an empty string if there are no \fIarg\fR arguments. .TP 15 \fBargv0\fR Contains \fIfileName\fR if it was specified. Otherwise, contains the name by which \fBtclsh\fR was invoked. .TP 15 \fBtcl_interactive\fR Contains 1 if \fBtclsh\fR is running interactively (no \fIfileName\fR was specified and standard input is a terminal-like device), 0 otherwise. .LP .SH PROMPTS .PP When \fBtclsh\fR is invoked interactively it normally prompts for each command with ``\fB% \fR''. You can change the prompt by setting the variables \fBtcl_prompt1\fR and \fBtcl_prompt2\fR. If variable \fBtcl_prompt1\fR exists then it must consist of a Tcl script to output a prompt; instead of outputting a prompt \fBtclsh\fR will evaluate the script in \fBtcl_prompt1\fR. The variable \fBtcl_prompt2\fR is used in a similar way when a newline is typed but the current command isn't yet complete; if \fBtcl_prompt2\fR isn't set then no prompt is output for incomplete commands. .SH KEYWORDS argument, interpreter, prompt, script file, shell .DS \fB#!/usr/local/bin/tclsh\fR .DE then you can invoke the script file directly from your shell if you mark the file as executable. This assumes that \fBtclsh\fR has been installed in the default location in /usr/local/bin; if it's installed somewhere else then you'll have to modify the above line to match. .VS Many UNIX systems do not allow the \fB#tcl7.4b4/doc/tclvars.n010044400630510000012000000146200575277302200154400ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) tclvars.n 1.5 95/05/06 15:19:36 '\" .so man.macros .TH tclvars n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME tclvars \- Variables used by Tcl .BE .SH DESCRIPTION .PP The following global variables are created and managed automatically by the Tcl library. Except where noted below, these variables should normally be treated as read-only by application-specific code and by users. .TP \fBenv\fR .br This variable is maintained by Tcl as an array whose elements are the environment variables for the process. Reading an element will return the value of the corresponding environment variable. Setting an element of the array will modify the corresponding environment variable or create a new one if it doesn't already exist. Unsetting an element of \fBenv\fR will remove the corresponding environment variable. Changes to the \fBenv\fR array will affect the environment passed to children by commands like \fBexec\fR. If the entire \fBenv\fR array is unset then Tcl will stop monitoring \fBenv\fR accesses and will not update environment variables. .TP \fBerrorCode\fR After an error has occurred, this variable will be set to hold additional information about the error in a form that is easy to process with programs. \fBerrorCode\fR consists of a Tcl list with one or more elements. The first element of the list identifies a general class of errors, and determines the format of the rest of the list. The following formats for \fBerrorCode\fR are used by the Tcl core; individual applications may define additional formats. .RS .TP \fBARITH\fI code msg\fR .VS This format is used when an arithmetic error occurs (e.g. an attempt to divide by zero in the \fBexpr\fR command). \fICode\fR identifies the precise error and \fImsg\fR provides a human-readable description of the error. \fICode\fR will be either DIVZERO (for an attempt to divide by zero), DOMAIN (if an argument is outside the domain of a function, such as acos(\-3)), IOVERFLOW (for integer overflow), OVERFLOW (for a floating-point overflow), or UNKNOWN (if the cause of the error cannot be determined). .VE .TP \fBCHILDKILLED\fI pid sigName msg\fR This format is used when a child process has been killed because of a signal. The second element of \fBerrorCode\fR will be the process's identifier (in decimal). The third element will be the symbolic name of the signal that caused the process to terminate; it will be one of the names from the include file signal.h, such as \fBSIGPIPE\fR. The fourth element will be a short human-readable message describing the signal, such as ``write on pipe with no readers'' for \fBSIGPIPE\fR. .TP \fBCHILDSTATUS\fI pid code\fR This format is used when a child process has exited with a non-zero exit status. The second element of \fBerrorCode\fR will be the process's identifier (in decimal) and the third element will be the exit code returned by the process (also in decimal). .TP \fBCHILDSUSP\fI pid sigName msg\fR This format is used when a child process has been suspended because of a signal. The second element of \fBerrorCode\fR will be the process's identifier, in decimal. The third element will be the symbolic name of the signal that caused the process to suspend; this will be one of the names from the include file signal.h, such as \fBSIGTTIN\fR. The fourth element will be a short human-readable message describing the signal, such as ``background tty read'' for \fBSIGTTIN\fR. .TP \fBNONE\fR .br This format is used for errors where no additional information is available for an error besides the message returned with the error. In these cases \fBerrorCode\fR will consist of a list containing a single element whose contents are \fBNONE\fR. .TP \fBPOSIX \fIerrName msg\fR .VS If the first element of \fBerrorCode\fR is \fBPOSIX\fR, then the error occurred during a POSIX kernel call. .VE The second element of the list will contain the symbolic name of the error that occurred, such as \fBENOENT\fR; this will be one of the values defined in the include file errno.h. The third element of the list will be a human-readable message corresponding to \fIerrName\fR, such as ``no such file or directory'' for the \fBENOENT\fR case. .PP To set \fBerrorCode\fR, applications should use library procedures such as \fBTcl_SetErrorCode\fR and .VS \fBTcl_PosixError\fR, .VE or they may invoke the \fBerror\fR command. If one of these methods hasn't been used, then the Tcl interpreter will reset the variable to \fBNONE\fR after the next error. .RE .TP \fBerrorInfo\fR After an error has occurred, this string will contain one or more lines identifying the Tcl commands and procedures that were being executed when the most recent error occurred. Its contents take the form of a stack trace showing the various nested Tcl commands that had been invoked at the time of the error. .TP \fBtcl_library\fR .VS When an interpreter is created, Tcl initializes this variable to hold the name of a directory containing the system library of Tcl scripts, such as those used for auto-loading. See the \fBlibrary\fR manual entry for details of the facilities provided by the Tcl script library. Normally each application will have its own application-specific script library in addition to the Tcl script library; each application should set a global variable with a name like \fB$\fIapp\fB_library\fR (where \fIapp\fR is the application's name) to hold the location of that application's library directory. The initial value of \fBtcl_library\fR is set from the TCL_LIBRARY environment variable if one exists, or from a compiled-in value otherwise. A Tcl application may change this variable to use a different library directory. The value of this variable is returned by the \fBinfo library\fR command. .TP \fBtcl_precision\fR If this variable is set, it must contain a decimal number giving the number of significant digits to include when converting floating-point values to strings. If this variable is not set then 6 digits are included. 17 digits is ``perfect'' for IEEE floating-point in that it allows double-precision values to be converted to strings and back to binary with no loss of precision. .VE .SH KEYWORDS arithmetic, error, environment, POSIX, precision, subprocess, variables tcl7.4b4/doc/tell.n010044400630510000012000000015200575277302200147150ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) tell.n 1.3 95/05/06 15:19:37 '\" .so man.macros .TH tell n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME tell \- Return current access position for an open file .SH SYNOPSIS \fBtell \fIfileId\fR .BE .SH DESCRIPTION .PP Returns a decimal string giving the current access position in \fIfileId\fR. \fIFileId\fR must have been the return value from a previous call to \fBopen\fR, or it may be \fBstdin\fR, \fBstdout\fR, or \fBstderr\fR to refer to one of the standard I/O channels. .SH KEYWORDS access position, file l "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME tell \- Return current access position for an open file .SH SYNOPSIS \fBteltcl7.4b4/doc/time.n010044400630510000012000000016330575277302200147200ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) time.n 1.3 95/05/06 15:19:39 '\" .so man.macros .TH time n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME time \- Time the execution of a script .SH SYNOPSIS \fBtime \fIscript\fR ?\fIcount\fR? .BE .SH DESCRIPTION .PP This command will call the Tcl interpreter \fIcount\fR times to evaluate \fIscript\fR (or once if \fIcount\fR isn't specified). It will then return a string of the form .DS \fB503 microseconds per iteration\fR .DE which indicates the average amount of time required per iteration, in microseconds. Time is measured in elapsed time, not CPU time. .SH KEYWORDS script, time tcl7.4b4/doc/trace.n010044400630510000012000000144510575277302200150620ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) trace.n 1.5 95/05/06 15:19:40 '\" .so man.macros .TH trace n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME trace \- Monitor variable accesses .SH SYNOPSIS \fBtrace \fIoption\fR ?\fIarg arg ...\fR? .BE .SH DESCRIPTION .PP This command causes Tcl commands to be executed whenever certain operations are invoked. At present, only variable tracing is implemented. The legal \fIoption\fR's (which may be abbreviated) are: .TP \fBtrace variable \fIname ops command\fR Arrange for \fIcommand\fR to be executed whenever variable \fIname\fR is accessed in one of the ways given by \fIops\fR. \fIName\fR may refer to a normal variable, an element of an array, or to an array as a whole (i.e. \fIname\fR may be just the name of an array, with no parenthesized index). If \fIname\fR refers to a whole array, then \fIcommand\fR is invoked whenever any element of the array is manipulated. .RS .LP \fIOps\fR indicates which operations are of interest, and consists of one or more of the following letters: .RS .TP \fBr\fR Invoke \fIcommand\fR whenever the variable is read. .TP \fBw\fR Invoke \fIcommand\fR whenever the variable is written. .TP \fBu\fR Invoke \fIcommand\fR whenever the variable is unset. Variables can be unset explicitly with the \fBunset\fR command, or implicitly when procedures return (all of their local variables are unset). Variables are also unset when interpreters are deleted, but traces will not be invoked because there is no interpreter in which to execute them. .RE .LP When the trace triggers, three arguments are appended to \fIcommand\fR so that the actual command is as follows: .DS C \fIcommand name1 name2 op\fR .DE \fIName1\fR and \fIname2\fR give the name(s) for the variable being accessed: if the variable is a scalar then \fIname1\fR gives the variable's name and \fIname2\fR is an empty string; if the variable is an array element then \fIname1\fR gives the name of the array and name2 gives the index into the array; if an entire array is being deleted and the trace was registered on the overall array, rather than a single element, then \fIname1\fR gives the array name and \fIname2\fR is an empty string. \fIOp\fR indicates what operation is being performed on the variable, and is one of \fBr\fR, \fBw\fR, or \fBu\fR as defined above. .LP \fICommand\fR executes in the same context as the code that invoked the traced operation: if the variable was accessed as part of a Tcl procedure, then \fIcommand\fR will have access to the same local variables as code in the procedure. This context may be different than the context in which the trace was created. If \fIcommand\fR invokes a procedure (which it normally does) then the procedure will have to use \fBupvar\fR or \fBuplevel\fR if it wishes to access the traced variable. Note also that \fIname1\fR may not necessarily be the same as the name used to set the trace on the variable; differences can occur if the access is made through a variable defined with the \fBupvar\fR command. .LP For read and write traces, \fIcommand\fR can modify the variable to affect the result of the traced operation. If \fIcommand\fR modifies the value of a variable during a read or write trace, then the new value will be returned as the result of the traced operation. The return value from \fIcommand\fR is ignored except that if it returns an error of any sort then the traced operation also returns an error with .VS the same error message returned by the trace command .VE (this mechanism can be used to implement read-only variables, for example). For write traces, \fIcommand\fR is invoked after the variable's value has been changed; it can write a new value into the variable to override the original value specified in the write operation. To implement read-only variables, \fIcommand\fR will have to restore the old value of the variable. .LP While \fIcommand\fR is executing during a read or write trace, traces on the variable are temporarily disabled. This means that reads and writes invoked by \fIcommand\fR will occur directly, without invoking \fIcommand\fR (or any other traces) again. .VS However, if \fIcommand\fR unsets the variable then unset traces will be invoked. .VE .LP When an unset trace is invoked, the variable has already been deleted: it will appear to be undefined with no traces. If an unset occurs because of a procedure return, then the trace will be invoked in the variable context of the procedure being returned to: the stack frame of the returning procedure will no longer exist. Traces are not disabled during unset traces, so if an unset trace command creates a new trace and accesses the variable, the trace will be invoked. .VS Any errors in unset traces are ignored. .VE .LP If there are multiple traces on a variable they are invoked in order of creation, most-recent first. If one trace returns an error, then no further traces are invoked for the variable. If an array element has a trace set, and there is also a trace set on the array as a whole, the trace on the overall array is invoked before the one on the element. .LP Once created, the trace remains in effect either until the trace is removed with the \fBtrace vdelete\fR command described below, until the variable is unset, or until the interpreter is deleted. Unsetting an element of array will remove any traces on that element, but will not remove traces on the overall array. .LP This command returns an empty string. .RE .TP \fBtrace vdelete \fIname ops command\fR If there is a trace set on variable \fIname\fR with the operations and command given by \fIops\fR and \fIcommand\fR, then the trace is removed, so that \fIcommand\fR will never again be invoked. Returns an empty string. .TP \fBtrace vinfo \fIname\fR Returns a list containing one element for each trace currently set on variable \fIname\fR. Each element of the list is itself a list containing two elements, which are the \fIops\fR and \fIcommand\fR associated with the trace. If \fIname\fR doesn't exist or doesn't have any traces set, then the result of the command will be an empty string. .SH KEYWORDS read, variable, write, trace, unset tcl7.4b4/doc/unknown.n010044400630510000012000000031010575277302200154510ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) unknown.n 1.4 95/05/06 15:19:41 '\" .so man.macros .TH unknown n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME unknown \- Handle attempts to use non-existent commands .SH SYNOPSIS \fBunknown \fIcmdName \fR?\fIarg arg ...\fR? .BE .SH DESCRIPTION .PP This command doesn't actually exist as part of Tcl, but Tcl will invoke it if it does exist. If the Tcl interpreter encounters a command name for which there is not a defined command, then Tcl checks for the existence of a command named \fBunknown\fR. If there is no such command, then the interpreter returns an error. If the \fBunknown\fR command exists, then it is invoked with arguments consisting of the fully-substituted name and arguments for the original non-existent command. The \fBunknown\fR command typically does things like searching through library directories for a command procedure with the name \fIcmdName\fR, or expanding abbreviated command names to full-length, or automatically executing unknown commands as sub-processes. In some cases (such as expanding abbreviations) \fBunknown\fR will change the original command slightly and then (re-)execute it. The result of the \fBunknown\fR command is used as the result for the original non-existent command. .SH KEYWORDS error, non-existent command tcl7.4b4/doc/unset.n010044400630510000012000000021420575277302200151140ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) unset.n 1.3 95/05/06 15:19:42 '\" .so man.macros .TH unset n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME unset \- Delete variables .SH SYNOPSIS \fBunset \fIname \fR?\fIname name ...\fR? .BE .SH DESCRIPTION .PP This command removes one or more variables. Each \fIname\fR is a variable name, specified in any of the ways acceptable to the \fBset\fR command. If a \fIname\fR refers to an element of an array then that element is removed without affecting the rest of the array. If a \fIname\fR consists of an array name with no parenthesized index, then the entire array is deleted. The \fBunset\fR command returns an empty string as result. An error occurs if any of the variables doesn't exist, and any variables after the non-existent one are not deleted. .SH KEYWORDS remove, variable tcl7.4b4/doc/uplevel.n010044400630510000012000000053010576215603400154310ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) uplevel.n 1.4 95/05/28 13:24:54 '\" .so man.macros .TH uplevel n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME uplevel \- Execute a script in a different stack frame .SH SYNOPSIS \fBuplevel \fR?\fIlevel\fR?\fI arg \fR?\fIarg ...\fR? .BE .SH DESCRIPTION .PP All of the \fIarg\fR arguments are concatenated as if they had been passed to \fBconcat\fR; the result is then evaluated in the variable context indicated by \fIlevel\fR. \fBUplevel\fR returns the result of that evaluation. .PP If \fIlevel\fR is an integer then it gives a distance (up the procedure calling stack) to move before executing the command. If \fIlevel\fR consists of \fB#\fR followed by a number then the number gives an absolute level number. If \fIlevel\fR is omitted then it defaults to \fB1\fR. \fILevel\fR cannot be defaulted if the first \fIcommand\fR argument starts with a digit or \fB#\fR. .PP For example, suppose that procedure \fBa\fR was invoked from top-level, and that it called \fBb\fR, and that \fBb\fR called \fBc\fR. Suppose that \fBc\fR invokes the \fBuplevel\fR command. If \fIlevel\fR is \fB1\fR or \fB#2\fR or omitted, then the command will be executed in the variable context of \fBb\fR. If \fIlevel\fR is \fB2\fR or \fB#1\fR then the command will be executed in the variable context of \fBa\fR. If \fIlevel\fR is \fB3\fR or \fB#0\fR then the command will be executed at top-level (only global variables will be visible). .PP The \fBuplevel\fR command causes the invoking procedure to disappear from the procedure calling stack while the command is being executed. In the above example, suppose \fBc\fR invokes the command .DS \fBuplevel 1 {set x 43; d}\fR .DE where \fBd\fR is another Tcl procedure. The \fBset\fR command will modify the variable \fBx\fR in \fBb\fR's context, and \fBd\fR will execute at level 3, as if called from \fBb\fR. If it in turn executes the command .DS \fBuplevel {set x 42}\fR .DE then the \fBset\fR command will modify the same variable \fBx\fR in \fBb\fR's context: the procedure \fBc\fR does not appear to be on the call stack when \fBd\fR is executing. The command ``\fBinfo level\fR'' may be used to obtain the level of the current procedure. .PP \fBUplevel\fR makes it possible to implement new control constructs as Tcl procedures (for example, \fBuplevel\fR could be used to implement the \fBwhile\fR construct as a Tcl procedure). .SH KEYWORDS context, stack frame, variables tcl7.4b4/doc/upvar.n010044400630510000012000000050350576215603400151160ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) upvar.n 1.7 95/05/28 13:24:55 '\" .so man.macros .TH upvar n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME upvar \- Create link to variable in a different stack frame .SH SYNOPSIS \fBupvar \fR?\fIlevel\fR? \fIotherVar myVar \fR?\fIotherVar myVar \fR...? .BE .SH DESCRIPTION .PP This command arranges for one or more local variables in the current procedure to refer to variables in an enclosing procedure call or to global variables. \fILevel\fR may have any of the forms permitted for the \fBuplevel\fR command, and may be omitted if the first letter of the first \fIotherVar\fR isn't \fB#\fR or a digit (it defaults to \fB1\fR). For each \fIotherVar\fR argument, \fBupvar\fR makes the variable by that name in the procedure frame given by \fIlevel\fR (or at global level, if \fIlevel\fR is \fB#0\fR) accessible in the current procedure by the name given in the corresponding \fImyVar\fR argument. The variable named by \fIotherVar\fR need not exist at the time of the call; it will be created the first time \fImyVar\fR is referenced, just like an ordinary variable. .VS \fIMyVar\fR may not refer to an element of an array, but \fIotherVar\fR may refer to an array element. .VE \fBUpvar\fR returns an empty string. .PP The \fBupvar\fR command simplifies the implementation of call-by-name procedure calling and also makes it easier to build new control constructs as Tcl procedures. For example, consider the following procedure: .DS .ta 1c 2c 3c \fBproc add2 name { upvar $name x set x [expr $x+2] }\fR .DE \fBAdd2\fR is invoked with an argument giving the name of a variable, and it adds two to the value of that variable. Although \fBadd2\fR could have been implemented using \fBuplevel\fR instead of \fBupvar\fR, \fBupvar\fR makes it simpler for \fBadd2\fR to access the variable in the caller's procedure frame. .PP .VS If an upvar variable is unset (e.g. \fBx\fR in \fBadd2\fR above), the \fBunset\fR operation affects the variable it is linked to, not the upvar variable. There is no way to unset an upvar variable except by exiting the procedure in which it is defined. However, it is possible to retarget an upvar variable by executing another \fBupvar\fR command. .VE .SH KEYWORDS context, frame, global, level, procedure, variable e Regents of the University of California. '\" Copyright (c) 1994 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) upvar.n 1.7 95/05/28 13:24:55 '\" .so man.macros .TH upvar n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME upvar \- Create link to variable in a different stack frame .SH SYNOPSIS tcl7.4b4/doc/while.n010044400630510000012000000024470576215603400150750ustar00ousterstaff00002300000001'\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" @(#) while.n 1.4 95/05/28 13:24:56 '\" .so man.macros .TH while n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME while \- Execute script repeatedly as long as a condition is met .SH SYNOPSIS \fBwhile \fItest body\fR .BE .SH DESCRIPTION .PP The \fIwhile\fR command evaluates \fItest\fR as an expression (in the same way that \fBexpr\fR evaluates its argument). The value of the expression must a proper boolean value; if it is a true value then \fIbody\fR is executed by passing it to the Tcl interpreter. Once \fIbody\fR has been executed then \fItest\fR is evaluated again, and the process repeats until eventually \fItest\fR evaluates to a false boolean value. \fBContinue\fR commands may be executed inside \fIbody\fR to terminate the current iteration of the loop, and \fBbreak\fR commands may be executed inside \fIbody\fR to cause immediate termination of the \fBwhile\fR command. The \fBwhile\fR command always returns an empty string. .SH KEYWORDS boolean value, loop, test, while tcl7.4b4/doc/man.macros010044400630510000012000000064600575277301700155730ustar00ousterstaff00002300000001'\" The definitions below are for supplemental macros used in Tcl/Tk '\" manual entries. '\" '\" .AP type name in/out [indent] '\" Start paragraph describing an argument to a library procedure. '\" type is type of argument (int, etc.), in/out is either "in", "out", '\" or "in/out" to describe whether procedure reads or modifies arg, '\" and indent is equivalent to second arg of .IP (shouldn't ever be '\" needed; use .AS below instead) '\" '\" .AS [type [name]] '\" Give maximum sizes of arguments for setting tab stops. Type and '\" name are examples of largest possible arguments that will be passed '\" to .AP later. If args are omitted, default tab stops are used. '\" '\" .BS '\" Start box enclosure. From here until next .BE, everything will be '\" enclosed in one large box. '\" '\" .BE '\" End of box enclosure. '\" '\" .VS '\" Begin vertical sidebar, for use in marking newly-changed parts '\" of man pages. '\" '\" .VE '\" End of vertical sidebar. '\" '\" .DS '\" Begin an indented unfilled display. '\" '\" .DE '\" End of indented unfilled display. '\" '\" @(#) man.macros 1.3 95/05/06 15:19:04 '\" '\" # Set up traps and other miscellaneous stuff for Tcl/Tk man pages. .if t .wh -1.3i ^B .nr ^l \n(.l .ad b '\" # Start an argument description .de AP .ie !"\\$4"" .TP \\$4 .el \{\ . ie !"\\$2"" .TP \\n()Cu . el .TP 15 .\} .ie !"\\$3"" \{\ .ta \\n()Au \\n()Bu \&\\$1 \\fI\\$2\\fP (\\$3) .\".b .\} .el \{\ .br .ie !"\\$2"" \{\ \&\\$1 \\fI\\$2\\fP .\} .el \{\ \&\\fI\\$1\\fP .\} .\} .. '\" # define tabbing values for .AP .de AS .nr )A 10n .if !"\\$1"" .nr )A \\w'\\$1'u+3n .nr )B \\n()Au+15n .\" .if !"\\$2"" .nr )B \\w'\\$2'u+\\n()Au+3n .nr )C \\n()Bu+\\w'(in/out)'u+2n .. '\" # BS - start boxed text '\" # ^y = starting y location '\" # ^b = 1 .de BS .br .mk ^y .nr ^b 1u .if n .nf .if n .ti 0 .if n \l'\\n(.lu\(ul' .if n .fi .. '\" # BE - end boxed text (draw box now) .de BE .nf .ti 0 .mk ^t .ie n \l'\\n(^lu\(ul' .el \{\ .\" Draw four-sided box normally, but don't draw top of .\" box if the box started on an earlier page. .ie !\\n(^b-1 \{\ \h'-1.5n'\L'|\\n(^yu-1v'\l'\\n(^lu+3n\(ul'\L'\\n(^tu+1v-\\n(^yu'\l'|0u-1.5n\(ul' .\} .el \}\ \h'-1.5n'\L'|\\n(^yu-1v'\h'\\n(^lu+3n'\L'\\n(^tu+1v-\\n(^yu'\l'|0u-1.5n\(ul' .\} .\} .fi .br .nr ^b 0 .. '\" # VS - start vertical sidebar '\" # ^Y = starting y location '\" # ^v = 1 (for troff; for nroff this doesn't matter) .de VS .mk ^Y .ie n 'mc \s12\(br\s0 .el .nr ^v 1u .. '\" # VE - end of vertical sidebar .de VE .ie n 'mc .el \{\ .ev 2 .nf .ti 0 .mk ^t \h'|\\n(^lu+3n'\L'|\\n(^Yu-1v\(bv'\v'\\n(^tu+1v-\\n(^Yu'\h'-|\\n(^lu+3n' .sp -1 .fi .ev .\} .nr ^v 0 .. '\" # Special macro to handle page bottom: finish off current '\" # box/sidebar if in box/sidebar mode, then invoked standard '\" # page bottom macro. .de ^B .ev 2 'ti 0 'nf .mk ^t .if \\n(^b \{\ .\" Draw three-sided box if this is the box's first page, .\" draw two sides but no top otherwise. .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 .el \h'-1.5n'\L'|\\n(^yu-1v'\h'\\n(^lu+3n'\L'\\n(^tu+1v-\\n(^yu'\h'|0u'\c .\} .if \\n(^v \{\ .nr ^x \\n(^tu+1v-\\n(^Yu \kx\h'-\\nxu'\h'|\\n(^lu+3n'\ky\L'-\\n(^xu'\v'\\n(^xu'\h'|0u'\c .\} .bp 'fi .ev .if \\n(^b \{\ .mk ^y .nr ^b 2 .\} .if \\n(^v \{\ .mk ^Y .\} .. '\" # DS - begin display .de DS .RS .nf .sp .. '\" # DE - end display .de DE .fi .RE .sp .. tcl7.4b4/compat/004077500630510000012000000000000577032347200143255ustar00ousterstaff00002300000001tcl7.4b4/compat/license.terms010044400630510000012000000033060567470030500170130ustar00ousterstaff00002300000001This software is copyrighted by the Regents of the University of California, Sun Microsystems, Inc., and other parties. The following terms apply to all files associated with the software unless explicitly disclaimed in individual files. The authors hereby grant permission to use, copy, modify, distribute, and license this software and its documentation for any purpose, provided that existing copyright notices are retained in all copies and that this notice is included verbatim in any distributions. No written agreement, license, or royalty fee is required for any of the authorized uses. Modifications to this software may be copyrighted by their authors and need not follow the licensing terms described here, provided that the new terms are clearly indicated on the first page of each file where they apply. IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. RESTRICTED RIGHTS: Use, duplication or disclosure by the government is subject to the restrictions as set forth in subparagraph (c) (1) (ii) of the Rights in Technical Data and Computer Software Clause as DFARS 252.227-7013 and FAR 52.227-19. tcl7.4b4/compat/fixstrtod.c010044400630510000012000000013030575301340100164720ustar00ousterstaff00002300000001/* * fixstrtod.c -- * * Source code for the "fixstrtod" procedure. This procedure is * used in place of strtod under Solaris 2.4, in order to fix * a bug where the "end" pointer gets set incorrectly. * * Copyright (c) 1995 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ static char sccsid[] = "@(#) fixstrtod.c 1.1 95/05/06 17:40:33"; #undef strtod #include double fixstrtod(string, endPtr) char *string; char **endPtr; { double d; d = strtod(string, endPtr); if ((*endPtr != string) && ((*endPtr)[-1] == 0)) { *endPtr -= 1; } return d; } tcl7.4b4/compat/getcwd.c010044400630510000012000000022030567470066100157360ustar00ousterstaff00002300000001/* * getcwd.c -- * * This file provides an implementation of the getcwd procedure * that uses getwd, for systems with getwd but without getcwd. * * Copyright (c) 1993 The Regents of the University of California. * Copyright (c) 1994 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #ifndef lint static char sccsid[] = "@(#) getcwd.c 1.4 94/12/17 16:26:18"; #endif /* not lint */ #include "tclInt.h" #include "tclPort.h" extern char *getwd _ANSI_ARGS_((char *pathname)); char * getcwd(buf, size) char *buf; /* Where to put path for current directory. */ size_t size; /* Number of bytes at buf. */ { char realBuffer[MAXPATHLEN+1]; int length; if (getwd(realBuffer) == NULL) { /* * There's not much we can do besides guess at an errno to * use for the result (the error message in realBuffer isn't * much use...). */ errno = EACCES; return NULL; } length = strlen(realBuffer); if (length >= size) { errno = ERANGE; return NULL; } strcpy(buf, realBuffer); return buf; } tcl7.4b4/compat/opendir.c010044400630510000012000000037770567470055400161430ustar00ousterstaff00002300000001/* * opendir.c -- * * This file provides dirent-style directory-reading procedures * for V7 Unix systems that don't have such procedures. The * origin of this code is unclear, but it seems to have come * originally from Larry Wall. * */ static char sccsid[] = "@(#) opendir.c 1.2 94/11/04 13:55:02"; #include "tclInt.h" #include "tclPort.h" #undef DIRSIZ #define DIRSIZ(dp) \ ((sizeof (struct dirent) - (MAXNAMLEN+1)) + (((dp)->d_namlen+1 + 3) &~ 3)) /* * open a directory. */ DIR * opendir(name) char *name; { register DIR *dirp; register int fd; char *myname; myname = ((*name == '\0') ? "." : name); if ((fd = open(myname, 0, 0)) == -1) return NULL; if ((dirp = (DIR *)ckalloc(sizeof(DIR))) == NULL) { close (fd); return NULL; } dirp->dd_fd = fd; dirp->dd_loc = 0; return dirp; } /* * read an old style directory entry and present it as a new one */ #ifndef pyr #define ODIRSIZ 14 struct olddirect { ino_t od_ino; char od_name[ODIRSIZ]; }; #else /* a Pyramid in the ATT universe */ #define ODIRSIZ 248 struct olddirect { long od_ino; short od_fill1, od_fill2; char od_name[ODIRSIZ]; }; #endif /* * get next entry in a directory. */ struct dirent * readdir(dirp) register DIR *dirp; { register struct olddirect *dp; static struct dirent dir; for (;;) { if (dirp->dd_loc == 0) { dirp->dd_size = read(dirp->dd_fd, dirp->dd_buf, DIRBLKSIZ); if (dirp->dd_size <= 0) return NULL; } if (dirp->dd_loc >= dirp->dd_size) { dirp->dd_loc = 0; continue; } dp = (struct olddirect *)(dirp->dd_buf + dirp->dd_loc); dirp->dd_loc += sizeof(struct olddirect); if (dp->od_ino == 0) continue; dir.d_ino = dp->od_ino; strncpy(dir.d_name, dp->od_name, ODIRSIZ); dir.d_name[ODIRSIZ] = '\0'; /* insure null termination */ dir.d_namlen = strlen(dir.d_name); dir.d_reclen = DIRSIZ(&dir); return (&dir); } } /* * close a directory. */ void closedir(dirp) register DIR *dirp; { close(dirp->dd_fd); dirp->dd_fd = -1; dirp->dd_loc = 0; ckfree((char *) dirp); } tcl7.4b4/compat/strerror.c010044400630510000012000000260000567470066100163440ustar00ousterstaff00002300000001/* * strerror.c -- * * Source code for the "strerror" library routine. * * Copyright (c) 1991-1993 The Regents of the University of California. * Copyright (c) 1994 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #ifndef lint static char sccsid[] = "@(#) strerror.c 1.10 94/12/17 16:26:21"; #endif /* not lint */ #include "tclInt.h" #include "tclPort.h" extern int sys_nerr; extern char *sys_errlist[]; /* *---------------------------------------------------------------------- * * strerror -- * * Map an integer error number into a printable string. * * Results: * The return value is a pointer to a string describing * error. The first character of string isn't capitalized. * * Side effects: * Each call to this procedure may overwrite the value returned * by the previous call. * *---------------------------------------------------------------------- */ char * strerror(error) int error; /* Integer identifying error (must be * one of the officially-defined Sprite * errors, as defined in errno.h). */ { static char msg[50]; #ifndef NO_SYS_ERRLIST if ((error <= sys_nerr) && (error > 0)) { return sys_errlist[error]; } #else switch (error) { #ifdef E2BIG case E2BIG: return "argument list too long"; #endif #ifdef EACCES case EACCES: return "permission denied"; #endif #ifdef EADDRINUSE case EADDRINUSE: return "address already in use"; #endif #ifdef EADDRNOTAVAIL case EADDRNOTAVAIL: return "can't assign requested address"; #endif #ifdef EADV case EADV: return "advertise error"; #endif #ifdef EAFNOSUPPORT case EAFNOSUPPORT: return "address family not supported by protocol family"; #endif #ifdef EAGAIN case EAGAIN: return "no more processes"; #endif #ifdef EALIGN case EALIGN: return "EALIGN"; #endif #ifdef EALREADY case EALREADY: return "operation already in progress"; #endif #ifdef EBADE case EBADE: return "bad exchange descriptor"; #endif #ifdef EBADF case EBADF: return "bad file number"; #endif #ifdef EBADFD case EBADFD: return "file descriptor in bad state"; #endif #ifdef EBADMSG case EBADMSG: return "not a data message"; #endif #ifdef EBADR case EBADR: return "bad request descriptor"; #endif #ifdef EBADRPC case EBADRPC: return "RPC structure is bad"; #endif #ifdef EBADRQC case EBADRQC: return "bad request code"; #endif #ifdef EBADSLT case EBADSLT: return "invalid slot"; #endif #ifdef EBFONT case EBFONT: return "bad font file format"; #endif #ifdef EBUSY case EBUSY: return "mount device busy"; #endif #ifdef ECHILD case ECHILD: return "no children"; #endif #ifdef ECHRNG case ECHRNG: return "channel number out of range"; #endif #ifdef ECOMM case ECOMM: return "communication error on send"; #endif #ifdef ECONNABORTED case ECONNABORTED: return "software caused connection abort"; #endif #ifdef ECONNREFUSED case ECONNREFUSED: return "connection refused"; #endif #ifdef ECONNRESET case ECONNRESET: return "connection reset by peer"; #endif #if defined(EDEADLK) && (!defined(EWOULDBLOCK) || (EDEADLK != EWOULDBLOCK)) case EDEADLK: return "resource deadlock avoided"; #endif #ifdef EDEADLOCK case EDEADLOCK: return "resource deadlock avoided"; #endif #ifdef EDESTADDRREQ case EDESTADDRREQ: return "destination address required"; #endif #ifdef EDIRTY case EDIRTY: return "mounting a dirty fs w/o force"; #endif #ifdef EDOM case EDOM: return "math argument out of range"; #endif #ifdef EDOTDOT case EDOTDOT: return "cross mount point"; #endif #ifdef EDQUOT case EDQUOT: return "disk quota exceeded"; #endif #ifdef EDUPPKG case EDUPPKG: return "duplicate package name"; #endif #ifdef EEXIST case EEXIST: return "file already exists"; #endif #ifdef EFAULT case EFAULT: return "bad address in system call argument"; #endif #ifdef EFBIG case EFBIG: return "file too large"; #endif #ifdef EHOSTDOWN case EHOSTDOWN: return "host is down"; #endif #ifdef EHOSTUNREACH case EHOSTUNREACH: return "host is unreachable"; #endif #ifdef EIDRM case EIDRM: return "identifier removed"; #endif #ifdef EINIT case EINIT: return "initialization error"; #endif #ifdef EINPROGRESS case EINPROGRESS: return "operation now in progress"; #endif #ifdef EINTR case EINTR: return "interrupted system call"; #endif #ifdef EINVAL case EINVAL: return "invalid argument"; #endif #ifdef EIO case EIO: return "I/O error"; #endif #ifdef EISCONN case EISCONN: return "socket is already connected"; #endif #ifdef EISDIR case EISDIR: return "illegal operation on a directory"; #endif #ifdef EISNAME case EISNAM: return "is a name file"; #endif #ifdef ELBIN case ELBIN: return "ELBIN"; #endif #ifdef EL2HLT case EL2HLT: return "level 2 halted"; #endif #ifdef EL2NSYNC case EL2NSYNC: return "level 2 not synchronized"; #endif #ifdef EL3HLT case EL3HLT: return "level 3 halted"; #endif #ifdef EL3RST case EL3RST: return "level 3 reset"; #endif #ifdef ELIBACC case ELIBACC: return "can not access a needed shared library"; #endif #ifdef ELIBBAD case ELIBBAD: return "accessing a corrupted shared library"; #endif #ifdef ELIBEXEC case ELIBEXEC: return "can not exec a shared library directly"; #endif #ifdef ELIBMAX case ELIBMAX: return "attempting to link in more shared libraries than system limit"; #endif #ifdef ELIBSCN case ELIBSCN: return ".lib section in a.out corrupted"; #endif #ifdef ELNRNG case ELNRNG: return "link number out of range"; #endif #ifdef ELOOP case ELOOP: return "too many levels of symbolic links"; #endif #ifdef EMFILE case EMFILE: return "too many open files"; #endif #ifdef EMLINK case EMLINK: return "too many links"; #endif #ifdef EMSGSIZE case EMSGSIZE: return "message too long"; #endif #ifdef EMULTIHOP case EMULTIHOP: return "multihop attempted"; #endif #ifdef ENAMETOOLONG case ENAMETOOLONG: return "file name too long"; #endif #ifdef ENAVAIL case ENAVAIL: return "not available"; #endif #ifdef ENET case ENET: return "ENET"; #endif #ifdef ENETDOWN case ENETDOWN: return "network is down"; #endif #ifdef ENETRESET case ENETRESET: return "network dropped connection on reset"; #endif #ifdef ENETUNREACH case ENETUNREACH: return "network is unreachable"; #endif #ifdef ENFILE case ENFILE: return "file table overflow"; #endif #ifdef ENOANO case ENOANO: return "anode table overflow"; #endif #if defined(ENOBUFS) && (!defined(ENOSR) || (ENOBUFS != ENOSR)) case ENOBUFS: return "no buffer space available"; #endif #ifdef ENOCSI case ENOCSI: return "no CSI structure available"; #endif #ifdef ENODATA case ENODATA: return "no data available"; #endif #ifdef ENODEV case ENODEV: return "no such device"; #endif #ifdef ENOENT case ENOENT: return "no such file or directory"; #endif #ifdef ENOEXEC case ENOEXEC: return "exec format error"; #endif #ifdef ENOLCK case ENOLCK: return "no locks available"; #endif #ifdef ENOLINK case ENOLINK: return "link has be severed"; #endif #ifdef ENOMEM case ENOMEM: return "not enough memory"; #endif #ifdef ENOMSG case ENOMSG: return "no message of desired type"; #endif #ifdef ENONET case ENONET: return "machine is not on the network"; #endif #ifdef ENOPKG case ENOPKG: return "package not installed"; #endif #ifdef ENOPROTOOPT case ENOPROTOOPT: return "bad proocol option"; #endif #ifdef ENOSPC case ENOSPC: return "no space left on device"; #endif #ifdef ENOSR case ENOSR: return "out of stream resources"; #endif #ifdef ENOSTR case ENOSTR: return "not a stream device"; #endif #ifdef ENOSYM case ENOSYM: return "unresolved symbol name"; #endif #ifdef ENOSYS case ENOSYS: return "function not implemented"; #endif #ifdef ENOTBLK case ENOTBLK: return "block device required"; #endif #ifdef ENOTCONN case ENOTCONN: return "socket is not connected"; #endif #ifdef ENOTDIR case ENOTDIR: return "not a directory"; #endif #ifdef ENOTEMPTY case ENOTEMPTY: return "directory not empty"; #endif #ifdef ENOTNAM case ENOTNAM: return "not a name file"; #endif #ifdef ENOTSOCK case ENOTSOCK: return "socket operation on non-socket"; #endif #ifdef ENOTTY case ENOTTY: return "inappropriate device for ioctl"; #endif #ifdef ENOTUNIQ case ENOTUNIQ: return "name not unique on network"; #endif #ifdef ENXIO case ENXIO: return "no such device or address"; #endif #ifdef EOPNOTSUPP case EOPNOTSUPP: return "operation not supported on socket"; #endif #ifdef EPERM case EPERM: return "not owner"; #endif #ifdef EPFNOSUPPORT case EPFNOSUPPORT: return "protocol family not supported"; #endif #ifdef EPIPE case EPIPE: return "broken pipe"; #endif #ifdef EPROCLIM case EPROCLIM: return "too many processes"; #endif #ifdef EPROCUNAVAIL case EPROCUNAVAIL: return "bad procedure for program"; #endif #ifdef EPROGMISMATCH case EPROGMISMATCH: return "program version wrong"; #endif #ifdef EPROGUNAVAIL case EPROGUNAVAIL: return "RPC program not available"; #endif #ifdef EPROTO case EPROTO: return "protocol error"; #endif #ifdef EPROTONOSUPPORT case EPROTONOSUPPORT: return "protocol not suppored"; #endif #ifdef EPROTOTYPE case EPROTOTYPE: return "protocol wrong type for socket"; #endif #ifdef ERANGE case ERANGE: return "math result unrepresentable"; #endif #if defined(EREFUSED) && (!defined(ECONNREFUSED) || (EREFUSED != ECONNREFUSED)) case EREFUSED: return "EREFUSED"; #endif #ifdef EREMCHG case EREMCHG: return "remote address changed"; #endif #ifdef EREMDEV case EREMDEV: return "remote device"; #endif #ifdef EREMOTE case EREMOTE: return "pathname hit remote file system"; #endif #ifdef EREMOTEIO case EREMOTEIO: return "remote i/o error"; #endif #ifdef EREMOTERELEASE case EREMOTERELEASE: return "EREMOTERELEASE"; #endif #ifdef EROFS case EROFS: return "read-only file system"; #endif #ifdef ERPCMISMATCH case ERPCMISMATCH: return "RPC version is wrong"; #endif #ifdef ERREMOTE case ERREMOTE: return "object is remote"; #endif #ifdef ESHUTDOWN case ESHUTDOWN: return "can't send afer socket shutdown"; #endif #ifdef ESOCKTNOSUPPORT case ESOCKTNOSUPPORT: return "socket type not supported"; #endif #ifdef ESPIPE case ESPIPE: return "invalid seek"; #endif #ifdef ESRCH case ESRCH: return "no such process"; #endif #ifdef ESRMNT case ESRMNT: return "srmount error"; #endif #ifdef ESTALE case ESTALE: return "stale remote file handle"; #endif #ifdef ESUCCESS case ESUCCESS: return "Error 0"; #endif #ifdef ETIME case ETIME: return "timer expired"; #endif #ifdef ETIMEDOUT case ETIMEDOUT: return "connection timed out"; #endif #ifdef ETOOMANYREFS case ETOOMANYREFS: return "too many references: can't splice"; #endif #ifdef ETXTBSY case ETXTBSY: return "text file or pseudo-device busy"; #endif #ifdef EUCLEAN case EUCLEAN: return "structure needs cleaning"; #endif #ifdef EUNATCH case EUNATCH: return "protocol driver not attached"; #endif #ifdef EUSERS case EUSERS: return "too many users"; #endif #ifdef EVERSION case EVERSION: return "version mismatch"; #endif #if defined(EWOULDBLOCK) && (!defined(EAGAIN) || (EWOULDBLOCK != EAGAIN)) case EWOULDBLOCK: return "operation would block"; #endif #ifdef EXDEV case EXDEV: return "cross-domain link"; #endif #ifdef EXFULL case EXFULL: return "message tables full"; #endif } #endif /* ! NO_SYS_ERRLIST */ sprintf(msg, "unknown error (%d)", error); return msg; } tcl7.4b4/compat/strncasecmp.c010044400630510000012000000061420567764705000170160ustar00ousterstaff00002300000001/* * strncasecmp.c -- * * Source code for the "strncasecmp" library routine. * * Copyright (c) 1988-1993 The Regents of the University of California. * Copyright (c) 1995 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ static char sccsid[] = "@(#) strncasecmp.c 1.1 94/12/26 15:13:47"; /* *---------------------------------------------------------------------- * * strncasecmp -- * * Compares two strings, ignoring case differences. * * Results: * Compares up to length chars of s1 and s2, returning -1, 0, or 1 * if s1 is lexicographically less than, equal to, or greater * than s2 over those characters. * * Side effects: * None. * *---------------------------------------------------------------------- */ int strncasecmp(s1, s2, length) char *s1; /* First string. */ char *s2; /* Second string. */ int length; /* Maximum number of characters to compare * (stop earlier if the end of either string * is reached). */ { unsigned char u1, u2; /* * This array is designed for mapping upper and lower case letter * together for a case independent comparison. The mappings are * based upon ASCII character sequences. */ static unsigned char charmap[] = { 0x00, 0x01, 0x02, 0x03, 0x04, 0x05, 0x06, 0x07, 0x08, 0x09, 0x0a, 0x0b, 0x0c, 0x0d, 0x0e, 0x0f, 0x10, 0x11, 0x12, 0x13, 0x14, 0x15, 0x16, 0x17, 0x18, 0x19, 0x1a, 0x1b, 0x1c, 0x1d, 0x1e, 0x1f, 0x20, 0x21, 0x22, 0x23, 0x24, 0x25, 0x26, 0x27, 0x28, 0x29, 0x2a, 0x2b, 0x2c, 0x2d, 0x2e, 0x2f, 0x30, 0x31, 0x32, 0x33, 0x34, 0x35, 0x36, 0x37, 0x38, 0x39, 0x3a, 0x3b, 0x3c, 0x3d, 0x3e, 0x3f, 0x40, 0x61, 0x62, 0x63, 0x64, 0x65, 0x66, 0x67, 0x68, 0x69, 0x6a, 0x6b, 0x6c, 0x6d, 0x6e, 0x6f, 0x70, 0x71, 0x72, 0x73, 0x74, 0x75, 0x76, 0x77, 0x78, 0x79, 0x7a, 0x5b, 0x5c, 0x5d, 0x5e, 0x5f, 0x60, 0x61, 0x62, 0x63, 0x64, 0x65, 0x66, 0x67, 0x68, 0x69, 0x6a, 0x6b, 0x6c, 0x6d, 0x6e, 0x6f, 0x70, 0x71, 0x72, 0x73, 0x74, 0x75, 0x76, 0x77, 0x78, 0x79, 0x7a, 0x7b, 0x7c, 0x7d, 0x7e, 0x7f, 0x80, 0x81, 0x82, 0x83, 0x84, 0x85, 0x86, 0x87, 0x88, 0x89, 0x8a, 0x8b, 0x8c, 0x8d, 0x8e, 0x8f, 0x90, 0x91, 0x92, 0x93, 0x94, 0x95, 0x96, 0x97, 0x98, 0x99, 0x9a, 0x9b, 0x9c, 0x9d, 0x9e, 0x9f, 0xa0, 0xa1, 0xa2, 0xa3, 0xa4, 0xa5, 0xa6, 0xa7, 0xa8, 0xa9, 0xaa, 0xab, 0xac, 0xad, 0xae, 0xaf, 0xb0, 0xb1, 0xb2, 0xb3, 0xb4, 0xb5, 0xb6, 0xb7, 0xb8, 0xb9, 0xba, 0xbb, 0xbc, 0xbd, 0xbe, 0xbf, 0xc0, 0xe1, 0xe2, 0xe3, 0xe4, 0xc5, 0xe6, 0xe7, 0xe8, 0xe9, 0xea, 0xeb, 0xec, 0xed, 0xee, 0xef, 0xf0, 0xf1, 0xf2, 0xf3, 0xf4, 0xf5, 0xf6, 0xf7, 0xf8, 0xf9, 0xfa, 0xdb, 0xdc, 0xdd, 0xde, 0xdf, 0xe0, 0xe1, 0xe2, 0xe3, 0xe4, 0xe5, 0xe6, 0xe7, 0xe8, 0xe9, 0xea, 0xeb, 0xec, 0xed, 0xee, 0xef, 0xf0, 0xf1, 0xf2, 0xf3, 0xf4, 0xf5, 0xf6, 0xf7, 0xf8, 0xf9, 0xfa, 0xfb, 0xfc, 0xfd, 0xfe, 0xff, }; for (; length != 0; length--, s1++, s2++) { u1 = (unsigned char) *s1; u2 = (unsigned char) *s2; if (charmap[u1] != charmap[u2]) { return charmap[u1] - charmap[u2]; } if (u1 == '\0') { return 0; } } return 0; } s1 and s2, returning -1, 0, or 1 * if s1 is lexicographically less than, equal to, or greater * than s2 over those characters. * * Side effects: * None. * *---------------------------------------------------------------------- */ int strncasecmp(s1, s2, length) char *s1; /* First string. */ char *s2; /* Second string. */ int length; /* Maximum number of characters to compare * (tcl7.4b4/compat/strstr.c010044400630510000012000000031650567764646100160440ustar00ousterstaff00002300000001/* * strstr.c -- * * Source code for the "strstr" library routine. * * Copyright (c) 1988-1993 The Regents of the University of California. * Copyright (c) 1994 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #ifndef lint static char sccsid[] = "@(#) strstr.c 1.3 94/12/17 16:26:23"; #endif /* not lint */ /* *---------------------------------------------------------------------- * * strstr -- * * Locate the first instance of a substring in a string. * * Results: * If string contains substring, the return value is the * location of the first matching instance of substring * in string. If string doesn't contain substring, the * return value is 0. Matching is done on an exact * character-for-character basis with no wildcards or special * characters. * * Side effects: * None. * *---------------------------------------------------------------------- */ char * strstr(string, substring) register char *string; /* String to search. */ char *substring; /* Substring to try to find in string. */ { register char *a, *b; /* First scan quickly through the two strings looking for a * single-character match. When it's found, then compare the * rest of the substring. */ b = substring; if (*b == 0) { return string; } for ( ; *string != 0; string += 1) { if (*string != *b) { continue; } a = string; while (1) { if (*b == 0) { return string; } if (*a++ != *b++) { break; } } b = substring; } return (char *) 0; } tcl7.4b4/compat/strtod.c010044400630510000012000000134530575301043600160010ustar00ousterstaff00002300000001/* * strtod.c -- * * Source code for the "strtod" library procedure. * * Copyright (c) 1988-1993 The Regents of the University of California. * Copyright (c) 1994 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #ifndef lint static char sccsid[] = "@(#) strtod.c 1.7 94/12/17 16:26:24"; #endif /* not lint */ #include "tcl.h" #ifdef NO_STDLIB_H # include "compat/stdlib.h" #else # include #endif #include #ifndef TRUE #define TRUE 1 #define FALSE 0 #endif #ifndef NULL #define NULL 0 #endif static int maxExponent = 511; /* Largest possible base 10 exponent. Any * exponent larger than this will already * produce underflow or overflow, so there's * no need to worry about additional digits. */ static double powersOf10[] = { /* Table giving binary powers of 10. Entry */ 10., /* is 10^2^i. Used to convert decimal */ 100., /* exponents into floating-point numbers. */ 1.0e4, 1.0e8, 1.0e16, 1.0e32, 1.0e64, 1.0e128, 1.0e256 }; /* *---------------------------------------------------------------------- * * strtod -- * * This procedure converts a floating-point number from an ASCII * decimal representation to internal double-precision format. * * Results: * The return value is the double-precision floating-point * representation of the characters in string. If endPtr isn't * NULL, then *endPtr is filled in with the address of the * next character after the last one that was part of the * floating-point number. * * Side effects: * None. * *---------------------------------------------------------------------- */ double strtod(string, endPtr) CONST char *string; /* A decimal ASCII floating-point number, * optionally preceded by white space. * Must have form "-I.FE-X", where I is the * integer part of the mantissa, F is the * fractional part of the mantissa, and X * is the exponent. Either of the signs * may be "+", "-", or omitted. Either I * or F may be omitted, or both. The decimal * point isn't necessary unless F is present. * The "E" may actually be an "e". E and X * may both be omitted (but not just one). */ char **endPtr; /* If non-NULL, store terminating character's * address here. */ { int sign, expSign = FALSE; double fraction, dblExp, *d; register CONST char *p; register int c; int exp = 0; /* Exponent read from "EX" field. */ int fracExp = 0; /* Exponent that derives from the fractional * part. Under normal circumstatnces, it is * the negative of the number of digits in F. * However, if I is very long, the last digits * of I get dropped (otherwise a long I with a * large negative exponent could cause an * unnecessary overflow on I alone). In this * case, fracExp is incremented one for each * dropped digit. */ int mantSize; /* Number of digits in mantissa. */ int decPt; /* Number of mantissa digits BEFORE decimal * point. */ CONST char *pExp; /* Temporarily holds location of exponent * in string. */ /* * Strip off leading blanks and check for a sign. */ p = string; while (isspace(*p)) { p += 1; } if (*p == '-') { sign = TRUE; p += 1; } else { if (*p == '+') { p += 1; } sign = FALSE; } /* * Count the number of digits in the mantissa (including the decimal * point), and also locate the decimal point. */ decPt = -1; for (mantSize = 0; ; mantSize += 1) { c = *p; if (!isdigit(c)) { if ((c != '.') || (decPt >= 0)) { break; } decPt = mantSize; } p += 1; } /* * Now suck up the digits in the mantissa. Use two integers to * collect 9 digits each (this is faster than using floating-point). * If the mantissa has more than 18 digits, ignore the extras, since * they can't affect the value anyway. */ pExp = p; p -= mantSize; if (decPt < 0) { decPt = mantSize; } else { mantSize -= 1; /* One of the digits was the point. */ } if (mantSize > 18) { fracExp = decPt - 18; mantSize = 18; } else { fracExp = decPt - mantSize; } if (mantSize == 0) { fraction = 0.0; p = string; goto done; } else { int frac1, frac2; frac1 = 0; for ( ; mantSize > 9; mantSize -= 1) { c = *p; p += 1; if (c == '.') { c = *p; p += 1; } frac1 = 10*frac1 + (c - '0'); } frac2 = 0; for (; mantSize > 0; mantSize -= 1) { c = *p; p += 1; if (c == '.') { c = *p; p += 1; } frac2 = 10*frac2 + (c - '0'); } fraction = (1.0e9 * frac1) + frac2; } /* * Skim off the exponent. */ p = pExp; if ((*p == 'E') || (*p == 'e')) { p += 1; if (*p == '-') { expSign = TRUE; p += 1; } else { if (*p == '+') { p += 1; } expSign = FALSE; } while (isdigit(*p)) { exp = exp * 10 + (*p - '0'); p += 1; } } if (expSign) { exp = fracExp - exp; } else { exp = fracExp + exp; } /* * Generate a floating-point number that represents the exponent. * Do this by processing the exponent one bit at a time to combine * many powers of 2 of 10. Then combine the exponent with the * fraction. */ if (exp < 0) { expSign = TRUE; exp = -exp; } else { expSign = FALSE; } if (exp > maxExponent) { exp = maxExponent; } dblExp = 1.0; for (d = powersOf10; exp != 0; exp >>= 1, d += 1) { if (exp & 01) { dblExp *= *d; } } if (expSign) { fraction /= dblExp; } else { fraction *= dblExp; } done: if (endPtr != NULL) { *endPtr = (char *) p; } if (sign) { return -fraction; } return fraction; } tcl7.4b4/compat/strtol.c010044400630510000012000000037170567470066200160240ustar00ousterstaff00002300000001/* * strtol.c -- * * Source code for the "strtol" library procedure. * * Copyright (c) 1988 The Regents of the University of California. * Copyright (c) 1994 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #ifndef lint static char sccsid[] = "@(#) strtol.c 1.3 94/12/17 16:26:25"; #endif /* not lint */ #include /* *---------------------------------------------------------------------- * * strtol -- * * Convert an ASCII string into an integer. * * Results: * The return value is the integer equivalent of string. If endPtr * is non-NULL, then *endPtr is filled in with the character * after the last one that was part of the integer. If string * doesn't contain a valid integer value, then zero is returned * and *endPtr is set to string. * * Side effects: * None. * *---------------------------------------------------------------------- */ long int strtol(string, endPtr, base) char *string; /* String of ASCII digits, possibly * preceded by white space. For bases * greater than 10, either lower- or * upper-case digits may be used. */ char **endPtr; /* Where to store address of terminating * character, or NULL. */ int base; /* Base for conversion. Must be less * than 37. If 0, then the base is chosen * from the leading characters of string: * "0x" means hex, "0" means octal, anything * else means decimal. */ { register char *p; int result; /* * Skip any leading blanks. */ p = string; while (isspace(*p)) { p += 1; } /* * Check for a sign. */ if (*p == '-') { p += 1; result = -(strtoul(p, endPtr, base)); } else { if (*p == '+') { p += 1; } result = strtoul(p, endPtr, base); } if ((result == 0) && (endPtr != 0) && (*endPtr == p)) { *endPtr = string; } return result; } tcl7.4b4/compat/strtoul.c010044400630510000012000000077220567470066200162110ustar00ousterstaff00002300000001/* * strtoul.c -- * * Source code for the "strtoul" library procedure. * * Copyright (c) 1988 The Regents of the University of California. * Copyright (c) 1994 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #ifndef lint static char sccsid[] = "@(#) strtoul.c 1.4 94/12/17 16:26:26"; #endif /* not lint */ #include /* * The table below is used to convert from ASCII digits to a * numerical equivalent. It maps from '0' through 'z' to integers * (100 for non-digit characters). */ static char cvtIn[] = { 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, /* '0' - '9' */ 100, 100, 100, 100, 100, 100, 100, /* punctuation */ 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, /* 'A' - 'Z' */ 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 100, 100, 100, 100, 100, 100, /* punctuation */ 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, /* 'a' - 'z' */ 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35}; /* *---------------------------------------------------------------------- * * strtoul -- * * Convert an ASCII string into an integer. * * Results: * The return value is the integer equivalent of string. If endPtr * is non-NULL, then *endPtr is filled in with the character * after the last one that was part of the integer. If string * doesn't contain a valid integer value, then zero is returned * and *endPtr is set to string. * * Side effects: * None. * *---------------------------------------------------------------------- */ unsigned long int strtoul(string, endPtr, base) char *string; /* String of ASCII digits, possibly * preceded by white space. For bases * greater than 10, either lower- or * upper-case digits may be used. */ char **endPtr; /* Where to store address of terminating * character, or NULL. */ int base; /* Base for conversion. Must be less * than 37. If 0, then the base is chosen * from the leading characters of string: * "0x" means hex, "0" means octal, anything * else means decimal. */ { register char *p; register unsigned long int result = 0; register unsigned digit; int anyDigits = 0; /* * Skip any leading blanks. */ p = string; while (isspace(*p)) { p += 1; } /* * If no base was provided, pick one from the leading characters * of the string. */ if (base == 0) { if (*p == '0') { p += 1; if (*p == 'x') { p += 1; base = 16; } else { /* * Must set anyDigits here, otherwise "0" produces a * "no digits" error. */ anyDigits = 1; base = 8; } } else base = 10; } else if (base == 16) { /* * Skip a leading "0x" from hex numbers. */ if ((p[0] == '0') && (p[1] == 'x')) { p += 2; } } /* * Sorry this code is so messy, but speed seems important. Do * different things for base 8, 10, 16, and other. */ if (base == 8) { for ( ; ; p += 1) { digit = *p - '0'; if (digit > 7) { break; } result = (result << 3) + digit; anyDigits = 1; } } else if (base == 10) { for ( ; ; p += 1) { digit = *p - '0'; if (digit > 9) { break; } result = (10*result) + digit; anyDigits = 1; } } else if (base == 16) { for ( ; ; p += 1) { digit = *p - '0'; if (digit > ('z' - '0')) { break; } digit = cvtIn[digit]; if (digit > 15) { break; } result = (result << 4) + digit; anyDigits = 1; } } else { for ( ; ; p += 1) { digit = *p - '0'; if (digit > ('z' - '0')) { break; } digit = cvtIn[digit]; if (digit >= base) { break; } result = result*base + digit; anyDigits = 1; } } /* * See if there were any digits at all. */ if (!anyDigits) { p = string; } if (endPtr != 0) { *endPtr = p; } return result; } tcl7.4b4/compat/tmpnam.c010044400630510000012000000017520567470057300157670ustar00ousterstaff00002300000001/* * Copyright (c) 1988 Regents of the University of California. * All rights reserved. * * Redistribution and use in source and binary forms are permitted * provided that this notice is preserved and that due credit is given * to the University of California at Berkeley. The name of the University * may not be used to endorse or promote products derived from this * software without specific written prior permission. This software * is provided ``as is'' without express or implied warranty. */ static char sccsid[] = "@(#) tmpnam.c 1.1 94/08/09 13:17:13"; #include #include #include #include /* * Use /tmp instead of /usr/tmp, because L_tmpname is only 14 chars * on some machines (like NeXT machines) and /usr/tmp will cause * buffer overflows. */ #define P_tmpdir "/tmp" char * tmpnam(s) char *s; { static char name[50]; char *mktemp(); if (!s) s = name; (void)sprintf(s, "%s/XXXXXX", P_tmpdir); return(mktemp(s)); } tcl7.4b4/compat/waitpid.c010044400630510000012000000111550567470066200161310ustar00ousterstaff00002300000001/* * waitpid.c -- * * This procedure emulates the POSIX waitpid kernel call on * BSD systems that don't have waitpid but do have wait3. * This code is based on a prototype version written by * Mark Diekhans and Karl Lehenbauer. * * Copyright (c) 1993 The Regents of the University of California. * Copyright (c) 1994 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #ifndef lint static char sccsid[] = "@(#) waitpid.c 1.7 94/12/17 16:26:27"; #endif /* not lint */ #include "tclInt.h" #include "tclPort.h" /* * A linked list of the following structures is used to keep track * of processes for which we received notification from the kernel, * but the application hasn't waited for them yet (this can happen * because wait may not return the process we really want). We * save the information here until the application finally does * wait for the process. */ typedef struct WaitInfo { int pid; /* Pid of process that exited. */ WAIT_STATUS_TYPE status; /* Status returned when child exited * or suspended. */ struct WaitInfo *nextPtr; /* Next in list of exited processes. */ } WaitInfo; static WaitInfo *deadList = NULL; /* First in list of all dead * processes. */ /* *---------------------------------------------------------------------- * * waitpid -- * * This procedure emulates the functionality of the POSIX * waitpid kernel call, using the BSD wait3 kernel call. * Note: it doesn't emulate absolutely all of the waitpid * functionality, in that it doesn't support pid's of 0 * or < -1. * * Results: * -1 is returned if there is an error in the wait kernel call. * Otherwise the pid of an exited or suspended process is * returned and *statusPtr is set to the status value of the * process. * * Side effects: * None. * *---------------------------------------------------------------------- */ #ifdef waitpid # undef waitpid #endif int waitpid(pid, statusPtr, options) int pid; /* The pid to wait on. Must be -1 or * greater than zero. */ int *statusPtr; /* Where to store wait status for the * process. */ int options; /* OR'ed combination of WNOHANG and * WUNTRACED. */ { register WaitInfo *waitPtr, *prevPtr; int result; WAIT_STATUS_TYPE status; if ((pid < -1) || (pid == 0)) { errno = EINVAL; return -1; } /* * See if there's a suitable process that has already stopped or * exited. If so, remove it from the list of exited processes and * return its information. */ for (waitPtr = deadList, prevPtr = NULL; waitPtr != NULL; prevPtr = waitPtr, waitPtr = waitPtr->nextPtr) { if ((pid != waitPtr->pid) && (pid != -1)) { continue; } if (!(options & WUNTRACED) && (WIFSTOPPED(waitPtr->status))) { continue; } result = waitPtr->pid; *statusPtr = *((int *) &waitPtr->status); if (prevPtr == NULL) { deadList = waitPtr->nextPtr; } else { prevPtr->nextPtr = waitPtr->nextPtr; } ckfree((char *) waitPtr); return result; } /* * Wait for any process to stop or exit. If it's an acceptable one * then return it to the caller; otherwise store information about it * in the list of exited processes and try again. On systems that * have only wait but not wait3, there are several situations we can't * handle, but we do the best we can (e.g. can still handle some * combinations of options by invoking wait instead of wait3). */ while (1) { #if NO_WAIT3 if (options & WNOHANG) { return 0; } if (options != 0) { errno = EINVAL; return -1; } result = wait(&status); #else result = wait3(&status, options, 0); #endif if ((result == -1) && (errno == EINTR)) { continue; } if (result <= 0) { return result; } if ((pid != result) && (pid != -1)) { goto saveInfo; } if (!(options & WUNTRACED) && (WIFSTOPPED(status))) { goto saveInfo; } *statusPtr = *((int *) &status); return result; /* * Can't return this info to caller. Save it in the list of * stopped or exited processes. Tricky point: first check for * an existing entry for the process and overwrite it if it * exists (e.g. a previously stopped process might now be dead). */ saveInfo: for (waitPtr = deadList; waitPtr != NULL; waitPtr = waitPtr->nextPtr) { if (waitPtr->pid == result) { waitPtr->status = status; goto waitAgain; } } waitPtr = (WaitInfo *) ckalloc(sizeof(WaitInfo)); waitPtr->pid = result; waitPtr->status = status; waitPtr->nextPtr = deadList; deadList = waitPtr; waitAgain: continue; } } tcl7.4b4/compat/dirent.h010044400630510000012000000010400567470066000157500ustar00ousterstaff00002300000001/* * dirent.h -- * * This file is a replacement for in systems that * support the old BSD-style with a "struct direct". * * Copyright (c) 1991 The Regents of the University of California. * Copyright (c) 1994 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * @(#) dirent.h 1.3 94/12/17 16:26:15 */ #ifndef _DIRENT #define _DIRENT #include #define dirent direct #endif /* _DIRENT */ tcl7.4b4/compat/dirent2.h010044400630510000012000000025610567470066000160430ustar00ousterstaff00002300000001/* * dirent.h -- * * Declarations of a library of directory-reading procedures * in the POSIX style ("struct dirent"). * * Copyright (c) 1991 The Regents of the University of California. * Copyright (c) 1994 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * @(#) dirent2.h 1.3 94/12/17 16:26:16 */ #ifndef _DIRENT #define _DIRENT #ifndef _TCL #include #endif /* * Dirent structure, which holds information about a single * directory entry. */ #define MAXNAMLEN 255 #define DIRBLKSIZ 512 struct dirent { long d_ino; /* Inode number of entry */ short d_reclen; /* Length of this record */ short d_namlen; /* Length of string in d_name */ char d_name[MAXNAMLEN + 1]; /* Name must be no longer than this */ }; /* * State that keeps track of the reading of a directory (clients * should never look inside this structure; the fields should * only be accessed by the library procedures). */ typedef struct _dirdesc { int dd_fd; long dd_loc; long dd_size; char dd_buf[DIRBLKSIZ]; } DIR; /* * Procedures defined for reading directories: */ extern void closedir _ANSI_ARGS_((DIR *dirp)); extern DIR * opendir _ANSI_ARGS_((char *name)); extern struct dirent * readdir _ANSI_ARGS_((DIR *dirp)); #endif /* _DIRENT */ tcl7.4b4/compat/float.h010044400630510000012000000010570567470066000156000ustar00ousterstaff00002300000001/* * float.h -- * * This is a dummy header file to #include in Tcl when there * is no float.h in /usr/include. Right now this file is empty: * Tcl contains #ifdefs to deal with the lack of definitions; * all it needs is for the #include statement to work. * * Copyright (c) 1993 The Regents of the University of California. * Copyright (c) 1994 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * @(#) float.h 1.2 94/12/17 16:26:17 */ tcl7.4b4/compat/limits.h010044400630510000012000000012500567470066100157700ustar00ousterstaff00002300000001/* * limits.h -- * * This is a dummy header file to #include in Tcl when there * is no limits.h in /usr/include. There are only a few * definitions here; also see tclPort.h, which already * #defines some of the things here if they're not arleady * defined. * * Copyright (c) 1991 The Regents of the University of California. * Copyright (c) 1994 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * @(#) limits.h 1.6 94/12/17 16:26:19 */ #define LONG_MIN 0x80000000 #define LONG_MAX 0x7fffffff #define INT_MIN 0x80000000 #define INT_MAX 0x7fffffff e tclPort.h, which already * #defines some of the things here if they're not arleady * defined. * * Copyright (c) 1991 The Regents of the University of California. * Copyright (c) 1994 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTtcl7.4b4/compat/stdlib.h010044400630510000012000000032470567470066100157600ustar00ousterstaff00002300000001/* * stdlib.h -- * * Declares facilities exported by the "stdlib" portion of * the C library. This file isn't complete in the ANSI-C * sense; it only declares things that are needed by Tcl. * This file is needed even on many systems with their own * stdlib.h (e.g. SunOS) because not all stdlib.h files * declare all the procedures needed here (such as strtod). * * Copyright (c) 1991 The Regents of the University of California. * Copyright (c) 1994 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * @(#) stdlib.h 1.9 94/12/17 16:26:20 */ #ifndef _STDLIB #define _STDLIB #include extern void abort _ANSI_ARGS_((void)); extern double atof _ANSI_ARGS_((CONST char *string)); extern int atoi _ANSI_ARGS_((CONST char *string)); extern long atol _ANSI_ARGS_((CONST char *string)); extern char * calloc _ANSI_ARGS_((unsigned int numElements, unsigned int size)); extern void exit _ANSI_ARGS_((int status)); extern int free _ANSI_ARGS_((char *blockPtr)); extern char * getenv _ANSI_ARGS_((CONST char *name)); extern char * malloc _ANSI_ARGS_((unsigned int numBytes)); extern void qsort _ANSI_ARGS_((VOID *base, int n, int size, int (*compar)(CONST VOID *element1, CONST VOID *element2))); extern char * realloc _ANSI_ARGS_((char *ptr, unsigned int numBytes)); extern double strtod _ANSI_ARGS_((CONST char *string, char **endPtr)); extern long strtol _ANSI_ARGS_((CONST char *string, char **endPtr, int base)); extern unsigned long strtoul _ANSI_ARGS_((CONST char *string, char **endPtr, int base)); #endif /* _STDLIB */ tcl7.4b4/compat/string.h010044400630510000012000000045520567470066100160050ustar00ousterstaff00002300000001/* * string.h -- * * Declarations of ANSI C library procedures for string handling. * * Copyright (c) 1991-1993 The Regents of the University of California. * Copyright (c) 1994 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * @(#) string.h 1.10 94/12/17 16:26:22 */ #ifndef _STRING #define _STRING #include /* * The following #include is needed to define size_t. (This used to * include sys/stdtypes.h but that doesn't exist on older versions * of SunOS, e.g. 4.0.2, so I'm trying sys/types.h now.... hopefully * it exists everywhere) */ #include extern char * memchr _ANSI_ARGS_((CONST VOID *s, int c, size_t n)); extern int memcmp _ANSI_ARGS_((CONST VOID *s1, CONST VOID *s2, size_t n)); extern char * memcpy _ANSI_ARGS_((VOID *t, CONST VOID *f, size_t n)); extern char * memmove _ANSI_ARGS_((VOID *t, CONST VOID *f, size_t n)); extern char * memset _ANSI_ARGS_((VOID *s, int c, size_t n)); extern int strcasecmp _ANSI_ARGS_((CONST char *s1, CONST char *s2)); extern char * strcat _ANSI_ARGS_((char *dst, CONST char *src)); extern char * strchr _ANSI_ARGS_((CONST char *string, int c)); extern int strcmp _ANSI_ARGS_((CONST char *s1, CONST char *s2)); extern char * strcpy _ANSI_ARGS_((char *dst, CONST char *src)); extern size_t strcspn _ANSI_ARGS_((CONST char *string, CONST char *chars)); extern char * strdup _ANSI_ARGS_((CONST char *string)); extern char * strerror _ANSI_ARGS_((int error)); extern size_t strlen _ANSI_ARGS_((CONST char *string)); extern int strncasecmp _ANSI_ARGS_((CONST char *s1, CONST char *s2, size_t n)); extern char * strncat _ANSI_ARGS_((char *dst, CONST char *src, size_t numChars)); extern int strncmp _ANSI_ARGS_((CONST char *s1, CONST char *s2, size_t nChars)); extern char * strncpy _ANSI_ARGS_((char *dst, CONST char *src, size_t numChars)); extern char * strpbrk _ANSI_ARGS_((CONST char *string, char *chars)); extern char * strrchr _ANSI_ARGS_((CONST char *string, int c)); extern size_t strspn _ANSI_ARGS_((CONST char *string, CONST char *chars)); extern char * strstr _ANSI_ARGS_((CONST char *string, CONST char *substring)); extern char * strtok _ANSI_ARGS_((CONST char *s, CONST char *delim)); #endif /* _STRING */ tcl7.4b4/compat/unistd.h010044400630510000012000000062270567470066200160070ustar00ousterstaff00002300000001/* * unistd.h -- * * Macros, CONSTants and prototypes for Posix conformance. * * Copyright 1989 Regents of the University of California * Permission to use, copy, modify, and distribute this * software and its documentation for any purpose and without * fee is hereby granted, provided that the above copyright * notice appear in all copies. The University of California * makes no representations about the suitability of this * software for any purpose. It is provided "as is" without * express or implied warranty. * * @(#) unistd.h 1.5 94/12/17 16:26:27 */ #ifndef _UNISTD #define _UNISTD #include #ifndef _TCL # include "tcl.h" #endif #ifndef NULL #define NULL 0 #endif /* * Strict POSIX stuff goes here. Extensions go down below, in the * ifndef _POSIX_SOURCE section. */ extern void _exit _ANSI_ARGS_((int status)); extern int access _ANSI_ARGS_((CONST char *path, int mode)); extern int chdir _ANSI_ARGS_((CONST char *path)); extern int chown _ANSI_ARGS_((CONST char *path, uid_t owner, gid_t group)); extern int close _ANSI_ARGS_((int fd)); extern int dup _ANSI_ARGS_((int oldfd)); extern int dup2 _ANSI_ARGS_((int oldfd, int newfd)); extern int execl _ANSI_ARGS_((CONST char *path, ...)); extern int execle _ANSI_ARGS_((CONST char *path, ...)); extern int execlp _ANSI_ARGS_((CONST char *file, ...)); extern int execv _ANSI_ARGS_((CONST char *path, char **argv)); extern int execve _ANSI_ARGS_((CONST char *path, char **argv, char **envp)); extern int execvp _ANSI_ARGS_((CONST char *file, char **argv)); extern pid_t fork _ANSI_ARGS_((void)); extern char *getcwd _ANSI_ARGS_((char *buf, size_t size)); extern gid_t getegid _ANSI_ARGS_((void)); extern uid_t geteuid _ANSI_ARGS_((void)); extern gid_t getgid _ANSI_ARGS_((void)); extern int getgroups _ANSI_ARGS_((int bufSize, int *buffer)); extern pid_t getpid _ANSI_ARGS_((void)); extern uid_t getuid _ANSI_ARGS_((void)); extern int isatty _ANSI_ARGS_((int fd)); extern long lseek _ANSI_ARGS_((int fd, long offset, int whence)); extern int pipe _ANSI_ARGS_((int *fildes)); extern int read _ANSI_ARGS_((int fd, char *buf, size_t size)); extern int setgid _ANSI_ARGS_((gid_t group)); extern int setuid _ANSI_ARGS_((uid_t user)); extern unsigned sleep _ANSI_ARGS_ ((unsigned seconds)); extern char *ttyname _ANSI_ARGS_((int fd)); extern int unlink _ANSI_ARGS_((CONST char *path)); extern int write _ANSI_ARGS_((int fd, CONST char *buf, size_t size)); #ifndef _POSIX_SOURCE extern char *crypt _ANSI_ARGS_((CONST char *, CONST char *)); extern int fchown _ANSI_ARGS_((int fd, uid_t owner, gid_t group)); extern int flock _ANSI_ARGS_((int fd, int operation)); extern int ftruncate _ANSI_ARGS_((int fd, unsigned long length)); extern int readlink _ANSI_ARGS_((CONST char *path, char *buf, int bufsize)); extern int setegid _ANSI_ARGS_((gid_t group)); extern int seteuid _ANSI_ARGS_((uid_t user)); extern int setreuid _ANSI_ARGS_((int ruid, int euid)); extern int symlink _ANSI_ARGS_((CONST char *, CONST char *)); extern int ttyslot _ANSI_ARGS_((void)); extern int truncate _ANSI_ARGS_((CONST char *path, unsigned long length)); extern int vfork _ANSI_ARGS_((void)); #endif /* _POSIX_SOURCE */ #endif /* _UNISTD */ tcl7.4b4/compat/README010044400630510000012000000006520565654036500152060ustar00ousterstaff00002300000001This directory contains various header and code files that are used make Tcl compatible with various releases of UNIX and UNIX-like systems. Typically, files from this directory are used to compile Tcl when a system doesn't contain the corresponding files or when they are known to be incorrect. When the whole world becomes POSIX- compliant this directory should be unnecessary. sccsid = @(#) README 1.2 94/11/04 15:17:09 tcl7.4b4/tests/004077500630510000012000000000000577032351100141765ustar00ousterstaff00002300000001tcl7.4b4/tests/license.terms010044400630510000012000000033060567470030500166720ustar00ousterstaff00002300000001This software is copyrighted by the Regents of the University of California, Sun Microsystems, Inc., and other parties. The following terms apply to all files associated with the software unless explicitly disclaimed in individual files. The authors hereby grant permission to use, copy, modify, distribute, and license this software and its documentation for any purpose, provided that existing copyright notices are retained in all copies and that this notice is included verbatim in any distributions. No written agreement, license, or royalty fee is required for any of the authorized uses. Modifications to this software may be copyrighted by their authors and need not follow the licensing terms described here, provided that the new terms are clearly indicated on the first page of each file where they apply. IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. RESTRICTED RIGHTS: Use, duplication or disclosure by the government is subject to the restrictions as set forth in subparagraph (c) (1) (ii) of the Rights in Technical Data and Computer Software Clause as DFARS 252.227-7013 and FAR 52.227-19. tcl7.4b4/tests/append.test010044400630510000012000000101210567470011600163350ustar00ousterstaff00002300000001# Commands covered: append lappend # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # @(#) append.test 1.12 94/12/17 16:19:43 if {[string compare test [info procs test]] == 1} then {source defs} catch {unset x} test append-1.1 {append command} { catch {unset x} list [append x 1 2 abc "long string"] $x } {{12abclong string} {12abclong string}} test append-1.2 {append command} { set x "" list [append x first] [append x second] [append x third] $x } {first firstsecond firstsecondthird firstsecondthird} test append-1.3 {append command} { set x "abcd" append x } abcd test append-2.1 {long appends} { set x "" for {set i 0} {$i < 1000} {set i [expr $i+1]} { append x "foobar " } set y "foobar" set y "$y $y $y $y $y $y $y $y $y $y" set y "$y $y $y $y $y $y $y $y $y $y" set y "$y $y $y $y $y $y $y $y $y $y " expr {$x == $y} } 1 test append-3.1 {append errors} { list [catch {append} msg] $msg } {1 {wrong # args: should be "append varName ?value value ...?"}} test append-3.2 {append errors} { set x "" list [catch {append x(0) 44} msg] $msg } {1 {can't set "x(0)": variable isn't array}} test append-3.3 {append errors} { catch {unset x} list [catch {append x} msg] $msg } {1 {can't read "x": no such variable}} test append-4.1 {lappend command} { catch {unset x} list [lappend x 1 2 abc "long string"] $x } {{1 2 abc {long string}} {1 2 abc {long string}}} test append-4.2 {lappend command} { set x "" list [lappend x first] [lappend x second] [lappend x third] $x } {first {first second} {first second third} {first second third}} test append-4.3 {lappend command} { proc foo {} { global x set x old unset x lappend x new } set result [foo] rename foo {} set result } {new} test append-4.4 {lappend command} { set x {} lappend x \{\ abc } {\{\ abc} test append-4.5 {lappend command} { set x {} lappend x \{ abc } {\{ abc} test append-4.6 {lappend command} { set x {1 2 3} lappend x } {1 2 3} test append-4.7 {lappend command} { set x "a\{" lappend x abc } "a{ abc" test append-4.8 {lappend command} { set x "\\\{" lappend x abc } "\\{ abc" test append-4.9 {lappend command} { set x " \{" lappend x abc } " {abc" test append-4.10 {lappend command} { set x " \{" lappend x abc } " {abc" test append-4.11 {lappend command} { set x "\{\{\{" lappend x abc } "{{{abc" test append-4.12 {lappend command} { set x "x \{\{\{" lappend x abc } "x {{{abc" test append-4.13 {lappend command} { set x "x\{\{\{" lappend x abc } "x{{{ abc" test append-4.14 {lappend command} { set x " " lappend x abc } " abc" test append-4.15 {lappend command} { set x "\\ " lappend x abc } "\\ abc" test append-4.16 {lappend command} { set x "x " lappend x abc } "x abc" proc check {var size} { set l [llength $var] if {$l != $size} { return "length mismatch: should have been $size, was $l" } for {set i 0} {$i < $size} {set i [expr $i+1]} { set j [lindex $var $i] if {$j != "item $i"} { return "element $i should have been \"item $i\", was \"$j\"" } } return ok } test append-5.1 {long lappends} { set x "" for {set i 0} {$i < 300} {set i [expr $i+1]} { lappend x "item $i" } check $x 300 } ok test append-6.1 {lappend errors} { list [catch {lappend} msg] $msg } {1 {wrong # args: should be "lappend varName ?value value ...?"}} test append-6.2 {lappend errors} { set x "" list [catch {lappend x(0) 44} msg] $msg } {1 {can't set "x(0)": variable isn't array}} test append-6.3 {lappend errors} { catch {unset x} list [catch {lappend x} msg] $msg } {1 {can't read "x": no such variable}} tcl7.4b4/tests/async.test010044400630510000012000000072100572021366000162030ustar00ousterstaff00002300000001# Commands covered: none # # This file contains a collection of tests for Tcl_AsyncCreate and related # library procedures. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # @(#) async.test 1.3 94/12/17 16:19:44 if {[info commands testasync] == {}} { puts "This application hasn't been compiled with the \"testasync\"" puts "command, so I can't test Tcl_AsyncCreate et al." return } if {[string compare test [info procs test]] == 1} then {source defs} proc async1 {result code} { global aresult acode set aresult $result set acode $code return "new result" } proc async2 {result code} { global aresult acode set aresult $result set acode $code return -code error "xyzzy" } proc async3 {result code} { global aresult set aresult "test pattern" return -code $code $result } set handler1 [testasync create async1] set handler2 [testasync create async2] set handler3 [testasync create async3] test async-1.1 {basic async handlers} { set aresult xxx set acode yyy list [catch {testasync mark $handler1 "original" 0} msg] $msg \ $acode $aresult } {0 {new result} 0 original} test async-1.2 {basic async handlers} { set aresult xxx set acode yyy list [catch {testasync mark $handler1 "original" 1} msg] $msg \ $acode $aresult } {0 {new result} 1 original} test async-1.3 {basic async handlers} { set aresult xxx set acode yyy list [catch {testasync mark $handler2 "old" 0} msg] $msg \ $acode $aresult } {1 xyzzy 0 old} test async-1.4 {basic async handlers} { set aresult xxx set acode yyy list [catch {testasync mark $handler2 "old" 3} msg] $msg \ $acode $aresult } {1 xyzzy 3 old} test async-1.5 {basic async handlers} { set aresult xxx list [catch {testasync mark $handler3 "foobar" 0} msg] $msg $aresult } {0 foobar {test pattern}} test async-1.6 {basic async handlers} { set aresult xxx list [catch {testasync mark $handler3 "foobar" 1} msg] $msg $aresult } {1 foobar {test pattern}} proc mult1 {result code} { global x lappend x mult1 return -code 7 mult1 } set hm1 [testasync create mult1] proc mult2 {result code} { global x lappend x mult2 return -code 9 mult2 } set hm2 [testasync create mult2] proc mult3 {result code} { global x hm1 hm2 lappend x [catch {testasync mark $hm2 serial2 0}] lappend x [catch {testasync mark $hm1 serial1 0}] lappend x mult3 return -code 11 mult3 } set hm3 [testasync create mult3] test async-2.1 {multiple handlers} { set x {} list [catch {testasync mark $hm3 "foobar" 5} msg] $msg $x } {9 mult2 {0 0 mult3 mult1 mult2}} proc del1 {result code} { global x hm1 hm2 hm3 hm4 lappend x [catch {testasync mark $hm3 serial2 0}] lappend x [catch {testasync mark $hm1 serial1 0}] lappend x [catch {testasync mark $hm4 serial1 0}] testasync delete $hm1 testasync delete $hm2 testasync delete $hm3 lappend x del1 return -code 13 del1 } proc del2 {result code} { global x lappend x del2 return -code 3 del2 } testasync delete $handler1 testasync delete $hm2 testasync delete $hm3 set hm2 [testasync create del1] set hm3 [testasync create mult2] set hm4 [testasync create del2] test async-3.1 {deleting handlers} { set x {} list [catch {testasync mark $hm2 "foobar" 5} msg] $msg $x } {3 del2 {0 0 0 del1 del2}} testasync delete tcl7.4b4/tests/case.test010044400630510000012000000054310567470011600160110ustar00ousterstaff00002300000001# Commands covered: case # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # @(#) case.test 1.12 94/12/17 16:19:45 if {[string compare test [info procs test]] == 1} then {source defs} test case-1.1 {simple pattern} { case a in a {format 1} b {format 2} c {format 3} default {format 4} } 1 test case-1.2 {simple pattern} { case b a {format 1} b {format 2} c {format 3} default {format 4} } 2 test case-1.3 {simple pattern} { case x in a {format 1} b {format 2} c {format 3} default {format 4} } 4 test case-1.4 {simple pattern} { case x a {format 1} b {format 2} c {format 3} } {} test case-1.5 {simple pattern matches many times} { case b a {format 1} b {format 2} b {format 3} b {format 4} } 2 test case-1.6 {fancier pattern} { case cx a {format 1} *c {format 2} *x {format 3} default {format 4} } 3 test case-1.7 {list of patterns} { case abc in {a b c} {format 1} {def abc ghi} {format 2} } 2 test case-2.1 {error in executed command} { list [catch {case a in a {error "Just a test"} default {format 1}} msg] \ $msg $errorInfo } {1 {Just a test} {Just a test while executing "error "Just a test"" ("a" arm line 1) invoked from within "case a in a {error "Just a test"} default {format 1}"}} test case-2.2 {error: not enough args} { list [catch {case} msg] $msg } {1 {wrong # args: should be "case string ?in? patList body ... ?default body?"}} test case-2.3 {error: pattern with no body} { list [catch {case a b} msg] $msg } {1 {extra case pattern with no body}} test case-2.4 {error: pattern with no body} { list [catch {case a in b {format 1} c} msg] $msg } {1 {extra case pattern with no body}} test case-2.5 {error in default command} { list [catch {case foo in a {error case1} default {error case2} \ b {error case 3}} msg] $msg $errorInfo } {1 case2 {case2 while executing "error case2" ("default" arm line 1) invoked from within "case foo in a {error case1} default {error case2} b {error case 3}"}} test case-3.1 {single-argument form for pattern/command pairs} { case b in { a {format 1} b {format 2} default {format 6} } } {2} test case-3.2 {single-argument form for pattern/command pairs} { case b { a {format 1} b {format 2} default {format 6} } } {2} test case-3.3 {single-argument form for pattern/command pairs} { list [catch {case z in {a 2 b}} msg] $msg } {1 {extra case pattern with no body}} tcl7.4b4/tests/cmdinfo.test010044400630510000012000000043510571654113200165130ustar00ousterstaff00002300000001# Commands covered: none # # This file contains a collection of tests for Tcl_GetCommandInfo, # Tcl_SetCommandInfo, Tcl_CreateCommand, Tcl_DeleteCommand, and # Tcl_NameOfCommand. Sourcing this file into Tcl runs the tests # and generates output for errors. No output means no errors were # found. # # Copyright (c) 1993 The Regents of the University of California. # Copyright (c) 1994-1995 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # @(#) cmdinfo.test 1.3 95/02/09 17:33:14 if {[info commands testcmdinfo] == {}} { puts "This application hasn't been compiled with the \"testcmdinfo\"" puts "command, so I can't test Tcl_GetCommandInfo etc." return } if {[string compare test [info procs test]] == 1} then {source defs} test cmdinfo-1.1 {command procedure and clientData} { testcmdinfo create x1 testcmdinfo get x1 } {CmdProc1 original CmdDelProc1 original} test cmdinfo-1.2 {command procedure and clientData} { testcmdinfo create x1 x1 } {CmdProc1 original} test cmdinfo-1.3 {command procedure and clientData} { testcmdinfo create x1 testcmdinfo modify x1 testcmdinfo get x1 } {CmdProc2 new_command_data CmdDelProc2 new_delete_data} test cmdinfo-1.4 {command procedure and clientData} { testcmdinfo create x1 testcmdinfo modify x1 x1 } {CmdProc2 new_command_data} test cmdinfo-2.1 {command deletion callbacks} { testcmdinfo create x1 testcmdinfo delete x1 } {CmdDelProc1 original} test cmdinfo-2.2 {command deletion callbacks} { testcmdinfo create x1 testcmdinfo modify x1 testcmdinfo delete x1 } {CmdDelProc2 new_delete_data} test cmdinfo-3.1 {Tcl_Get/SetCommandInfo return values} { testcmdinfo get non_existent } {??} test cmdinfo-3.2 {Tcl_Get/SetCommandInfo return values} { testcmdinfo create x1 testcmdinfo modify x1 } 1 test cmdinfo-3.3 {Tcl_Get/SetCommandInfo return values} { testcmdinfo modify non_existent } 0 test cmdinfo-4.1 {Tcl_GetCommandName procedure} { set x [testcmdtoken create x1] rename x1 newName set y [testcmdtoken name $x] rename newName x1 lappend y [testcmdtoken name $x] } {newName x1} catch {rename x1 ""} concat {} tcl7.4b4/tests/concat.test010044400630510000012000000023520567470011600163440ustar00ousterstaff00002300000001# Commands covered: concat # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # @(#) concat.test 1.7 94/12/17 16:19:47 if {[string compare test [info procs test]] == 1} then {source defs} test concat-1.1 {simple concatenation} { concat a b c d e f g } {a b c d e f g} test concat-1.2 {merging lists together} { concat a {b c d} {e f g h} } {a b c d e f g h} test concat-1.3 {merge lists, retain sub-lists} { concat a {b {c d}} {{e f}} g h } {a b {c d} {e f} g h} test concat-1.4 {special characters} { concat a\{ {b \{c d} \{d } "a{ b \\{c d {d" test concat-2.1 {error: no arguments} { list [catch concat msg] $msg } {0 {}} test concat-3.1 {pruning off extra white space} { concat {} {a b c} } {a b c} test concat-3.2 {pruning off extra white space} { concat x y " a b c \n\t " " " " def " } {x y a b c def} tcl7.4b4/tests/dcall.test010044400630510000012000000022370567470011600161560ustar00ousterstaff00002300000001# Commands covered: none # # This file contains a collection of tests for Tcl_CallWhenDeleted. # Sourcing this file into Tcl runs the tests and generates output for # errors. No output means no errors were found. # # Copyright (c) 1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # @(#) dcall.test 1.4 94/12/17 16:19:48 if {[info commands testdcall] == {}} { puts "This application hasn't been compiled with the \"testdcall\"" puts "command, so I can't test Tcl_CallWhenDeleted." return } if {[string compare test [info procs test]] == 1} then {source defs} test dcall-1.1 {deletion callbacks} { testdcall 1 2 3 } {1 2 3} test dcall-1.2 {deletion callbacks} { testdcall } {} test dcall-1.3 {deletion callbacks} { testdcall 20 21 22 -22 } {20 21} test dcall-1.4 {deletion callbacks} { testdcall 20 21 22 -20 } {21 22} test dcall-1.5 {deletion callbacks} { testdcall 20 21 22 -21 } {20 22} test dcall-1.6 {deletion callbacks} { testdcall 20 21 22 -21 -22 -20 } {} tcl7.4b4/tests/dstring.test010044400630510000012000000166420567470011600165560ustar00ousterstaff00002300000001# Commands covered: none # # This file contains a collection of tests for Tcl's dynamic string # library procedures. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # @(#) dstring.test 1.7 94/12/17 16:19:49 if {[info commands testdstring] == {}} { puts "This application hasn't been compiled with the \"testdstring\"" puts "command, so I can't test Tcl_DStringAppend et al." return } if {[string compare test [info procs test]] == 1} then {source defs} test dstring-1.1 {appending and retrieving} { testdstring free testdstring append "abc" -1 list [testdstring get] [testdstring length] } {abc 3} test dstring-1.2 {appending and retrieving} { testdstring free testdstring append "abc" -1 testdstring append " xyzzy" 3 testdstring append " 12345" -1 list [testdstring get] [testdstring length] } {{abc xy 12345} 12} test dstring-1.3 {appending and retrieving} { testdstring free foreach l {a b c d e f g h i j k l m n o p} { testdstring append $l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l\n -1 } list [testdstring get] [testdstring length] } {{aaaaaaaaaaaaaaaaaaaaa bbbbbbbbbbbbbbbbbbbbb ccccccccccccccccccccc ddddddddddddddddddddd eeeeeeeeeeeeeeeeeeeee fffffffffffffffffffff ggggggggggggggggggggg hhhhhhhhhhhhhhhhhhhhh iiiiiiiiiiiiiiiiiiiii jjjjjjjjjjjjjjjjjjjjj kkkkkkkkkkkkkkkkkkkkk lllllllllllllllllllll mmmmmmmmmmmmmmmmmmmmm nnnnnnnnnnnnnnnnnnnnn ooooooooooooooooooooo ppppppppppppppppppppp } 352} test dstring-2.1 {appending list elements} { testdstring free testdstring element "abc" testdstring element "d e f" list [testdstring get] [testdstring length] } {{abc {d e f}} 11} test dstring-2.2 {appending list elements} { testdstring free testdstring element "x" testdstring element "\{" testdstring element "ab\}" testdstring get } {x \{ ab\}} test dstring-2.3 {appending list elements} { testdstring free foreach l {a b c d e f g h i j k l m n o p} { testdstring element $l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l } testdstring get } {aaaaaaaaaaaaaaaaaaaaa bbbbbbbbbbbbbbbbbbbbb ccccccccccccccccccccc ddddddddddddddddddddd eeeeeeeeeeeeeeeeeeeee fffffffffffffffffffff ggggggggggggggggggggg hhhhhhhhhhhhhhhhhhhhh iiiiiiiiiiiiiiiiiiiii jjjjjjjjjjjjjjjjjjjjj kkkkkkkkkkkkkkkkkkkkk lllllllllllllllllllll mmmmmmmmmmmmmmmmmmmmm nnnnnnnnnnnnnnnnnnnnn ooooooooooooooooooooo ppppppppppppppppppppp} test dstring-2.4 {appending list elements} { testdstring free testdstring append "a\{" -1 testdstring element abc testdstring append " \{" -1 testdstring element xyzzy testdstring get } "a{ abc {xyzzy" test dstring-2.5 {appending list elements} { testdstring free testdstring append " \{" -1 testdstring element abc testdstring get } " {abc" test dstring-2.6 {appending list elements} { testdstring free testdstring append " " -1 testdstring element abc testdstring get } { abc} test dstring-2.7 {appending list elements} { testdstring free testdstring append "\\ " -1 testdstring element abc testdstring get } "\\ abc" test dstring-2.8 {appending list elements} { testdstring free testdstring append "x " -1 testdstring element abc testdstring get } {x abc} test dstring-3.1 {nested sublists} { testdstring free testdstring start testdstring element foo testdstring element bar testdstring end testdstring element another testdstring get } {{foo bar} another} test dstring-3.2 {nested sublists} { testdstring free testdstring start testdstring start testdstring element abc testdstring element def testdstring end testdstring end testdstring element ghi testdstring get } {{{abc def}} ghi} test dstring-3.3 {nested sublists} { testdstring free testdstring start testdstring start testdstring start testdstring element foo testdstring element foo2 testdstring end testdstring end testdstring element foo3 testdstring end testdstring element foo4 testdstring get } {{{{foo foo2}} foo3} foo4} test dstring-3.4 {nested sublists} { testdstring free testdstring element before testdstring start testdstring element during testdstring element more testdstring end testdstring element last testdstring get } {before {during more} last} test dstring-3.4 {nested sublists} { testdstring free testdstring element "\{" testdstring start testdstring element first testdstring element second testdstring end testdstring get } {\{ {first second}} test dstring-4.1 {truncation} { testdstring free testdstring append "abcdefg" -1 testdstring trunc 3 list [testdstring get] [testdstring length] } {abc 3} test dstring-4.2 {truncation} { testdstring free testdstring append "xyzzy" -1 testdstring trunc 0 list [testdstring get] [testdstring length] } {{} 0} test dstring-5.1 {copying to result} { testdstring free testdstring append xyz -1 testdstring result } xyz test dstring-5.2 {copying to result} { testdstring free foreach l {a b c d e f g h i j k l m n o p} { testdstring append $l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l\n -1 } set a [testdstring result] testdstring append abc -1 list $a [testdstring get] } {{aaaaaaaaaaaaaaaaaaaaa bbbbbbbbbbbbbbbbbbbbb ccccccccccccccccccccc ddddddddddddddddddddd eeeeeeeeeeeeeeeeeeeee fffffffffffffffffffff ggggggggggggggggggggg hhhhhhhhhhhhhhhhhhhhh iiiiiiiiiiiiiiiiiiiii jjjjjjjjjjjjjjjjjjjjj kkkkkkkkkkkkkkkkkkkkk lllllllllllllllllllll mmmmmmmmmmmmmmmmmmmmm nnnnnnnnnnnnnnnnnnnnn ooooooooooooooooooooo ppppppppppppppppppppp } abc} test dstring-6.1 {Tcl_DStringGetResult} { testdstring free list [testdstring gresult staticsmall] [testdstring get] } {{} short} test dstring-6.2 {Tcl_DStringGetResult} { testdstring free foreach l {a b c d e f g h i j k l m n o p} { testdstring append $l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l\n -1 } list [testdstring gresult staticsmall] [testdstring get] } {{} short} test dstring-6.3 {Tcl_DStringGetResult} { set result {} lappend result [testdstring gresult staticlarge] testdstring append x 1 lappend result [testdstring get] } {{} {first0 first1 first2 first3 first4 first5 first6 first7 first8 first9 second0 second1 second2 second3 second4 second5 second6 second7 second8 second9 third0 third1 third2 third3 third4 third5 third6 third7 third8 third9 fourth0 fourth1 fourth2 fourth3 fourth4 fourth5 fourth6 fourth7 fourth8 fourth9 fifth0 fifth1 fifth2 fifth3 fifth4 fifth5 fifth6 fifth7 fifth8 fifth9 sixth0 sixth1 sixth2 sixth3 sixth4 sixth5 sixth6 sixth7 sixth8 sixth9 seventh0 seventh1 seventh2 seventh3 seventh4 seventh5 seventh6 seventh7 seventh8 seventh9 x}} test dstring-6.4 {Tcl_DStringGetResult} { set result {} lappend result [testdstring gresult free] testdstring append y 1 lappend result [testdstring get] } {{} {This is a malloc-ed stringy}} test dstring-6.5 {Tcl_DStringGetResult} { set result {} lappend result [testdstring gresult special] testdstring append z 1 lappend result [testdstring get] } {{} {This is a specially-allocated stringz}} testdstring free ngth] } {{abc {d e f}} 11} test dstring-2.2 {appending list elements} { testdstring free tcl7.4b4/tests/env.test010044400630510000012000000054600567470011700156710ustar00ousterstaff00002300000001# Commands covered: none (tests environment variable implementation) # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # @(#) env.test 1.8 94/12/17 16:19:50 if {[string compare test [info procs test]] == 1} then {source defs} # If there is no "printenv" program on this system, then it's just too # much trouble to run this test (can't necessarily run csh to get the # environment: on some systems it barfs if there isn't a minimum set # predefined environment variables. Also, printenv returns a non-zero # status on some systems, so read the environment using a procedure # that catches errors. set printenv {} if [info exists env(PATH)] { set dirs [split $env(PATH) :] } else { set dirs {/bin /usr/bin /usr/ucb /usr/local /usr/public /usr/etc} } foreach i $dirs { if [file executable $i/printenv] { # The following hack is needed because of weirdness with # environment variables in symbolic lines on Apollos (?!#?). if ![catch {exec sh -c "cd $i; pwd"} x] { set printenv $x/printenv } else { set printenv $i/printenv } break } } if {$printenv == ""} { puts stdout "Skipping env tests: need \"printenv\" to read environment." return "" } proc getenv {} { global printenv catch {exec $printenv} out if {$out == "child process exited abnormally"} { set out {} } return $out } # Save the current environment variables at the start of the test. foreach name [array names env] { set env2($name) $env($name) unset env($name) } test env-1.1 {adding environment variables} { getenv } {} set env(NAME1) "test string" test env-1.2 {adding environment variables} { getenv } {NAME1=test string} set env(NAME2) "more" test env-1.3 {adding environment variables} { getenv } {NAME1=test string NAME2=more} set env(XYZZY) "garbage" test env-1.4 {adding environment variables} { getenv } {NAME1=test string NAME2=more XYZZY=garbage} set env(NAME2) "new value" test env-2.1 {changing environment variables} { getenv } {NAME1=test string NAME2=new value XYZZY=garbage} unset env(NAME2) test env-3.1 {unsetting environment variables} { getenv } {NAME1=test string XYZZY=garbage} unset env(NAME1) test env-3.2 {unsetting environment variables} { getenv } {XYZZY=garbage} # Restore the environment variables at the end of the test. foreach name [array names env] { unset env($name) } foreach name [array names env2] { set env($name) $env2($name) } tcl7.4b4/tests/error.test010044400630510000012000000112170567470011700162270ustar00ousterstaff00002300000001# Commands covered: error, catch # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # @(#) error.test 1.13 94/12/17 16:19:51 if {[string compare test [info procs test]] == 1} then {source defs} proc foo {} { global errorInfo set a [catch {format [error glorp2]} b] error {Human-generated} } proc foo2 {} { global errorInfo set a [catch {format [error glorp2]} b] error {Human-generated} $errorInfo } # Catch errors occurring in commands and errors from "error" command test error-1.1 {simple errors from commands} { catch {format [string compare]} b } 1 test error-1.2 {simple errors from commands} { catch {format [string compare]} b set b } {wrong # args: should be "string compare string1 string2"} test error-1.3 {simple errors from commands} { catch {format [string compare]} b set errorInfo } {wrong # args: should be "string compare string1 string2" while executing "string compare" invoked from within "format [string compare]..."} test error-1.4 {simple errors from commands} { catch {error glorp} b } 1 test error-1.5 {simple errors from commands} { catch {error glorp} b set b } glorp test error-1.6 {simple errors from commands} { catch {catch a b c} b } 1 test error-1.7 {simple errors from commands} { catch {catch a b c} b set b } {wrong # args: should be "catch command ?varName?"} test error-2.1 {simple errors from commands} { catch catch } 1 # Check errors nested in procedures. Also check the optional argument # to "error" to generate a new error trace. test error-2.1 {errors in nested procedures} { catch foo b } 1 test error-2.2 {errors in nested procedures} { catch foo b set b } {Human-generated} test error-2.3 {errors in nested procedures} { catch foo b set errorInfo } {Human-generated while executing "error {Human-generated}" (procedure "foo" line 4) invoked from within "foo"} test error-2.4 {errors in nested procedures} { catch foo2 b } 1 test error-2.5 {errors in nested procedures} { catch foo2 b set b } {Human-generated} test error-2.6 {errors in nested procedures} { catch foo2 b set errorInfo } {glorp2 while executing "error glorp2" invoked from within "format [error glorp2]..." (procedure "foo2" line 1) invoked from within "foo2"} # Error conditions related to "catch". test error-3.1 {errors in catch command} { list [catch {catch} msg] $msg } {1 {wrong # args: should be "catch command ?varName?"}} test error-3.2 {errors in catch command} { list [catch {catch a b c} msg] $msg } {1 {wrong # args: should be "catch command ?varName?"}} test error-3.3 {errors in catch command} { catch {unset a} set a(0) 22 list [catch {catch {format 44} a} msg] $msg } {1 {couldn't save command result in variable}} catch {unset a} # More tests related to errorInfo and errorCode test error-4.1 {errorInfo and errorCode variables} { list [catch {error msg1 msg2 msg3} msg] $msg $errorInfo $errorCode } {1 msg1 msg2 msg3} test error-4.2 {errorInfo and errorCode variables} { list [catch {error msg1 {} msg3} msg] $msg $errorInfo $errorCode } {1 msg1 {msg1 while executing "error msg1 {} msg3"} msg3} test error-4.3 {errorInfo and errorCode variables} { list [catch {error msg1 {}} msg] $msg $errorInfo $errorCode } {1 msg1 {msg1 while executing "error msg1 {}"} NONE} test error-4.4 {errorInfo and errorCode variables} { set errorCode bogus list [catch {error msg1} msg] $msg $errorInfo $errorCode } {1 msg1 {msg1 while executing "error msg1"} NONE} test error-4.5 {errorInfo and errorCode variables} { set errorCode bogus list [catch {error msg1 msg2 {}} msg] $msg $errorInfo $errorCode } {1 msg1 msg2 {}} # Errors in error command itself test error-5.1 {errors in error command} { list [catch {error} msg] $msg } {1 {wrong # args: should be "error message ?errorInfo? ?errorCode?"}} test error-5.2 {errors in error command} { list [catch {error a b c d} msg] $msg } {1 {wrong # args: should be "error message ?errorInfo? ?errorCode?"}} # Make sure that catch resets error information test error-6.1 {catch must reset error state} { catch {error outer [catch {error inner inner.errorInfo inner.errorCode}]} list $errorCode $errorInfo } {NONE 1} return "" catch {format [error glorp2]} b] error {Human-generated} } proc foo2 {} { global errorInfo set a [catch {format [error glorp2]} b] error {Human-generated} $errorInfo } # Catch errors occurring in commands and errors from "error" command test error-1.1 {simple errors from commands} { catch {format [string compare]} b } 1 test error-1.2 {simple tcl7.4b4/tests/eval.test010044400630510000012000000027540567470011700160330ustar00ousterstaff00002300000001# Commands covered: eval # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # @(#) eval.test 1.6 94/12/17 16:19:52 if {[string compare test [info procs test]] == 1} then {source defs} test eval-1.1 {single argument} { eval {format 22} } 22 test eval-1.2 {multiple arguments} { set a {$b} set b xyzzy eval format $a } xyzzy test eval-1.3 {single argument} { eval concat a b c d e f g } {a b c d e f g} test eval-2.1 {error: not enough arguments} {catch eval} 1 test eval-2.2 {error: not enough arguments} { catch eval msg set msg } {wrong # args: should be "eval arg ?arg ...?"} test eval-2.3 {error in eval'ed command} { catch {eval {error "test error"}} } 1 test eval-2.4 {error in eval'ed command} { catch {eval {error "test error"}} msg set msg } {test error} test eval-2.5 {error in eval'ed command: setting errorInfo} { catch {eval { set a 1 error "test error" }} msg set errorInfo } "test error while executing \"error \"test error\"\" (\"eval\" body line 3) invoked from within \"eval { set a 1 error \"test error\" }\"" tcl7.4b4/tests/exec.test010044400630510000012000000344470567470011700160340ustar00ousterstaff00002300000001# Commands covered: exec # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1994 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # @(#) exec.test 1.36 94/12/17 16:19:53 if {[string compare test [info procs test]] == 1} then {source defs} # Basic operations. test exec-1.1 {basic exec operation} { exec echo a b c } "a b c" test exec-1.2 {pipelining} { exec echo a b c d | cat | cat } "a b c d" test exec-1.3 {pipelining} { set a [exec echo a b c d | cat | wc] list [scan $a "%d %d %d" b c d] $b $c $d } {3 1 4 8} # I/O redirection: input from Tcl command. test exec-2.1 {redirecting input from immediate source} { exec cat << "Sample text" } {Sample text} test exec-2.2 {redirecting input from immediate source} { exec << "Sample text" cat | cat } {Sample text} test exec-2.3 {redirecting input from immediate source} { exec cat << "Sample text" | cat } {Sample text} test exec-2.4 {redirecting input from immediate source} { exec cat | cat << "Sample text" } {Sample text} test exec-2.5 {redirecting input from immediate source} { exec cat "< gorp.file exec cat gorp.file } "Some simple words" test exec-3.2 {redirecting output to file} { exec echo "More simple words" | >gorp.file cat | cat exec cat gorp.file } "More simple words" test exec-3.3 {redirecting output to file} { exec > gorp.file echo "Different simple words" | cat | cat exec cat gorp.file } "Different simple words" test exec-3.4 {redirecting output to file} { exec echo "Some simple words" >gorp.file exec cat gorp.file } "Some simple words" test exec-3.5 {redirecting output to file} { exec echo "First line" >gorp.file exec echo "Second line" >> gorp.file exec cat gorp.file } "First line\nSecond line" test exec-3.6 {redirecting output to file} { exec echo "First line" >gorp.file exec echo "Second line" >>gorp.file exec cat gorp.file } "First line\nSecond line" test exec-3.7 {redirecting output to file} { set f [open gorp.file w] puts $f "Line 1" flush $f exec echo "More text" >@ $f exec echo >@$f "Even more" puts $f "Line 3" close $f exec cat gorp.file } "Line 1\nMore text\nEven more\nLine 3" # I/O redirection: output and stderr to file. catch {exec rm -f gorp.file} test exec-4.1 {redirecting output and stderr to file} { exec echo "test output" >& gorp.file exec cat gorp.file } "test output" test exec-4.2 {redirecting output and stderr to file} { list [exec sh -c "echo foo bar 1>&2" >&gorp.file] \ [exec cat gorp.file] } {{} {foo bar}} test exec-4.3 {redirecting output and stderr to file} { exec echo "first line" > gorp.file list [exec sh -c "echo foo bar 1>&2" >>&gorp.file] \ [exec cat gorp.file] } "{} {first line\nfoo bar}" test exec-4.4 {redirecting output and stderr to file} { set f [open gorp.file w] puts $f "Line 1" flush $f exec echo "More text" >&@ $f exec echo >&@$f "Even more" puts $f "Line 3" close $f exec cat gorp.file } "Line 1\nMore text\nEven more\nLine 3" test exec-4.5 {redirecting output and stderr to file} { set f [open gorp.file w] puts $f "Line 1" flush $f exec >&@ $f sh -c "echo foo bar 1>&2" exec >&@$f sh -c "echo xyzzy 1>&2" puts $f "Line 3" close $f exec cat gorp.file } "Line 1\nfoo bar\nxyzzy\nLine 3" # I/O redirection: input from file. exec echo "Just a few thoughts" > gorp.file test exec-5.1 {redirecting input from file} { exec cat < gorp.file } {Just a few thoughts} test exec-5.2 {redirecting input from file} { exec cat | cat < gorp.file } {Just a few thoughts} test exec-5.3 {redirecting input from file} { exec cat < gorp.file | cat } {Just a few thoughts} test exec-5.4 {redirecting input from file} { exec < gorp.file cat | cat } {Just a few thoughts} test exec-5.5 {redirecting input from file} { exec cat &2" |& cat } "foo bar" test exec-6.3 {redirecting stderr through a pipeline} { exec sh -c "echo foo bar 1>&2" |& sh -c "echo second msg 1>& 2; cat" |& cat } "second msg\nfoo bar" # I/O redirection: combinations. catch {exec rm -f gorp.file2} test exec-7.1 {multiple I/O redirections} { exec << "command input" > gorp.file2 cat < gorp.file exec cat gorp.file2 } {Just a few thoughts} test exec-7.2 {multiple I/O redirections} { exec < gorp.file << "command input" cat } {command input} # Long input to command and output from command. set a "0123456789 xxxxxxxxx abcdefghi ABCDEFGHIJK\n" set a [concat $a $a $a $a] set a [concat $a $a $a $a] set a [concat $a $a $a $a] set a [concat $a $a $a $a] test exec-8.1 {long input and output} { exec cat << $a } $a # Commands that return errors. test exec-9.1 {commands returning errors} { set x [catch {exec gorp456} msg] list $x [string tolower $msg] [string tolower $errorCode] } {1 {couldn't execute "gorp456": no such file or directory} {posix enoent {no such file or directory}}} test exec-9.2 {commands returning errors} { string tolower [list [catch {exec echo foo | foo123} msg] $msg $errorCode] } {1 {couldn't execute "foo123": no such file or directory} {posix enoent {no such file or directory}}} test exec-9.3 {commands returning errors} { list [catch {exec sleep 1 | sh -c "exit 43" | sleep 1} msg] $msg } {1 {child process exited abnormally}} test exec-9.4 {commands returning errors} { list [catch {exec gorp456 | echo a b c} msg] [string tolower $msg] } {1 {couldn't execute "gorp456": no such file or directory}} test exec-9.5 {commands returning errors} { list [catch {exec sh -c "echo error msg 1>&2"} msg] $msg } {1 {error msg}} test exec-9.6 {commands returning errors} { list [catch {exec sh -c "echo error msg 1>&2" | sh -c "echo error msg 1>&2"} msg] $msg } {1 {error msg error msg}} # Errors in executing the Tcl command, as opposed to errors in the # processes that are invoked. test exec-10.1 {errors in exec invocation} { list [catch {exec} msg] $msg } {1 {wrong # args: should be "exec ?switches? arg ?arg ...?"}} test exec-10.2 {errors in exec invocation} { list [catch {exec | cat} msg] $msg } {1 {illegal use of | or |& in command}} test exec-10.3 {errors in exec invocation} { list [catch {exec cat |} msg] $msg } {1 {illegal use of | or |& in command}} test exec-10.4 {errors in exec invocation} { list [catch {exec cat | | cat} msg] $msg } {1 {illegal use of | or |& in command}} test exec-10.5 {errors in exec invocation} { list [catch {exec cat | |& cat} msg] $msg } {1 {illegal use of | or |& in command}} test exec-10.6 {errors in exec invocation} { list [catch {exec cat |&} msg] $msg } {1 {illegal use of | or |& in command}} test exec-10.7 {errors in exec invocation} { list [catch {exec cat <} msg] $msg } {1 {can't specify "<" as last word in command}} test exec-10.8 {errors in exec invocation} { list [catch {exec cat >} msg] $msg } {1 {can't specify ">" as last word in command}} test exec-10.9 {errors in exec invocation} { list [catch {exec cat <<} msg] $msg } {1 {can't specify "<<" as last word in command}} test exec-10.10 {errors in exec invocation} { list [catch {exec cat >>} msg] $msg } {1 {can't specify ">>" as last word in command}} test exec-10.11 {errors in exec invocation} { list [catch {exec cat >&} msg] $msg } {1 {can't specify ">&" as last word in command}} test exec-10.12 {errors in exec invocation} { list [catch {exec cat >>&} msg] $msg } {1 {can't specify ">>&" as last word in command}} test exec-10.13 {errors in exec invocation} { list [catch {exec cat >@} msg] $msg } {1 {can't specify ">@" as last word in command}} test exec-10.14 {errors in exec invocation} { list [catch {exec cat <@} msg] $msg } {1 {can't specify "<@" as last word in command}} test exec-10.15 {errors in exec invocation} { list [catch {exec cat < a/b/c} msg] [string tolower $msg] } {1 {couldn't read file "a/b/c": no such file or directory}} test exec-10.16 {errors in exec invocation} { list [catch {exec cat << foo > a/b/c} msg] [string tolower $msg] } {1 {couldn't write file "a/b/c": no such file or directory}} test exec-10.17 {errors in exec invocation} { list [catch {exec cat << foo > a/b/c} msg] [string tolower $msg] } {1 {couldn't write file "a/b/c": no such file or directory}} set f [open gorp.file w] test exec-10.18 {errors in exec invocation} { list [catch {exec cat <@ $f} msg] $msg } "1 {\"$f\" wasn't opened for reading}" close $f set f [open gorp.file r] test exec-10.19 {errors in exec invocation} { list [catch {exec cat >@ $f} msg] $msg } "1 {\"$f\" wasn't opened for writing}" close $f # Commands in background. test exec-11.1 {commands in background} { set x [lindex [time {exec sleep 2 &}] 0] expr $x<1000000 } 1 test exec-11.2 {commands in background} { list [catch {exec echo a &b} msg] $msg } {0 {a &b}} test exec-11.3 {commands in background} { llength [exec sleep 1 &] } 1 test exec-11.4 {commands in background} { llength [exec sleep 1 | sleep 1 | sleep 1 &] } 3 # Make sure that background commands are properly reaped when # they eventually die. exec sleep 3 if $doNonPortableTests { test exec-12.1 {reaping background processes} { for {set i 0} {$i < 20} {incr i} { exec echo foo > /dev/null & } exec sleep 1 catch {exec ps | fgrep "echo foo" | fgrep -v fgrep | wc} msg lindex $msg 0 } 0 test exec-12.2 {reaping background processes} { exec sleep 2 | sleep 2 | sleep 2 & catch {exec ps | fgrep "sleep" | fgrep -v fgrep | wc} msg set x [lindex $msg 0] exec sleep 3 catch {exec ps | fgrep "sleep" | fgrep -v fgrep | wc} msg list $x [lindex $msg 0] } {3 0} test exec-12.3 {reaping background processes} { exec sleep 1000 & exec sleep 1000 & set x [exec ps | fgrep "sleep" | fgrep -v fgrep] set pids {} foreach i [split $x \n] { lappend pids [lindex $i 0] } foreach i $pids { catch {exec kill -STOP $i} } catch {exec ps | fgrep "sleep" | fgrep -v fgrep | wc} msg set x [lindex $msg 0] foreach i $pids { catch {exec kill -KILL $i} } catch {exec ps | fgrep "sleep" | fgrep -v fgrep | wc} msg list $x [lindex $msg 0] } {2 0} } # Make sure "errorCode" is set correctly. test exec-13.1 {setting errorCode variable} { list [catch {exec cat < a/b/c} msg] [string tolower $errorCode] } {1 {posix enoent {no such file or directory}}} test exec-13.2 {setting errorCode variable} { list [catch {exec cat > a/b/c} msg] [string tolower $errorCode] } {1 {posix enoent {no such file or directory}}} test exec-13.3 {setting errorCode variable} { set x [catch {exec _weirdo_command_} msg] list $x [string tolower $msg] [lindex $errorCode 0] \ [string tolower [lrange $errorCode 2 end]] } {1 {couldn't execute "_weirdo_command_": no such file or directory} POSIX {{no such file or directory}}} # Switches before the first argument test exec-14.1 {-keepnewline switch} { exec -keepnewline echo foo } "foo\n" test exec-14.2 {-keepnewline switch} { list [catch {exec -keepnewline} msg] $msg } {1 {wrong # args: should be "exec ?switches? arg ?arg ...?"}} test exec-14.3 {unknown switch} { list [catch {exec -gorp} msg] $msg } {1 {bad switch "-gorp": must be -keepnewline or --}} test exec-14.4 {-- switch} { list [catch {exec -- -gorp} msg] [string tolower $msg] } {1 {couldn't execute "-gorp": no such file or directory}} # Redirecting standard error separately from standard output test exec-15.1 {standard error redirection} { exec echo "First line" > gorp.file list [exec sh -c "echo foo bar 1>&2" 2> gorp.file] \ [exec cat gorp.file] } {{} {foo bar}} test exec-15.2 {standard error redirection} { list [exec sh -c "echo foo bar 1>&2" | echo biz baz >gorp.file \ 2> gorp.file2] [exec cat gorp.file] \ [exec cat gorp.file2] } {{} {biz baz} {foo bar}} test exec-15.3 {standard error redirection} { list [exec sh -c "echo foo bar 1>&2" | echo biz baz 2>gorp.file \ > gorp.file2] [exec cat gorp.file] \ [exec cat gorp.file2] } {{} {foo bar} {biz baz}} test exec-15.4 {standard error redirection} { set f [open gorp.file w] puts $f "Line 1" flush $f exec sh -c "echo foo bar 1>&2" 2>@ $f puts $f "Line 3" close $f exec cat gorp.file } {Line 1 foo bar Line 3} test exec-15.5 {standard error redirection} { exec echo "First line" > gorp.file exec sh -c "echo foo bar 1>&2" 2>> gorp.file exec cat gorp.file } {First line foo bar} test exec-15.6 {standard error redirection} { exec sh -c "echo foo bar 1>&2" > gorp.file2 2> gorp.file \ >& gorp.file 2> gorp.file2 | echo biz baz list [exec cat gorp.file] [exec cat gorp.file2] } {{biz baz} {foo bar}} if $doNonPortableTests { test exec-16.1 {restore signal settings before exec} { set f [open {|cat exec.test} r] list [catch {close $f} msg] [string tolower $msg] } {1 {child killed: write on pipe with no readers}} } test exec-17.1 {flush output before exec} { set f [open gorp.file w] puts $f "First line" exec echo "Second line" >@ $f puts $f "Third line" close $f exec cat gorp.file } {First line Second line Third line} test exec-17.2 {flush output before exec} { set f [open gorp.file w] puts $f "First line" exec sh -c "echo Second line 1>&2" >&@ $f > gorp.file2 puts $f "Third line" close $f exec cat gorp.file } {First line Second line Third line} catch {exec rm -f gorp.file} catch {exec rm -f gorp.file2} return {} tcl7.4b4/tests/expr.test010044400630510000012000001105460573242357200160630ustar00ousterstaff00002300000001# Commands covered: expr # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1994 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # @(#) expr.test 1.44 95/03/17 16:21:14 if {[string compare test [info procs test]] == 1} then {source defs} if {([catch {expr T1()} msg] == 1) && ($msg == {unknown math function "T1"})} { set gotT1 0 puts "This application hasn't been compiled with the \"T1\" and" puts "\"T2\" math functions, so I'll skip some of the expr tests." } else { set gotT1 1 } # First, test all of the integer operators individually. test expr-1.1 {integer operators} {expr -4} -4 test expr-1.2 {integer operators} {expr -(1+4)} -5 test expr-1.3 {integer operators} {expr ~3} -4 test expr-1.4 {integer operators} {expr !2} 0 test expr-1.5 {integer operators} {expr !0} 1 test expr-1.6 {integer operators} {expr 4*6} 24 test expr-1.7 {integer operators} {expr 36/12} 3 test expr-1.8 {integer operators} {expr 27/4} 6 test expr-1.9 {integer operators} {expr 27%4} 3 test expr-1.10 {integer operators} {expr 2+2} 4 test expr-1.11 {integer operators} {expr 2-6} -4 test expr-1.12 {integer operators} {expr 1<<3} 8 test expr-1.13 {integer operators} {expr 0xff>>2} 63 test expr-1.14 {integer operators} {expr -1>>2} -1 test expr-1.15 {integer operators} {expr 3>2} 1 test expr-1.16 {integer operators} {expr 2>2} 0 test expr-1.17 {integer operators} {expr 1>2} 0 test expr-1.18 {integer operators} {expr 3<2} 0 test expr-1.19 {integer operators} {expr 2<2} 0 test expr-1.20 {integer operators} {expr 1<2} 1 test expr-1.21 {integer operators} {expr 3>=2} 1 test expr-1.22 {integer operators} {expr 2>=2} 1 test expr-1.23 {integer operators} {expr 1>=2} 0 test expr-1.24 {integer operators} {expr 3<=2} 0 test expr-1.25 {integer operators} {expr 2<=2} 1 test expr-1.26 {integer operators} {expr 1<=2} 1 test expr-1.27 {integer operators} {expr 3==2} 0 test expr-1.28 {integer operators} {expr 2==2} 1 test expr-1.29 {integer operators} {expr 3!=2} 1 test expr-1.30 {integer operators} {expr 2!=2} 0 test expr-1.31 {integer operators} {expr 7&0x13} 3 test expr-1.32 {integer operators} {expr 7^0x13} 20 test expr-1.33 {integer operators} {expr 7|0x13} 23 test expr-1.34 {integer operators} {expr 0&&1} 0 test expr-1.35 {integer operators} {expr 0&&0} 0 test expr-1.36 {integer operators} {expr 1&&3} 1 test expr-1.37 {integer operators} {expr 0||1} 1 test expr-1.38 {integer operators} {expr 3||0} 1 test expr-1.39 {integer operators} {expr 0||0} 0 test expr-1.40 {integer operators} {expr 3>2?44:66} 44 test expr-1.41 {integer operators} {expr 2>3?44:66} 66 test expr-1.42 {integer operators} {expr 36/5} 7 test expr-1.43 {integer operators} {expr 36%5} 1 test expr-1.44 {integer operators} {expr -36/5} -8 test expr-1.45 {integer operators} {expr -36%5} 4 test expr-1.46 {integer operators} {expr 36/-5} -8 test expr-1.47 {integer operators} {expr 36%-5} -4 test expr-1.48 {integer operators} {expr -36/-5} 7 test expr-1.49 {integer operators} {expr -36%-5} -1 test expr-1.50 {integer operators} {expr +36} 36 test expr-1.51 {integer operators} {expr +--++36} 36 test expr-1.52 {integer operators} {expr +36%+5} 1 # Check the floating-point operators individually, along with # automatic conversion to integers where needed. test expr-2.1 {floating-point operators} {expr -4.2} -4.2 test expr-2.2 {floating-point operators} {expr -(1.1+4.2)} -5.3 test expr-2.3 {floating-point operators} {expr +5.7} 5.7 test expr-2.4 {floating-point operators} {expr +--+-62.0} -62.0 test expr-2.5 {floating-point operators} {expr !2.1} 0 test expr-2.6 {floating-point operators} {expr !0.0} 1 test expr-2.7 {floating-point operators} {expr 4.2*6.3} 26.46 test expr-2.8 {floating-point operators} {expr 36.0/12.0} 3.0 test expr-2.9 {floating-point operators} {expr 27/4.0} 6.75 test expr-2.10 {floating-point operators} {expr 2.3+2.1} 4.4 test expr-2.11 {floating-point operators} {expr 2.3-6.5} -4.2 test expr-2.12 {floating-point operators} {expr 3.1>2.1} 1 test expr-2.13 {floating-point operators} {expr {2.1 > 2.1}} 0 test expr-2.14 {floating-point operators} {expr 1.23>2.34e+1} 0 test expr-2.15 {floating-point operators} {expr 3.45<2.34} 0 test expr-2.16 {floating-point operators} {expr 0.002e3<--200e-2} 0 test expr-2.17 {floating-point operators} {expr 1.1<2.1} 1 test expr-2.18 {floating-point operators} {expr 3.1>=2.2} 1 test expr-2.19 {floating-point operators} {expr 2.345>=2.345} 1 test expr-2.20 {floating-point operators} {expr 1.1>=2.2} 0 test expr-2.21 {floating-point operators} {expr 3.0<=2.0} 0 test expr-2.22 {floating-point operators} {expr 2.2<=2.2} 1 test expr-2.23 {floating-point operators} {expr 2.2<=2.2001} 1 test expr-2.24 {floating-point operators} {expr 3.2==2.2} 0 test expr-2.25 {floating-point operators} {expr 2.2==2.2} 1 test expr-2.26 {floating-point operators} {expr 3.2!=2.2} 1 test expr-2.27 {floating-point operators} {expr 2.2!=2.2} 0 test expr-2.28 {floating-point operators} {expr 0.0&&0.0} 0 test expr-2.29 {floating-point operators} {expr 0.0&&1.3} 0 test expr-2.30 {floating-point operators} {expr 1.3&&0.0} 0 test expr-2.31 {floating-point operators} {expr 1.3&&3.3} 1 test expr-2.32 {floating-point operators} {expr 0.0||0.0} 0 test expr-2.33 {floating-point operators} {expr 0.0||1.3} 1 test expr-2.34 {floating-point operators} {expr 1.3||0.0} 1 test expr-2.35 {floating-point operators} {expr 3.3||0.0} 1 test expr-2.36 {floating-point operators} {expr 3.3>2.3?44.3:66.3} 44.3 test expr-2.37 {floating-point operators} {expr 2.3>3.3?44.3:66.3} 66.3 test expr-2.38 {floating-point operators} { list [catch {expr 028.1 + 09.2} msg] $msg } {0 37.3} # Operators that aren't legal on floating-point numbers test expr-3.1 {illegal floating-point operations} { list [catch {expr ~4.0} msg] $msg } {1 {can't use floating-point value as operand of "~"}} test expr-3.2 {illegal floating-point operations} { list [catch {expr 27%4.0} msg] $msg } {1 {can't use floating-point value as operand of "%"}} test expr-3.3 {illegal floating-point operations} { list [catch {expr 27.0%4} msg] $msg } {1 {can't use floating-point value as operand of "%"}} test expr-3.4 {illegal floating-point operations} { list [catch {expr 1.0<<3} msg] $msg } {1 {can't use floating-point value as operand of "<<"}} test expr-3.5 {illegal floating-point operations} { list [catch {expr 3<<1.0} msg] $msg } {1 {can't use floating-point value as operand of "<<"}} test expr-3.6 {illegal floating-point operations} { list [catch {expr 24.0>>3} msg] $msg } {1 {can't use floating-point value as operand of ">>"}} test expr-3.7 {illegal floating-point operations} { list [catch {expr 24>>3.0} msg] $msg } {1 {can't use floating-point value as operand of ">>"}} test expr-3.8 {illegal floating-point operations} { list [catch {expr 24&3.0} msg] $msg } {1 {can't use floating-point value as operand of "&"}} test expr-3.9 {illegal floating-point operations} { list [catch {expr 24.0|3} msg] $msg } {1 {can't use floating-point value as operand of "|"}} test expr-3.10 {illegal floating-point operations} { list [catch {expr 24.0^3} msg] $msg } {1 {can't use floating-point value as operand of "^"}} # Check the string operators individually. test expr-4.1 {string operators} {expr {"abc" > "def"}} 0 test expr-4.2 {string operators} {expr {"def" > "def"}} 0 test expr-4.3 {string operators} {expr {"g" > "def"}} 1 test expr-4.4 {string operators} {expr {"abc" < "abd"}} 1 test expr-4.5 {string operators} {expr {"abd" < "abd"}} 0 test expr-4.6 {string operators} {expr {"abe" < "abd"}} 0 test expr-4.7 {string operators} {expr {"abc" >= "def"}} 0 test expr-4.8 {string operators} {expr {"def" >= "def"}} 1 test expr-4.9 {string operators} {expr {"g" >= "def"}} 1 test expr-4.10 {string operators} {expr {"abc" <= "abd"}} 1 test expr-4.11 {string operators} {expr {"abd" <= "abd"}} 1 test expr-4.12 {string operators} {expr {"abe" <= "abd"}} 0 test expr-4.13 {string operators} {expr {"abc" == "abd"}} 0 test expr-4.14 {string operators} {expr {"abd" == "abd"}} 1 test expr-4.15 {string operators} {expr {"abc" != "abd"}} 1 test expr-4.16 {string operators} {expr {"abd" != "abd"}} 0 test expr-4.17 {string operators} {expr {"0y" < "0x12"}} 1 test expr-4.18 {string operators} {expr {"." < " "}} 0 test expr-4.19 {string operators} {expr {"0" == "+"}} 0 test expr-4.20 {string operators} {expr {"0" == "-"}} 0 test expr-4.21 {string operators} {expr {1?"foo":"bar"}} foo test expr-4.22 {string operators} {expr {0?"foo":"bar"}} bar # Operators that aren't legal on string operands. test expr-5.1 {illegal string operations} { list [catch {expr {-"a"}} msg] $msg } {1 {can't use non-numeric string as operand of "-"}} test expr-5.2 {illegal string operations} { list [catch {expr {+"a"}} msg] $msg } {1 {can't use non-numeric string as operand of "+"}} test expr-5.3 {illegal string operations} { list [catch {expr {~"a"}} msg] $msg } {1 {can't use non-numeric string as operand of "~"}} test expr-5.4 {illegal string operations} { list [catch {expr {!"a"}} msg] $msg } {1 {can't use non-numeric string as operand of "!"}} test expr-5.5 {illegal string operations} { list [catch {expr {"a"*"b"}} msg] $msg } {1 {can't use non-numeric string as operand of "*"}} test expr-5.6 {illegal string operations} { list [catch {expr {"a"/"b"}} msg] $msg } {1 {can't use non-numeric string as operand of "/"}} test expr-5.7 {illegal string operations} { list [catch {expr {"a"%"b"}} msg] $msg } {1 {can't use non-numeric string as operand of "%"}} test expr-5.8 {illegal string operations} { list [catch {expr {"a"+"b"}} msg] $msg } {1 {can't use non-numeric string as operand of "+"}} test expr-5.9 {illegal string operations} { list [catch {expr {"a"-"b"}} msg] $msg } {1 {can't use non-numeric string as operand of "-"}} test expr-5.10 {illegal string operations} { list [catch {expr {"a"<<"b"}} msg] $msg } {1 {can't use non-numeric string as operand of "<<"}} test expr-5.11 {illegal string operations} { list [catch {expr {"a">>"b"}} msg] $msg } {1 {can't use non-numeric string as operand of ">>"}} test expr-5.12 {illegal string operations} { list [catch {expr {"a"&"b"}} msg] $msg } {1 {can't use non-numeric string as operand of "&"}} test expr-5.13 {illegal string operations} { list [catch {expr {"a"^"b"}} msg] $msg } {1 {can't use non-numeric string as operand of "^"}} test expr-5.14 {illegal string operations} { list [catch {expr {"a"|"b"}} msg] $msg } {1 {can't use non-numeric string as operand of "|"}} test expr-5.15 {illegal string operations} { list [catch {expr {"a"&&"b"}} msg] $msg } {1 {can't use non-numeric string as operand of "&&"}} test expr-5.16 {illegal string operations} { list [catch {expr {"a"||"b"}} msg] $msg } {1 {can't use non-numeric string as operand of "||"}} test expr-5.17 {illegal string operations} { list [catch {expr {"a"?4:2}} msg] $msg } {1 {can't use non-numeric string as operand of "?"}} # Check precedence pairwise. test expr-6.1 {precedence checks} {expr -~3} 4 test expr-6.2 {precedence checks} {expr -!3} 0 test expr-6.3 {precedence checks} {expr -~0} 1 test expr-7.1 {precedence checks} {expr 2*4/6} 1 test expr-7.2 {precedence checks} {expr 24/6*3} 12 test expr-7.3 {precedence checks} {expr 24/6/2} 2 test expr-8.1 {precedence checks} {expr -2+4} 2 test expr-8.2 {precedence checks} {expr -2-4} -6 test expr-8.3 {precedence checks} {expr +2-4} -2 test expr-9.1 {precedence checks} {expr 2*3+4} 10 test expr-9.2 {precedence checks} {expr 8/2+4} 8 test expr-9.3 {precedence checks} {expr 8%3+4} 6 test expr-9.4 {precedence checks} {expr 2*3-1} 5 test expr-9.5 {precedence checks} {expr 8/2-1} 3 test expr-9.6 {precedence checks} {expr 8%3-1} 1 test expr-10.1 {precedence checks} {expr 6-3-2} 1 test expr-11.1 {precedence checks} {expr 7+1>>2} 2 test expr-11.2 {precedence checks} {expr 7+1<<2} 32 test expr-11.3 {precedence checks} {expr 7>>3-2} 3 test expr-11.4 {precedence checks} {expr 7<<3-2} 14 test expr-12.1 {precedence checks} {expr 6>>1>4} 0 test expr-12.2 {precedence checks} {expr 6>>1<2} 0 test expr-12.3 {precedence checks} {expr 6>>1>=3} 1 test expr-12.4 {precedence checks} {expr 6>>1<=2} 0 test expr-12.5 {precedence checks} {expr 6<<1>5} 1 test expr-12.6 {precedence checks} {expr 6<<1<5} 0 test expr-12.7 {precedence checks} {expr 5<=6<<1} 1 test expr-12.8 {precedence checks} {expr 5>=6<<1} 0 test expr-13.1 {precedence checks} {expr 2<3<4} 1 test expr-13.2 {precedence checks} {expr 0<4>2} 0 test expr-13.3 {precedence checks} {expr 4>2<1} 0 test expr-13.4 {precedence checks} {expr 4>3>2} 0 test expr-13.5 {precedence checks} {expr 4>3>=2} 0 test expr-13.6 {precedence checks} {expr 4>=3>2} 0 test expr-13.7 {precedence checks} {expr 4>=3>=2} 0 test expr-13.8 {precedence checks} {expr 0<=4>=2} 0 test expr-13.9 {precedence checks} {expr 4>=2<=0} 0 test expr-13.10 {precedence checks} {expr 2<=3<=4} 1 test expr-14.1 {precedence checks} {expr 1==4>3} 1 test expr-14.2 {precedence checks} {expr 0!=4>3} 1 test expr-14.3 {precedence checks} {expr 1==3<4} 1 test expr-14.4 {precedence checks} {expr 0!=3<4} 1 test expr-14.5 {precedence checks} {expr 1==4>=3} 1 test expr-14.6 {precedence checks} {expr 0!=4>=3} 1 test expr-14.7 {precedence checks} {expr 1==3<=4} 1 test expr-14.8 {precedence checks} {expr 0!=3<=4} 1 test expr-15.1 {precedence checks} {expr 1==3==3} 0 test expr-15.2 {precedence checks} {expr 3==3!=2} 1 test expr-15.3 {precedence checks} {expr 2!=3==3} 0 test expr-15.4 {precedence checks} {expr 2!=1!=1} 0 test expr-16.1 {precedence checks} {expr 2&3==2} 0 test expr-16.2 {precedence checks} {expr 1&3!=3} 0 test expr-17.1 {precedence checks} {expr 7&3^0x10} 19 test expr-17.2 {precedence checks} {expr 7^0x10&3} 7 test expr-18.1 {precedence checks} {expr 7^0x10|3} 23 test expr-18.2 {precedence checks} {expr 7|0x10^3} 23 test expr-19.1 {precedence checks} {expr 7|3&&1} 1 test expr-19.2 {precedence checks} {expr 1&&3|7} 1 test expr-19.3 {precedence checks} {expr 0&&1||1} 1 test expr-19.4 {precedence checks} {expr 1||1&&0} 1 test expr-20.1 {precedence checks} {expr 1||0?3:4} 3 test expr-20.2 {precedence checks} {expr 1?0:4||1} 0 test expr-20.3 {precedence checks} {expr 1?2:0?3:4} 2 test expr-20.4 {precedence checks} {expr 0?2:0?3:4} 4 test expr-20.5 {precedence checks} {expr 1?2?3:4:0} 3 test expr-20.6 {precedence checks} {expr 0?2?3:4:0} 0 # Parentheses. test expr-21.1 {parenthesization} {expr (2+4)*6} 36 test expr-21.2 {parenthesization} {expr (1?0:4)||1} 1 test expr-21.3 {parenthesization} {expr +(3-4)} -1 # Embedded commands and variable names. set a 16 test expr-22.1 {embedded variables} {expr {2*$a}} 32 test expr-22.2 {embedded variables} { set x -5 set y 10 expr {$x + $y} } {5} test expr-22.3 {embedded variables} { set x " -5" set y " +10" expr {$x + $y} } {5} test expr-22.4 {embedded commands and variables} {expr {[set a] - 14}} 2 test expr-22.5 {embedded commands and variables} { list [catch {expr {12 - [bad_command_name]}} msg] $msg } {1 {invalid command name "bad_command_name"}} # Double-quotes and things inside them. test expr-23.1 {double quotes} {expr {"abc"}} abc test expr-23.2 {double quotes} { set a 189 expr {"$a.bc"} } 189.bc test expr-23.3 {double quotes} { set b2 xyx expr {"$b2$b2$b2.[set b2].[set b2]"} } xyxxyxxyx.xyx.xyx test expr-23.4 {double quotes} {expr {"11\}\}22"}} 11}}22 test expr-23.5 {double quotes} {expr {"\*bc"}} {*bc} test expr-23.6 {double quotes} { catch {unset bogus__} list [catch {expr {"$bogus__"}} msg] $msg } {1 {can't read "bogus__": no such variable}} test expr-23.7 {double quotes} { list [catch {expr {"a[error Testing]bc"}} msg] $msg } {1 Testing} test expr-23.8 {double quotes} { list [catch {expr {"12398712938788234-1298379" != ""}} msg] $msg } {0 1} # Numbers in various bases. test expr-24.1 {numbers in different bases} {expr 0x20} 32 test expr-24.2 {numbers in different bases} {expr 015} 13 # Conversions between various data types. test expr-25.1 {type conversions} {expr 2+2.5} 4.5 test expr-25.2 {type conversions} {expr 2.5+2} 4.5 test expr-25.3 {type conversions} {expr 2-2.5} -0.5 test expr-25.4 {type conversions} {expr 2/2.5} 0.8 test expr-25.5 {type conversions} {expr 2>2.5} 0 test expr-25.6 {type conversions} {expr 2.5>2} 1 test expr-25.7 {type conversions} {expr 2<2.5} 1 test expr-25.8 {type conversions} {expr 2>=2.5} 0 test expr-25.9 {type conversions} {expr 2<=2.5} 1 test expr-25.10 {type conversions} {expr 2==2.5} 0 test expr-25.11 {type conversions} {expr 2!=2.5} 1 test expr-25.12 {type conversions} {expr 2>"ab"} 0 test expr-25.13 {type conversions} {expr {2>" "}} 1 test expr-25.14 {type conversions} {expr {"24.1a" > 24.1}} 1 test expr-25.15 {type conversions} {expr {24.1 > "24.1a"}} 0 test expr-25.16 {type conversions} {expr 2+2.5} 4.5 test expr-25.17 {type conversions} {expr 2+2.5} 4.5 test expr-25.18 {type conversions} {expr 2.0e2} 200.0 test expr-25.19 {type conversions} {expr 2.0e15} 2e+15 test expr-25.20 {type conversions} {expr 10.0} 10.0 # Various error conditions. test expr-26.1 {error conditions} { list [catch {expr 2+"a"} msg] $msg } {1 {can't use non-numeric string as operand of "+"}} test expr-26.2 {error conditions} { list [catch {expr 2+4*} msg] $msg } {1 {syntax error in expression "2+4*"}} test expr-26.3 {error conditions} { list [catch {expr 2+4*(} msg] $msg } {1 {syntax error in expression "2+4*("}} catch {unset _non_existent_} test expr-26.4 {error conditions} { list [catch {expr 2+$_non_existent_} msg] $msg } {1 {can't read "_non_existent_": no such variable}} set a xx test expr-26.5 {error conditions} { list [catch {expr {2+$a}} msg] $msg } {1 {can't use non-numeric string as operand of "+"}} test expr-26.6 {error conditions} { list [catch {expr {2+[set a]}} msg] $msg } {1 {can't use non-numeric string as operand of "+"}} test expr-26.7 {error conditions} { list [catch {expr {2+(4}} msg] $msg } {1 {unmatched parentheses in expression "2+(4"}} test expr-26.8 {error conditions} { list [catch {expr 2/0} msg] $msg $errorCode } {1 {divide by zero} {ARITH DIVZERO {divide by zero}}} test expr-26.9 {error conditions} { list [catch {expr 2%0} msg] $msg $errorCode } {1 {divide by zero} {ARITH DIVZERO {divide by zero}}} test expr-26.10 {error conditions} { list [catch {expr 2.0/0.0} msg] $msg $errorCode } {1 {divide by zero} {ARITH DIVZERO {divide by zero}}} test expr-26.11 {error conditions} { list [catch {expr 2#} msg] $msg } {1 {syntax error in expression "2#"}} test expr-26.12 {error conditions} { list [catch {expr a.b} msg] $msg } {1 {syntax error in expression "a.b"}} test expr-26.13 {error conditions} { list [catch {expr {"a"/"b"}} msg] $msg } {1 {can't use non-numeric string as operand of "/"}} test expr-26.14 {error conditions} { list [catch {expr 2:3} msg] $msg } {1 {can't have : operator without ? first}} test expr-26.15 {error conditions} { list [catch {expr a@b} msg] $msg } {1 {syntax error in expression "a@b"}} test expr-26.16 {error conditions} { list [catch {expr a[b} msg] $msg } {1 {missing close-bracket}} test expr-26.17 {error conditions} { list [catch {expr a`b} msg] $msg } {1 {syntax error in expression "a`b"}} test expr-26.18 {error conditions} { list [catch {expr \"a\"\{b} msg] $msg } {1 {missing close-brace}} test expr-26.19 {error conditions} { list [catch {expr a} msg] $msg } {1 {syntax error in expression "a"}} test expr-26.20 {error conditions} { list [catch expr msg] $msg } {1 {wrong # args: should be "expr arg ?arg ...?"}} if $doNonPortableTests { test expr-26.21 {error conditions (integer overflow)} { list [catch {expr 0x7fffffff + -1} msg] $msg } {0 2147483646} test expr-26.22 {error conditions (integer overflow)} { list [catch {expr 0x7fffffff + 0} msg] $msg } {0 2147483647} test expr-26.23 {error conditions (integer overflow)} { list [catch {expr 0x7fffffff + 1} msg] $msg } {1 {integer overflow}} test expr-26.24 {error conditions (integer overflow)} { list [catch {expr 0x80000000 + -1} msg] $msg } {1 {integer overflow}} test expr-26.25 {error conditions (integer overflow)} { list [catch {expr 0x80000000 + 0} msg] $msg } {0 -2147483648} test expr-26.26 {error conditions (integer overflow)} { list [catch {expr 0x80000000 + 1} msg] $msg } {0 -2147483647} test expr-26.27 {error conditions (integer overflow)} { list [catch {expr 0x7fffffff - -1} msg] $msg } {1 {integer overflow}} test expr-26.28 {error conditions (integer overflow)} { list [catch {expr 0x7fffffff - 0} msg] $msg } {0 2147483647} test expr-26.29 {error conditions (integer overflow)} { list [catch {expr 0x7fffffff - 1} msg] $msg } {0 2147483646} test expr-26.30 {error conditions (integer overflow)} { list [catch {expr 0x80000000 - -1} msg] $msg } {0 -2147483647} test expr-26.31 {error conditions (integer overflow)} { list [catch {expr 0x80000000 - 0} msg] $msg } {0 -2147483648} test expr-26.32 {error conditions (integer overflow)} { list [catch {expr 0x80000000 - 1} msg] $msg } {1 {integer overflow}} test expr-26.33 {error conditions (integer overflow)} { list [catch {expr -0x80000000} msg] $msg } {1 {integer overflow}} test expr-26.34 {error conditions (integer overflow)} { list [catch {expr 0x3fff * 0x20000} msg] $msg } {0 2147352576} test expr-26.35 {error conditions (integer overflow)} { list [catch {expr 0x4000 * 0x20000} msg] $msg } {1 {integer overflow}} test expr-26.36 {error conditions (integer overflow)} { list [catch {expr -0x4000 * 0x20000} msg] $msg } {0 -2147483648} test expr-26.37 {error conditions (integer overflow)} { list [catch {expr -0x4001 * 0x20000} msg] $msg } {1 {integer overflow}} test expr-26.38 {error conditions (integer overflow)} { list [catch {expr -0x4000 * -0x20000} msg] $msg $errorCode } {1 {integer overflow} {ARITH IOVERFLOW {integer overflow}}} test expr-26.39 {error conditions (integer overflow)} { list [catch {expr 0 * 0x20000} msg] $msg } {0 0} test expr-26.40 {error conditions (integer overflow)} { list [catch {expr 0x80000000 / -1} msg] $msg } {1 {integer overflow}} test expr-26.41 {error conditions (integer overflow)} { list [catch {expr 0x80000000 / 1} msg] $msg } {0 -2147483648} test expr-26.42 {error conditions (integer overflow)} { list [catch {expr 0x80000000 % -1} msg] $msg } {0 0} } # Cancelled evaluation. test expr-27.1 {cancelled evaluation} { set a 1 expr {0&&[set a 2]} set a } 1 test expr-27.2 {cancelled evaluation} { set a 1 expr {1||[set a 2]} set a } 1 test expr-27.3 {cancelled evaluation} { set a 1 expr {0?[set a 2]:1} set a } 1 test expr-27.4 {cancelled evaluation} { set a 1 expr {1?2:[set a 2]} set a } 1 catch {unset x} test expr-27.5 {cancelled evaluation} { list [catch {expr {[info exists x] && $x}} msg] $msg } {0 0} test expr-27.6 {cancelled evaluation} { list [catch {expr {0 && [concat $x]}} msg] $msg } {0 0} test expr-27.7 {cancelled evaluation} { set one 1 list [catch {expr {1 || 1/$one}} msg] $msg } {0 1} test expr-27.8 {cancelled evaluation} { list [catch {expr {1 || -"string"}} msg] $msg } {0 1} test expr-27.9 {cancelled evaluation} { list [catch {expr {1 || ("string" * ("x" && "y"))}} msg] $msg } {0 1} test expr-27.10 {cancelled evaluation} { set x -1.0 list [catch {expr {($x > 0) ? round(log($x)) : 0}} msg] $msg } {0 0} # Tcl_ExprBool as used in "if" statements test expr-28.1 {Tcl_ExprBoolean usage} { set a 1 if {2} {set a 2} set a } 2 test expr-28.2 {Tcl_ExprBoolean usage} { set a 1 if {0} {set a 2} set a } 1 test expr-28.3 {Tcl_ExprBoolean usage} { set a 1 if {1.2} {set a 2} set a } 2 test expr-28.4 {Tcl_ExprBoolean usage} { set a 1 if {-1.1} {set a 2} set a } 2 test expr-28.5 {Tcl_ExprBoolean usage} { set a 1 if {0.0} {set a 2} set a } 1 test expr-28.6 {Tcl_ExprBoolean usage} { set a 1 if {"YES"} {set a 2} set a } 2 test expr-28.7 {Tcl_ExprBoolean usage} { set a 1 if {"no"} {set a 2} set a } 1 test expr-28.8 {Tcl_ExprBoolean usage} { set a 1 if {"true"} {set a 2} set a } 2 test expr-28.9 {Tcl_ExprBoolean usage} { set a 1 if {"fAlse"} {set a 2} set a } 1 test expr-28.10 {Tcl_ExprBoolean usage} { set a 1 if {"on"} {set a 2} set a } 2 test expr-28.11 {Tcl_ExprBoolean usage} { set a 1 if {"Off"} {set a 2} set a } 1 test expr-28.12 {Tcl_ExprBool usage} { list [catch {if {"abc"} {}} msg] $msg } {1 {expected boolean value but got "abc"}} test expr-28.13 {Tcl_ExprBool usage} { list [catch {if {"ogle"} {}} msg] $msg } {1 {expected boolean value but got "ogle"}} test expr-28.14 {Tcl_ExprBool usage} { list [catch {if {"o"} {}} msg] $msg } {1 {expected boolean value but got "o"}} # Operands enclosed in braces test expr-29.1 {braces} {expr {{abc}}} abc test expr-29.2 {braces} {expr {{00010}}} 8 test expr-29.3 {braces} {expr {{3.1200000}}} 3.12 test expr-29.4 {braces} {expr {{a{b}{1 {2 3}}c}}} "a{b}{1 {2 3}}c" test expr-29.5 {braces} { list [catch {expr "\{abc"} msg] $msg } {1 {missing close-brace}} # Very long values test expr-30.1 {long values} { set a "0000 1111 2222 3333 4444" set a "$a | $a | $a | $a | $a" set a "$a || $a || $a || $a || $a" expr {$a} } {0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 || 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 || 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 || 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 || 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444 | 0000 1111 2222 3333 4444} test expr-30.2 {long values} { set a "000000000000000000000000000000" set a "$a$a$a$a$a$a$a$a$a$a$a$a$a$a$a$a${a}5" expr $a } 5 # Expressions spanning multiple arguments test expr-31.1 {multiple arguments to expr command} { expr 4 + ( 6 *12) -3 } 73 test expr-31.2 {multiple arguments to expr command} { list [catch {expr 2 + (3 + 4} msg] $msg } {1 {unmatched parentheses in expression "2 + (3 + 4"}} test expr-31.3 {multiple arguments to expr command} { list [catch {expr 2 + 3 +} msg] $msg } {1 {syntax error in expression "2 + 3 +"}} test expr-31.4 {multiple arguments to expr command} { list [catch {expr 2 + 3 )} msg] $msg } {1 {syntax error in expression "2 + 3 )"}} # Math functions test expr-32.1 {math functions in expressions} { expr acos(0.5) } {1.0472} test expr-32.2 {math functions in expressions} { expr asin(0.5) } {0.523599} test expr-32.3 {math functions in expressions} { expr atan(1.0) } {0.785398} test expr-32.4 {math functions in expressions} { expr atan2(2.0, 2.0) } {0.785398} test expr-32.5 {math functions in expressions} { expr ceil(1.999) } {2.0} test expr-32.6 {math functions in expressions} { expr cos(.1) } {0.995004} test expr-32.7 {math functions in expressions} { expr cosh(.1) } {1.005} test expr-32.8 {math functions in expressions} { expr exp(1.0) } {2.71828} test expr-32.9 {math functions in expressions} { expr floor(2.000) } {2.0} test expr-32.10 {math functions in expressions} { expr floor(2.001) } {2.0} test expr-32.11 {math functions in expressions} { expr fmod(7.3, 3.2) } {0.9} test expr-32.12 {math functions in expressions} { expr hypot(3.0, 4.0) } {5.0} test expr-32.13 {math functions in expressions} { expr log(2.8) } {1.02962} test expr-32.14 {math functions in expressions} { expr log10(2.8) } {0.447158} test expr-32.15 {math functions in expressions} { expr pow(2.1, 3.1) } {9.97424} test expr-32.16 {math functions in expressions} { expr sin(.1) } {0.0998334} test expr-32.17 {math functions in expressions} { expr sinh(.1) } {0.100167} test expr-32.18 {math functions in expressions} { expr sqrt(2.0) } {1.41421} test expr-32.19 {math functions in expressions} { expr tan(0.8) } {1.02964} test expr-32.20 {math functions in expressions} { expr tanh(0.8) } {0.664037} test expr-32.21 {math functions in expressions} { expr abs(-1.8) } {1.8} test expr-32.22 {math functions in expressions} { expr abs(10.0) } {10.0} test expr-32.23 {math functions in expressions} { expr abs(-4) } {4} test expr-32.24 {math functions in expressions} { expr abs(66) } {66} if ($doNonPortableTests) { test expr-32.25 {math functions in expressions} { list [catch {expr abs(0x80000000)} msg] $msg } {1 {integer value too large to represent}} } test expr-32.26 {math functions in expressions} { expr double(1) } {1.0} test expr-32.27 {math functions in expressions} { expr double(1.1) } {1.1} test expr-32.28 {math functions in expressions} { expr int(1) } {1} test expr-32.29 {math functions in expressions} { expr int(1.4) } {1} test expr-32.30 {math functions in expressions} { expr int(1.6) } {1} test expr-32.31 {math functions in expressions} { expr int(-1.4) } {-1} test expr-32.32 {math functions in expressions} { expr int(-1.6) } {-1} test expr-32.33 {math functions in expressions} { list [catch {expr int(1e60)} msg] $msg } {1 {integer value too large to represent}} test expr-32.34 {math functions in expressions} { list [catch {expr int(-1e60)} msg] $msg } {1 {integer value too large to represent}} test expr-32.35 {math functions in expressions} { expr round(1.49) } {1} test expr-32.36 {math functions in expressions} { expr round(1.51) } {2} test expr-32.37 {math functions in expressions} { expr round(-1.49) } {-1} test expr-32.38 {math functions in expressions} { expr round(-1.51) } {-2} test expr-32.39 {math functions in expressions} { list [catch {expr round(1e60)} msg] $msg } {1 {integer value too large to represent}} test expr-32.40 {math functions in expressions} { list [catch {expr round(-1e60)} msg] $msg } {1 {integer value too large to represent}} test expr-32.41 {math functions in expressions} { list [catch {expr pow(1.0 + 3.0 - 2, .8 * 5)} msg] $msg } {0 16.0} test expr-32.42 {math functions in expressions} { list [catch {expr hypot(5*.8,3)} msg] $msg } {0 5.0} if $gotT1 { test expr-32.43 {math functions in expressions} { expr 2*T1() } 246 test expr-32.44 {math functions in expressions} { expr T2()*3 } 1035 } test expr-33.1 {conversions and fancy args to math functions} { expr hypot ( 3 , 4 ) } 5.0 test expr-33.2 {conversions and fancy args to math functions} { expr hypot ( (2.0+1.0) , 4 ) } 5.0 test expr-33.3 {conversions and fancy args to math functions} { expr hypot ( 3 , (3.0 + 1.0) ) } 5.0 test expr-33.4 {conversions and fancy args to math functions} { expr cos(acos(0.1)) } 0.1 test expr-34.1 {errors in math functions} { list [catch {expr func_2(1.0)} msg] $msg } {1 {unknown math function "func_2"}} test expr-34.2 {errors in math functions} { list [catch {expr func|(1.0)} msg] $msg } {1 {syntax error in expression "func|(1.0)"}} test expr-34.3 {errors in math functions} { list [catch {expr {hypot("a b", 2.0)}} msg] $msg } {1 {argument to math function didn't have numeric value}} test expr-34.4 {errors in math functions} { list [catch {expr hypot(1.0 2.0)} msg] $msg } {1 {syntax error in expression "hypot(1.0 2.0)"}} test expr-34.5 {errors in math functions} { list [catch {expr hypot(1.0, 2.0} msg] $msg } {1 {syntax error in expression "hypot(1.0, 2.0"}} test expr-34.6 {errors in math functions} { list [catch {expr hypot(1.0 ,} msg] $msg } {1 {syntax error in expression "hypot(1.0 ,"}} test expr-34.7 {errors in math functions} { list [catch {expr hypot(1.0)} msg] $msg } {1 {too few arguments for math function}} test expr-34.8 {errors in math functions} { list [catch {expr hypot(1.0, 2.0, 3.0)} msg] $msg } {1 {too many arguments for math function}} test expr-34.9 {errors in math functions} { list [catch {expr acos(-2.0)} msg] $msg $errorCode } {1 {domain error: argument not in valid range} {ARITH DOMAIN {domain error: argument not in valid range}}} if $doNonPortableTests { test expr-34.10 {errors in math functions} { list [catch {expr pow(-3, 1000001)} msg] $msg $errorCode } {1 {floating-point value too large to represent} {ARITH OVERFLOW {floating-point value too large to represent}}} } test expr-34.11 {errors in math functions} { list [catch {expr pow(3, 1000001)} msg] $msg $errorCode } {1 {floating-point value too large to represent} {ARITH OVERFLOW {floating-point value too large to represent}}} test expr-34.12 {errors in math functions} { list [catch {expr -14.0*exp(100000)} msg] $msg $errorCode } {1 {floating-point value too large to represent} {ARITH OVERFLOW {floating-point value too large to represent}}} test expr-34.13 {errors in math functions} { list [catch {expr int(1.0e30)} msg] $msg $errorCode } {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}} test expr-34.14 {errors in math functions} { list [catch {expr int(-1.0e30)} msg] $msg $errorCode } {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}} test expr-34.15 {errors in math functions} { list [catch {expr round(1.0e30)} msg] $msg $errorCode } {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}} test expr-34.16 {errors in math functions} { list [catch {expr round(-1.0e30)} msg] $msg $errorCode } {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}} if $gotT1 { test expr-34.17 {errors in math functions} { list [catch {expr T1(4)} msg] $msg } {1 {syntax error in expression "T1(4)"}} } catch {unset tcl_precision} test expr-35.1 {tcl_precision variable} { expr 2.0/3 } 0.666667 set tcl_precision 1 test expr-35.2 {tcl_precision variable} { expr 2.0/3 } 0.7 test expr-35.3 {tcl_precision variable} { expr 2.0/3 } 0.7 test expr-35.4 {tcl_precision variable} { list [catch {set tcl_precision 0} msg] $msg [expr 2.0/3] } {1 {can't set "tcl_precision": improper value for precision} 0.7} test expr-35.5 {tcl_precision variable} { list [catch {set tcl_precision 101} msg] $msg [expr 2.0/3] } {1 {can't set "tcl_precision": improper value for precision} 0.7} test expr-35.6 {tcl_precision variable} { list [catch {set tcl_precision {}} msg] $msg [expr 2.0/3] } {1 {can't set "tcl_precision": improper value for precision} 0.7} test expr-35.7 {tcl_precision variable} { list [catch {set tcl_precision {1 2 3}} msg] $msg [expr 2.0/3] } {1 {can't set "tcl_precision": improper value for precision} 0.7} catch {unset tcl_precision} test expr-35.8 {tcl_precision variable} { expr 2.0/3 } 0.666667 test expr-36.1 {ExprLooksLikeInt procedure} { list [catch {expr 0289} msg] $msg } {1 {syntax error in expression "0289"}} test expr-36.2 {ExprLooksLikeInt procedure} { set x 0289 list [catch {expr {$x+1}} msg] $msg } {1 {can't use non-numeric string as operand of "+"}} test expr-36.3 {ExprLooksLikeInt procedure} { list [catch {expr 0289.1} msg] $msg } {0 289.1} test expr-36.4 {ExprLooksLikeInt procedure} { set x 0289.1 list [catch {expr {$x+1}} msg] $msg } {0 290.1} test expr-36.5 {ExprLooksLikeInt procedure} { set x { +22} list [catch {expr {$x+1}} msg] $msg } {0 23} test expr-36.6 {ExprLooksLikeInt procedure} { set x { -22} list [catch {expr {$x+1}} msg] $msg } {0 -21} if $doNonPortableTests { test expr-36.7 {ExprLooksLikeInt procedure} { list [catch {expr nan} msg] $msg } {1 {domain error: argument not in valid range}} } test expr-36.8 {ExprLooksLikeInt procedure} { list [catch {expr 78e1} msg] $msg } {0 780.0} test expr-36.9 {ExprLooksLikeInt procedure} { list [catch {expr 24E1} msg] $msg } {0 240.0} if $doNonPortableTests { test expr-36.10 {ExprLooksLikeInt procedure} { list [catch {expr 78e} msg] $msg } {1 {syntax error in expression "78e"}} } # Special test for Pentium arithmetic bug of 1994: if {(4195835.0 - (4195835.0/3145727.0)*3145727.0) == 256.0} { puts "Warning: this machine contains a defective Pentium processor" puts "that performs arithmetic incorrectly. I recommend that you" puts "call Intel customer service immediately at 1-800-628-8686" puts "to request a replacement processor." } "2 + (3 + 4"}} test expr-31.3 {multiple arguments to expr command} { list [catch {expr 2 + 3 +} msg] $msg } {1 {syntax error in expression "2 + 3 +"}}tcl7.4b4/tests/file.test010044400630510000012000000271550567470012000160170ustar00ousterstaff00002300000001# Commands covered: file # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1994 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # @(#) file.test 1.25 94/12/17 16:19:56 if {[string compare test [info procs test]] == 1} then {source defs} # rootname and ext test file-1.1 {rootname and extension options} {file ext abc.def} .def test file-1.2 {rootname and extension options} {file ro abc.def} abc test file-1.3 {rootname and extension options} {file extension a/b/c.d} .d test file-1.4 {rootname and extension options} {file rootname a/b/c.d} a/b/c test file-1.5 {rootname and extension options} {file extension a/b.c/d} {} test file-1.6 {rootname and extension options} {file rootname a/b.c/d} a/b.c/d set num 7 foreach outer { {} a .a a. a.a } { foreach inner { {} a .a a. a.a } { set thing [format %s/%s $outer $inner] test file-1.$num {rootname and extension options} { format %s%s [file rootname $thing] [file ext $thing] } $thing set num [expr $num+1] } } # dirname and tail test file-2.1 {dirname and tail options} {file dirname .def} . test file-2.2 {dirname and tail options} {file tail abc.def} abc.def test file-2.3 {dirname and tail options} {file d a/b/c.d} a/b test file-2.4 {dirname and tail options} {file ta a/b/c.d} c.d test file-2.5 {dirname and tail options} {file dirname a/b.c/d} a/b.c test file-2.6 {dirname and tail options} {file tail a/b.c/d} d set num 7 foreach outer { a .a a. a.a } { foreach inner { {} a .a a. a.a } { set thing [format %s/%s $outer $inner] test file-2.$num {dirname and tail options} { format %s/%s [file dirname $thing] [file tail $thing] } $thing set num [expr $num+1] } } # exists catch {exec chmod 777 dir.file} catch {exec rm -f dir.file/gorp.file} catch {exec rm -f gorp.file} catch {exec rmdir dir.file} catch {exec rm -f link.file} test file-3.1 {exists option} {file exists gorp.file} 0 test file-3.2 {exists option} {file exists dir.file/gorp.file} 0 exec cat > gorp.file << abcde exec mkdir dir.file exec cat > dir.file/gorp.file << 12345 test file-3.3 {exists option} {file exists gorp.file} 1 test file-3.4 {exists option} {file exi dir.file/gorp.file} 1 # The test below has to be done in /tmp rather than the current # directory in order to guarantee (?) a local file system: some # NFS file systems won't do the stuff below correctly. catch {exec rm /tmp/tcl.foo.dir/file} catch {exec rmdir /tmp/tcl.foo.dir} exec mkdir /tmp/tcl.foo.dir exec cat > /tmp/tcl.foo.dir/file << 12345 exec chmod 000 /tmp/tcl.foo.dir if {$user != "root"} { test file-3.5 {exists option} {file exists /tmp/tcl.foo.dir/file} 0 } exec chmod 775 /tmp/tcl.foo.dir exec rm /tmp/tcl.foo.dir/file exec rmdir /tmp/tcl.foo.dir # executable exec chmod 000 dir.file if {$user != "root"} { test file-4.1 {executable option} {file executable gorp.file} 0 } exec chmod 775 gorp.file test file-4.2 {executable option} {file exe gorp.file} 1 # isdirectory test file-5.1 {isdirectory option} {file isdirectory gorp.file} 0 test file-5.2 {isdirectory option} {file isd dir.file} 1 # isfile test file-6.1 {isfile option} {file isfile gorp.file} 1 test file-6.2 {isfile option} {file isfile dir.file} 0 # isowned test file-7.1 {owned option} {file owned gorp.file} 1 if {$user != "root"} { test file-7.2 {owned option} {file owned /} 0 } # readable exec chmod 444 gorp.file test file-8.1 {readable option} {file readable gorp.file} 1 exec chmod 333 gorp.file if {$user != "root"} { test file-8.2 {readable option} {file reada gorp.file} 0 } # writable exec chmod 555 gorp.file if {$user != "root"} { test file-9.1 {writable option} {file writable gorp.file} 0 } exec chmod 222 gorp.file test file-9.2 {writable option} {file w gorp.file} 1 # stat exec cat > gorp.file << "Test string" exec chmod 765 gorp.file test file-10.1 {stat option} { catch {unset stat} file stat gorp.file stat lsort [array names stat] } {atime ctime dev gid ino mode mtime nlink size type uid} test file-10.2 {stat option} { catch {unset stat} file stat gorp.file stat list $stat(nlink) $stat(size) [expr $stat(mode)&0777] $stat(type) } {1 11 501 file} test file-10.3 {stat option} { string tolower [list [catch {file stat _bogus_ stat} msg] \ $msg $errorCode] } {1 {couldn't stat "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} test file-10.4 {stat option} { list [catch {file stat _bogus_} msg] $msg $errorCode } {1 {wrong # args: should be "file stat name varName"} NONE} test file-10.5 {stat option} { list [catch {file stat _bogus_ a b} msg] $msg $errorCode } {1 {wrong # args: should be "file stat name varName"} NONE} test file-10.6 {stat option} { catch {unset x} set x 44 list [catch {file stat gorp.file x} msg] $msg $errorCode } {1 {can't set "x(dev)": variable isn't array} NONE} catch {unset stat} # mtime, and size (I've given up trying to find a test for "atime": there # seem to be too many quirks in the way file systems handle this to come # up with a reproducible test). test file-11.1 {mtime and atime and size options} { catch {unset stat} file stat gorp.file stat list [expr {[file mtime gorp.file] == $stat(mtime)}] \ [expr {[file atime gorp.file] == $stat(atime)}] \ [file size gorp.file] } {1 1 11} test file-11.2 {mtime option} { set old [file mtime gorp.file] exec sleep 2 set f [open gorp.file w] puts $f "More text" close $f set new [file mtime gorp.file] expr {($new > $old) && ($new <= ($old+5))} } {1} test file-11.3 {size option} { set oldsize [file size gorp.file] set f [open gorp.file a] puts $f "More text" close $f expr {[file size gorp.file] - $oldsize} } {10} test file-11.4 {errors in atime option} { list [catch {file atime _bogus_ x} msg] $msg $errorCode } {1 {wrong # args: should be "file atime name"} NONE} test file-11.5 {errors in atime option} { string tolower [list [catch {file atime _bogus_} msg] \ $msg $errorCode] } {1 {couldn't stat "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} test file-11.6 {errors in mtime option} { list [catch {file mtime _bogus_ x} msg] $msg $errorCode } {1 {wrong # args: should be "file mtime name"} NONE} test file-11.7 {errors in mtime option} { string tolower [list [catch {file mtime _bogus_} msg] $msg \ $errorCode] } {1 {couldn't stat "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} test file-11.8 {errors in size option} { list [catch {file size _bogus_ x} msg] $msg $errorCode } {1 {wrong # args: should be "file size name"} NONE} test file-11.9 {errors in size option} { string tolower [list [catch {file size _bogus_} msg] $msg \ $errorCode] } {1 {couldn't stat "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} # type test file-12.1 {type option} { file type dir.file } directory test file-12.2 {type option} { file type gorp.file } file if $doNonPortableTests { exec ln -s a/b/c link.file test file-12.3 {type option} { file type link.file } link exec rm link.file } test file-12.4 {errors in type option} { list [catch {file type a b} msg] $msg $errorCode } {1 {wrong # args: should be "file type name"} NONE} test file-12.5 {errors in type option} { string tolower [list [catch {file type _bogus_} msg] $msg $errorCode] } {1 {couldn't stat "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} # lstat and readlink: don't run these tests everywhere, since not all # sites will have symbolic links if $doNonPortableTests { exec ln -s gorp.file link.file test file-13.1 {lstat option} { catch {unset stat} file lstat link.file stat lsort [array names stat] } {atime ctime dev gid ino mode mtime nlink size type uid} test file-13.1 {lstat option} { catch {unset stat} file lstat link.file stat list $stat(nlink) [expr $stat(mode)&0777] $stat(type) } {1 511 link} test file-13.3 {errors in lstat option} { string tolower [list [catch {file lstat _bogus_ stat} msg] \ $msg $errorCode] } {1 {couldn't lstat "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} test file-13.4 {errors in lstat option} { list [catch {file lstat _bogus_} msg] $msg $errorCode } {1 {wrong # args: should be "file lstat name varName"} NONE} test file-13.5 {errors in lstat option} { list [catch {file lstat _bogus_ a b} msg] $msg $errorCode } {1 {wrong # args: should be "file lstat name varName"} NONE} test file-13.6 {errors in lstat option} { catch {unset x} set x 44 list [catch {file lstat gorp.file x} msg] $msg $errorCode } {1 {can't set "x(dev)": variable isn't array} NONE} catch {unset stat} test file-14.1 {readlink option} { file readlink link.file } gorp.file test file-14.2 {errors in readlink option} { list [catch {file readlink a b} msg] $msg $errorCode } {1 {wrong # args: should be "file readlink name"} NONE} test file-14.3 {errors in readlink option} { list [catch {file readlink _bogus_} msg] [string tolower $msg] \ [string tolower $errorCode] } {1 {couldn't readlink "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} exec rm link.file } # Error conditions test file-15.1 {error conditions} { list [catch file msg] $msg } {1 {wrong # args: should be "file option name ?arg ...?"}} test file-15.2 {error conditions} { list [catch {file x} msg] $msg } {1 {wrong # args: should be "file option name ?arg ...?"}} test file-15.3 {error conditions} { list [catch {file exists x too} msg] $msg } {1 {wrong # args: should be "file exists name"}} test file-15.4 {error conditions} { list [catch {file gorp x} msg] $msg } {1 {bad option "gorp": should be atime, dirname, executable, exists, extension, isdirectory, isfile, lstat, mtime, owned, readable, readlink, root, size, stat, tail, type, or writable}} test file-15.5 {error conditions} { list [catch {file ex x} msg] $msg } {1 {bad option "ex": should be atime, dirname, executable, exists, extension, isdirectory, isfile, lstat, mtime, owned, readable, readlink, root, size, stat, tail, type, or writable}} test file-15.6 {error conditions} { list [catch {file is x} msg] $msg } {1 {bad option "is": should be atime, dirname, executable, exists, extension, isdirectory, isfile, lstat, mtime, owned, readable, readlink, root, size, stat, tail, type, or writable}} test file-15.7 {error conditions} { list [catch {file read x} msg] $msg } {1 {bad option "read": should be atime, dirname, executable, exists, extension, isdirectory, isfile, lstat, mtime, owned, readable, readlink, root, size, stat, tail, type, or writable}} test file-15.8 {error conditions} { list [catch {file s x} msg] $msg } {1 {bad option "s": should be atime, dirname, executable, exists, extension, isdirectory, isfile, lstat, mtime, owned, readable, readlink, root, size, stat, tail, type, or writable}} test file-15.9 {error conditions} { list [catch {file t x} msg] $msg } {1 {bad option "t": should be atime, dirname, executable, exists, extension, isdirectory, isfile, lstat, mtime, owned, readable, readlink, root, size, stat, tail, type, or writable}} test file-15.10 {error conditions} { list [catch {file rootname ~woohgy} msg] $msg } {1 {user "woohgy" doesn't exist}} exec chmod 777 dir.file exec rm dir.file/gorp.file gorp.file exec rmdir dir.file tcl7.4b4/tests/for.test010044400630510000012000000077340567470012000156670ustar00ousterstaff00002300000001# Commands covered: foreach, for, continue, break # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # @(#) for.test 1.9 94/12/17 16:19:57 if {[string compare test [info procs test]] == 1} then {source defs} # Basic "foreach" operation. test for-1.1 {basic foreach tests} { set a {} foreach i {a b c d} { set a [concat $a $i] } set a } {a b c d} test for-1.2 {basic foreach tests} { set a {} foreach i {a b {{c d} e} {123 {{x}}}} { set a [concat $a $i] } set a } {a b {c d} e 123 {{x}}} test for-1.3 {basic foreach tests} {catch {foreach} msg} 1 test for-1.4 {basic foreach tests} { catch {foreach} msg set msg } {wrong # args: should be "foreach varName list command"} test for-1.5 {basic foreach tests} {catch {foreach i} msg} 1 test for-1.6 {basic foreach tests} { catch {foreach i} msg set msg } {wrong # args: should be "foreach varName list command"} test for-1.7 {basic foreach tests} {catch {foreach i j} msg} 1 test for-1.8 {basic foreach tests} { catch {foreach i j} msg set msg } {wrong # args: should be "foreach varName list command"} test for-1.9 {basic foreach tests} {catch {foreach i j k l} msg} 1 test for-1.10 {basic foreach tests} { catch {foreach i j k l} msg set msg } {wrong # args: should be "foreach varName list command"} test for-1.11 {basic foreach tests} { set a {} foreach i {} { set a [concat $a $i] } set a } {} test for-1.11 {foreach errors} { catch {unset a} set a(0) 44 list [catch {foreach a {1 2 3} {}} msg] $msg } {1 {couldn't set loop variable}} catch {unset a} # Check "continue". test for-2.1 {continue tests} {catch continue} 4 test for-2.2 {continue tests} { set a {} foreach i {a b c d} { if {[string compare $i "b"] == 0} continue set a [concat $a $i] } set a } {a c d} test for-2.3 {continue tests} { set a {} foreach i {a b c d} { if {[string compare $i "b"] != 0} continue set a [concat $a $i] } set a } {b} test for-2.4 {continue tests} {catch {continue foo} msg} 1 test for-2.5 {continue tests} { catch {continue foo} msg set msg } {wrong # args: should be "continue"} # Check "break". test for-3.1 {break tests} {catch break} 3 test for-3.2 {break tests} { set a {} foreach i {a b c d} { if {[string compare $i "c"] == 0} break set a [concat $a $i] } set a } {a b} test for-3.3 {break tests} {catch {break foo} msg} 1 test for-3.4 {break tests} { catch {break foo} msg set msg } {wrong # args: should be "break"} # Check "for" and its use of continue and break. test for-4.1 {for tests} { set a {} for {set i 1} {$i<6} {set i [expr $i+1]} { set a [concat $a $i] } set a } {1 2 3 4 5} test for-4.2 {for tests} { set a {} for {set i 1} {$i<6} {set i [expr $i+1]} { if $i==4 continue set a [concat $a $i] } set a } {1 2 3 5} test for-4.3 {for tests} { set a {} for {set i 1} {$i<6} {set i [expr $i+1]} { if $i==4 break set a [concat $a $i] } set a } {1 2 3} test for-4.4 {for tests} {catch {for 1 2 3} msg} 1 test for-4.5 {for tests} { catch {for 1 2 3} msg set msg } {wrong # args: should be "for start test next command"} test for-4.6 {for tests} {catch {for 1 2 3 4 5} msg} 1 test for-4.7 {for tests} { catch {for 1 2 3 4 5} msg set msg } {wrong # args: should be "for start test next command"} test for-4.8 {for tests} { set a {xyz} for {set i 1} {$i<6} {set i [expr $i+1]} {} set a } xyz test for-4.9 {for tests} { set a {} for {set i 1} {$i<6} {set i [expr $i+1]; if $i==4 break} { set a [concat $a $i] } set a } {1 2 3} # Check "continue". test for-2.1 {tcl7.4b4/tests/format.test010044400630510000012000000320230567470012000163560ustar00ousterstaff00002300000001# Commands covered: format # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1994 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # @(#) format.test 1.19 94/12/17 16:19:58 if {[string compare test [info procs test]] == 1} then {source defs} # The following code is needed because some versions of SCO Unix have # a round-off error in sprintf which would cause some of the tests to # fail. Someday I hope this code shouldn't be necessary (code added # 9/9/91). set roundOffBug 0 if {"[format %7.1e 68.514]" == "6.8e+01"} { puts stdout "Note: this system has a sprintf round-off bug, some tests skipped\n" set roundOffBug 1 } test format-1.1 {integer formatting} { format "%*d %d %d %d" 6 34 16923 -12 -1 } { 34 16923 -12 -1} if $doNonPortableTests { test format-1.2 {integer formatting} { format "%4d %4d %4d %4d %d %#x %#X" 6 34 16923 -12 -1 14 12 } { 6 34 16923 -12 -1 0xe 0XC} } # %u output depends on word length, so this test is not portable. if $doNonPortableTests { test format-1.3 {integer formatting} { format "%4u %4u %4u %4u %d %#o" 6 34 16923 -12 -1 0 } { 6 34 16923 4294967284 -1 0} } test format-1.4 {integer formatting} { format "%-4d %-4i %-4d %-4ld" 6 34 16923 -12 -1 } {6 34 16923 -12 } test format-1.5 {integer formatting} { format "%04d %04d %04d %04i" 6 34 16923 -12 -1 } {0006 0034 16923 -012} test format-1.6 {integer formatting} { format "%00*d" 6 34 } {000034} # Printing negative numbers in hex or octal format depends on word # length, so these tests are not portable. if $doNonPortableTests { test format-1.7 {integer formatting} { format "%4x %4x %4x %4x" 6 34 16923 -12 -1 } { 6 22 421b fffffff4} test format-1.8 {integer formatting} { format "%#x %#X %#X %#x" 6 34 16923 -12 -1 } {0x6 0X22 0X421B 0xfffffff4} test format-1.9 {integer formatting} { format "%#20x %#20x %#20x %#20x" 6 34 16923 -12 -1 } { 0x6 0x22 0x421b 0xfffffff4} test format-1.10 {integer formatting} { format "%-#20x %-#20x %-#20x %-#20x" 6 34 16923 -12 -1 } {0x6 0x22 0x421b 0xfffffff4 } test format-1.11 {integer formatting} { format "%-#20o %#-20o %#-20o %#-20o" 6 34 16923 -12 -1 } {06 042 041033 037777777764 } } test format-2.1 {string formatting} { format "%s %s %c %s" abcd {This is a very long test string.} 120 x } {abcd This is a very long test string. x x} test format-2.2 {string formatting} { format "%20s %20s %20c %20s" abcd {This is a very long test string.} 120 x } { abcd This is a very long test string. x x} test format-2.3 {string formatting} { format "%.10s %.10s %c %.10s" abcd {This is a very long test string.} 120 x } {abcd This is a x x} test format-2.4 {string formatting} { format "%s %s %% %c %s" abcd {This is a very long test string.} 120 x } {abcd This is a very long test string. % x x} test format-3.1 {e and f formats} { format "%e %e %e %e" 34.2e12 68.514 -.125 -16000. .000053 } {3.420000e+13 6.851400e+01 -1.250000e-01 -1.600000e+04} test format-3.2 {e and f formats} { format "%20e %20e %20e %20e" 34.2e12 68.514 -.125 -16000. .000053 } { 3.420000e+13 6.851400e+01 -1.250000e-01 -1.600000e+04} if {!$roundOffBug} { test format-3.3 {e and f formats} { format "%.1e %.1e %.1e %.1e" 34.2e12 68.514 -.126 -16000. .000053 } {3.4e+13 6.9e+01 -1.3e-01 -1.6e+04} test format-3.4 {e and f formats} { format "%020e %020e %020e %020e" 34.2e12 68.514 -.126 -16000. .000053 } {000000003.420000e+13 000000006.851400e+01 -00000001.260000e-01 -00000001.600000e+04} test format-3.5 {e and f formats} { format "%7.1e %7.1e %7.1e %7.1e" 34.2e12 68.514 -.126 -16000. .000053 } {3.4e+13 6.9e+01 -1.3e-01 -1.6e+04} test format-3.6 {e and f formats} { format "%f %f %f %f" 34.2e12 68.514 -.125 -16000. .000053 } {34200000000000.000000 68.514000 -0.125000 -16000.000000} } test format-3.7 {e and f formats} { format "%.4f %.4f %.4f %.4f %.4f" 34.2e12 68.514 -.125 -16000. .000053 } {34200000000000.0000 68.5140 -0.1250 -16000.0000 0.0001} test format-3.8 {e and f formats} { format "%.4e %.5e %.6e" -9.99996 -9.99996 9.99996 } {-1.0000e+01 -9.99996e+00 9.999960e+00} test format-3.9 {e and f formats} { format "%.4f %.5f %.6f" -9.99996 -9.99996 9.99996 } {-10.0000 -9.99996 9.999960} test format-3.10 {e and f formats} { format "%20f %-20f %020f" -9.99996 -9.99996 9.99996 } { -9.999960 -9.999960 0000000000009.999960} test format-3.11 {e and f formats} { format "%-020f %020f" -9.99996 -9.99996 9.99996 } {-9.999960 -000000000009.999960} test format-3.12 {e and f formats} { format "%.0e %#.0e" -9.99996 -9.99996 9.99996 } {-1e+01 -1.e+01} test format-3.13 {e and f formats} { format "%.0f %#.0f" -9.99996 -9.99996 9.99996 } {-10 -10.} test format-3.14 {e and f formats} { format "%.4f %.5f %.6f" -9.99996 -9.99996 9.99996 } {-10.0000 -9.99996 9.999960} test format-3.15 {e and f formats} { format "%3.0f %3.0f %3.0f %3.0f" 1.0 1.1 1.01 1.001 } { 1 1 1 1} test format-3.16 {e and f formats} { format "%3.1f %3.1f %3.1f %3.1f" 0.0 0.1 0.01 0.001 } {0.0 0.1 0.0 0.0} test format-4.1 {g-format} { format "%.3g" 12341.0 } {1.23e+04} test format-4.2 {g-format} { format "%.3G" 1234.12345 } {1.23E+03} test format-4.3 {g-format} { format "%.3g" 123.412345 } {123} test format-4.4 {g-format} { format "%.3g" 12.3412345 } {12.3} test format-4.5 {g-format} { format "%.3g" 1.23412345 } {1.23} test format-4.6 {g-format} { format "%.3g" 1.23412345 } {1.23} test format-4.7 {g-format} { format "%.3g" .123412345 } {0.123} test format-4.8 {g-format} { format "%.3g" .012341 } {0.0123} test format-4.9 {g-format} { format "%.3g" .0012341 } {0.00123} test format-4.10 {g-format} { format "%.3g" .00012341 } {0.000123} test format-4.11 {g-format} { format "%.3g" .00001234 } {1.23e-05} test format-4.12 {g-format} { format "%.4g" 9999.6 } {1e+04} test format-4.13 {g-format} { format "%.4g" 999.96 } {1000} test format-4.14 {g-format} { format "%.3g" 1.0 } {1} test format-4.15 {g-format} { format "%.3g" .1 } {0.1} test format-4.16 {g-format} { format "%.3g" .01 } {0.01} test format-4.17 {g-format} { format "%.3g" .001 } {0.001} test format-4.19 {g-format} { format "%.3g" .00001 } {1e-05} test format-4.20 {g-format} { format "%#.3g" 1234.0 } {1.23e+03} test format-4.21 {g-format} { format "%#.3G" 9999.5 } {1.00E+04} test format-5.1 {floating-point zeroes} { format "%e %f %g" 0.0 0.0 0.0 0.0 } {0.000000e+00 0.000000 0} test format-5.2 {floating-point zeroes} { format "%.4e %.4f %.4g" 0.0 0.0 0.0 0.0 } {0.0000e+00 0.0000 0} test format-5.3 {floating-point zeroes} { format "%#.4e %#.4f %#.4g" 0.0 0.0 0.0 0.0 } {0.0000e+00 0.0000 0.000} test format-5.4 {floating-point zeroes} { format "%.0e %.0f %.0g" 0.0 0.0 0.0 0.0 } {0e+00 0 0} test format-5.5 {floating-point zeroes} { format "%#.0e %#.0f %#.0g" 0.0 0.0 0.0 0.0 } {0.e+00 0. 0.} test format-5.6 {floating-point zeroes} { format "%3.0f %3.0f %3.0f %3.0f" 0.0 0.0 0.0 0.0 } { 0 0 0 0} test format-5.7 {floating-point zeroes} { format "%3.0f %3.0f %3.0f %3.0f" 1.0 1.1 1.01 1.001 } { 1 1 1 1} test format-5.8 {floating-point zeroes} { format "%3.1f %3.1f %3.1f %3.1f" 0.0 0.1 0.01 0.001 } {0.0 0.1 0.0 0.0} test format-6.1 {various syntax features} { format "%*.*f" 12 3 12.345678901 } { 12.346} test format-6.2 {various syntax features} { format "%0*.*f" 12 3 12.345678901 } {00000012.346} test format-6.3 {various syntax features} { format "\*\t\\n" } {* \n} test format-7.1 {error conditions} { catch format } 1 test format-7.2 {error conditions} { catch format msg set msg } {wrong # args: should be "format formatString ?arg arg ...?"} test format-7.3 {error conditions} { catch {format %*d} } 1 test format-7.4 {error conditions} { catch {format %*d} msg set msg } {not enough arguments for all format specifiers} test format-7.5 {error conditions} { catch {format %*.*f 12} } 1 test format-7.6 {error conditions} { catch {format %*.*f 12} msg set msg } {not enough arguments for all format specifiers} test format-7.7 {error conditions} { catch {format %*.*f 12 3} } 1 test format-7.8 {error conditions} { catch {format %*.*f 12 3} msg set msg } {not enough arguments for all format specifiers} test format-7.9 {error conditions} { list [catch {format %*d x 3} msg] $msg } {1 {expected integer but got "x"}} test format-7.10 {error conditions} { list [catch {format %*.*f 2 xyz 3} msg] $msg } {1 {expected integer but got "xyz"}} test format-7.11 {error conditions} { catch {format %d 2a} } 1 test format-7.12 {error conditions} { catch {format %d 2a} msg set msg } {expected integer but got "2a"} test format-7.13 {error conditions} { catch {format %c 2x} } 1 test format-7.14 {error conditions} { catch {format %c 2x} msg set msg } {expected integer but got "2x"} test format-7.15 {error conditions} { catch {format %f 2.1z} } 1 test format-7.16 {error conditions} { catch {format %f 2.1z} msg set msg } {expected floating-point number but got "2.1z"} test format-7.17 {error conditions} { catch {format ab%} } 1 test format-7.18 {error conditions} { catch {format ab% 12} msg set msg } {format string ended in middle of field specifier} test format-7.19 {error conditions} { catch {format %q x} } 1 test format-7.20 {error conditions} { catch {format %q x} msg set msg } {bad field specifier "q"} test format-7.21 {error conditions} { catch {format %d} } 1 test format-7.22 {error conditions} { catch {format %d} msg set msg } {not enough arguments for all format specifiers} test format-8.1 {long result} { set a {1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ 1 2 3 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 F G H I J K L M N O P Q R S T U V W X Y Z} format {1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG %s %s %s} $a $a $a } {1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG 1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ 1 2 3 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 F G H I J K L M N O P Q R S T U V W X Y Z 1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ 1 2 3 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 F G H I J K L M N O P Q R S T U V W X Y Z 1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ 1 2 3 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 F G H I J K L M N O P Q R S T U V W X Y Z} if $doNonPortableTests { test format-9.1 {"h" format specifier} { format %hd 0xffff } -1 test format-9.2 {"h" format specifier} { format %hx 0x10fff } fff test format-9.3 {"h" format specifier} { format %hd 0x10000 } 0 } test format-10.1 {XPG3 %$n specifiers} { format {%2$d %1$d} 4 5 } {5 4} test format-10.2 {XPG3 %$n specifiers} { format {%2$d %1$d %1$d %3$d} 4 5 6 } {5 4 4 6} test format-10.3 {XPG3 %$n specifiers} { list [catch {format {%2$d %3$d} 4 5} msg] $msg } {1 {"%n$" argument index out of range}} test format-10.4 {XPG3 %$n specifiers} { list [catch {format {%2$d %0$d} 4 5 6} msg] $msg } {1 {"%n$" argument index out of range}} test format-10.5 {XPG3 %$n specifiers} { list [catch {format {%d %1$d} 4 5 6} msg] $msg } {1 {cannot mix "%" and "%n$" conversion specifiers}} test format-10.6 {XPG3 %$n specifiers} { list [catch {format {%2$d %d} 4 5 6} msg] $msg } {1 {cannot mix "%" and "%n$" conversion specifiers}} test format-10.7 {XPG3 %$n specifiers} { list [catch {format {%2$d %3d} 4 5 6} msg] $msg } {1 {cannot mix "%" and "%n$" conversion specifiers}} test format-10.8 {XPG3 %$n specifiers} { format {%2$*d %3$d} 1 10 4 } { 4 4} test format-10.9 {XPG3 %$n specifiers} { format {%2$.*s %4$d} 1 5 abcdefghijklmnop 44 } {abcde 44} test format-10.10 {XPG3 %$n specifiers} { list [catch {format {%2$*d} 4} msg] $msg } {1 {"%n$" argument index out of range}} test format-10.11 {XPG3 %$n specifiers} { list [catch {format {%2$*d} 4 5} msg] $msg } {1 {"%n$" argument index out of range}} test format-10.12 {XPG3 %$n specifiers} { list [catch {format {%2$*d} 4 5 6} msg] $msg } {0 { 6}} -3.16 {e and f formats} { format "%3.1f %3.1f %3.1f %3.1f" 0.0 0.1 0.01 0.001 } {0.0 0.1 0.0 0.0} test format-4.1 {g-format} { format "%.3g" 12341.0 } {1.23e+04} test format-4.2 {g-format} { format "%.3G" 1234.12345 } {1.23E+03} test format-4.3 {g-format} { format "%.3g" 123.412345 } {123} test format-4.4 {g-format} { format "%.3g" 12.3412345 } {12.3} test format-4.5 {g-format} { format "%.3g" 1.23412345 } {1.23} test format-4.6 {g-format} { format "%.3g" 1.23tcl7.4b4/tests/get.test010044400630510000012000000047570572021655000156630ustar00ousterstaff00002300000001# Commands covered: none # # This file contains a collection of tests for the procedures in the # file tclGet.c. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1995 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # @(#) get.test 1.1 95/02/14 13:15:15 if {[string compare test [info procs test]] == 1} then {source defs} test get-1.1 {Tcl_GetInt procedure} { set x 44 incr x { 22} } {66} test get-1.2 {Tcl_GetInt procedure} { set x 44 incr x -3 } {41} test get-1.3 {Tcl_GetInt procedure} { set x 44 incr x +8 } {52} test get-1.4 {Tcl_GetInt procedure} { set x 44 list [catch {incr x foo} msg] $msg } {1 {expected integer but got "foo"}} test get-1.5 {Tcl_GetInt procedure} { set x 44 list [catch {incr x {16 }} msg] $msg } {0 60} test get-1.6 {Tcl_GetInt procedure} { set x 44 list [catch {incr x {16 x}} msg] $msg } {1 {expected integer but got "16 x"}} if $doNonPortableTests { test get-1.7 {Tcl_GetInt procedure} { set x 44 list [catch {incr x 4294967296} msg] $msg $errorCode } {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}} test get-1.8 {Tcl_GetInt procedure} { set x 0 list [catch {incr x 4294967294} msg] $msg } {0 -2} test get-1.8 {Tcl_GetInt procedure} { set x 0 list [catch {incr x +4294967294} msg] $msg } {0 -2} test get-1.9 {Tcl_GetInt procedure} { set x 0 list [catch {incr x -4294967294} msg] $msg } {0 2} } test get-2.1 {Tcl_GetInt procedure} { format %g 1.23 } {1.23} test get-2.2 {Tcl_GetInt procedure} { format %g { 1.23 } } {1.23} test get-2.3 {Tcl_GetInt procedure} { list [catch {format %g clip} msg] $msg } {1 {expected floating-point number but got "clip"}} if $doNonPortableTests { test get-2.4 {Tcl_GetInt procedure} { list [catch {format %g .000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000001} msg] $msg $errorCode } {1 {floating-point value too small to represent} {ARITH UNDERFLOW {floating-point value too small to represent}}} } tcl7.4b4/tests/glob.test010044400630510000012000000130260567470012000160130ustar00ousterstaff00002300000001# Commands covered: glob # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1994 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # @(#) glob.test 1.28 94/12/17 16:19:59 if {[string compare test [info procs test]] == 1} then {source defs} # First, create some subdirectories to use for testing. exec rm -rf globTest exec mkdir globTest globTest/a1 globTest/a2 globTest/a3 exec mkdir globTest/a1/b1 globTest/a1/b2 globTest/a2/b3 exec cat << abc > globTest/x1.c exec cat << abc > globTest/y1.c exec cat << abc > globTest/z1.c exec cat << abc > "globTest/weird name.c" exec cat << abc > globTest/.1 exec cat << abc > globTest/a1/b1/x2.c exec cat << abc > globTest/a1/b2/y2.c test glob-1.1 {simple globbing} { lsort [glob globTest/x1.c globTest/y1.c globTest/foo] } {globTest/x1.c globTest/y1.c} test glob-1.2 {simple globbing} { glob {} } . test glob-2.1 {globbing with braces} { glob -nocomplain "{a1,a2}" } {} test glob-2.2 {globbing with braces} { lsort [glob globTest/{a,b,x,y}1.c] } {globTest/x1.c globTest/y1.c} test glob-2.3 {globbing with braces} { lsort [glob {globTest/{x1,y2,weird name}.c}] } {{globTest/weird name.c} globTest/x1.c} test glob-2.4 {globbing with braces} { lsort [glob globTest/{x1.c,a1/*}] } {globTest/a1/b1 globTest/a1/b2 globTest/x1.c} test glob-3.1 {asterisks, question marks, and brackets} { lsort [glob g*/*.c] } {{globTest/weird name.c} globTest/x1.c globTest/y1.c globTest/z1.c} test glob-3.2 {asterisks, question marks, and brackets} { lsort [glob globTest/?1.c] } {globTest/x1.c globTest/y1.c globTest/z1.c} test glob-3.3 {asterisks, question marks, and brackets} { lsort [glob */*/*/*.c] } {globTest/a1/b1/x2.c globTest/a1/b2/y2.c} test glob-3.4 {asterisks, question marks, and brackets} { lsort [glob globTest/*] } {globTest/a1 globTest/a2 globTest/a3 {globTest/weird name.c} globTest/x1.c globTest/y1.c globTest/z1.c} test glob-3.5 {asterisks, question marks, and brackets} { lsort [glob globTest/.*] } {globTest/. globTest/.. globTest/.1} test glob-3.6 {asterisks, question marks, and brackets} { lsort [glob globTest/*/*] } {globTest/a1/b1 globTest/a1/b2 globTest/a2/b3} test glob-3.7 {asterisks, question marks, and brackets} { lsort [glob {globTest/[xyab]1.*}] } {globTest/x1.c globTest/y1.c} test glob-3.8 {asterisks, question marks, and brackets} { lsort [glob globTest/*/] } {globTest/a1/ globTest/a2/ globTest/a3/} # The tests below are not portable, since they depend on a # particular location for ouster's home directory. if $doNonPortableTests { test glob-4.1 {tildes} {glob ~/.csh*} "/home/ouster/.cshrc" test glob-4.2 {tildes} {glob ~ouster/.csh*} "/home/ouster/.cshrc" } test glob-5.1 {error conditions} { list [catch {glob} msg] $msg } {1 {wrong # args: should be "glob ?switches? name ?name ...?"}} test glob-5.2 {error conditions} { list [catch {glob globTest/\{} msg] $msg } {1 {unmatched open-brace in file name}} test glob-5.3 {error conditions} { list [catch {glob globTest/*/gorp} msg] $msg } {1 {no files matched glob pattern "globTest/*/gorp"}} test glob-5.4 {error conditions} { list [catch {glob goo/* x*z foo?q} msg] $msg } {1 {no files matched glob patterns "goo/* x*z foo?q"}} test glob-5.5 {error conditions} { list [catch {lsort [glob globTest/*.c goo/*]} msg] $msg } {0 {{globTest/weird name.c} globTest/x1.c globTest/y1.c globTest/z1.c}} test glob-5.6 {error conditions} { list [catch {glob ~no-one} msg] $msg } {1 {user "no-one" doesn't exist}} test glob-5.7 {error conditions} { set home $env(HOME) unset env(HOME) set x [list [catch {glob ~/*} msg] $msg] set env(HOME) $home set x } {1 {couldn't find HOME environment variable to expand "~/*"}} test glob-5.8 {error conditions} { list [catch {glob globTest/{a1,a2}/\{} msg] $msg } {1 {unmatched open-brace in file name}} test glob-5.9 {error conditions} { list [catch {glob globTest/*/\{} msg] $msg } {1 {unmatched open-brace in file name}} # On some systems, like AFS, "000" protection doesn't prevent # access by owner, so the following test is not portable. if $doNonPortableTests { exec chmod 000 globTest test glob-6.1 {setting errorCode variable} { string tolower [list [catch {glob globTest/*} msg] $msg $errorCode] } {1 {couldn't read directory "globtest": permission denied} {posix eacces {permission denied}}} exec chmod 755 globTest } test glob-7.1 {-nocomplain switch} { list [catch {glob -nocomplai} msg] $msg } {1 {bad switch "-nocomplai": must be -nocomplain or --}} test glob-7.2 {-nocomplain switch} { list [catch {glob -nocomplain} msg] $msg } {1 {wrong # args: should be "glob ?switches? name ?name ...?"}} test glob-7.3 {-nocomplain switch} { list [catch {glob -nocomplain goo/*} msg] $msg } {0 {}} test glob-7.4 {-nocomplain switch} { list [catch {glob -nocomplain ~xyqrszzz} msg] $msg } {0 {}} test glob-7.5 {-nocomplain switch} { list [catch {glob ~xyqrszzz} msg] $msg } {1 {user "xyqrszzz" doesn't exist}} test glob-7.6 {-- switch} { list [catch {glob -- -nocomplain} msg] $msg } {1 {no files matched glob patterns "-nocomplain"}} test glob-7.7 {bogus switch} { list [catch {glob -gorp} msg] $msg } {1 {bad switch "-gorp": must be -nocomplain or --}} exec rm -rf globTest tcl7.4b4/tests/history.test010044400630510000012000000302550567470012000165740ustar00ousterstaff00002300000001# Commands covered: history # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # @(#) history.test 1.9 94/12/17 16:20:00 if {[info commands history] == ""} { puts stdout "This version of Tcl was built without the history command;\n" puts stdout "history tests will be skipped.\n" return } if {[string compare test [info procs test]] == 1} then {source defs} set num [history nextid] history keep 3 history add {set a 12345} history add {set b [format {A test %s} string]} history add {Another test} # "history event" test history-1.1 {event option} {history event -1} \ {set b [format {A test %s} string]} test history-1.2 {event option} {history event $num} \ {set a 12345} test history-1.3 {event option} {history event [expr $num+2]} \ {Another test} test history-1.4 {event option} {history event set} \ {set b [format {A test %s} string]} test history-1.5 {event option} {history e "* a*"} \ {set a 12345} test history-1.6 {event option} {catch {history event *gorp} msg} 1 test history-1.7 {event option} { catch {history event *gorp} msg set msg } {no event matches "*gorp"} test history-1.8 {event option} {history event} \ {set b [format {A test %s} string]} test history-1.9 {event option} {catch {history event 123 456} msg} 1 test history-1.10 {event option} { catch {history event 123 456} msg set msg } {wrong # args: should be "history event ?event?"} # "history redo" set a 0 history redo -2 test history-2.1 {redo option} {set a} 12345 set b 0 history redo test history-2.2 {redo option} {set b} {A test string} test history-2.3 {redo option} {catch {history redo -3 -4}} 1 test history-2.4 {redo option} { catch {history redo -3 -4} msg set msg } {wrong # args: should be "history redo ?event?"} # "history add" history add "set a 444" exec test history-3.1 {add option} {set a} 444 test history-3.2 {add option} {catch {history add "set a 444" execGorp}} 1 test history-3.3 {add option} { catch {history add "set a 444" execGorp} msg set msg } {bad argument "execGorp": should be "exec"} test history-3.4 {add option} {catch {history add "set a 444" a} msg} 1 test history-3.5 {add option} { catch {history add "set a 444" a} msg set msg } {bad argument "a": should be "exec"} history add "set a 555" e test history-3.6 {add option} {set a} 555 history add "set a 666" test history-3.7 {add option} {set a} 555 test history-3.8 {add option} {catch {history add "set a 666" e f} msg} 1 test history-3.9 {add option} { catch {history add "set a 666" e f} msg set msg } {wrong # args: should be "history add event ?exec?"} # "history change" history change "A test value" test history-4.1 {change option} {history event [expr {[history n]-1}]} \ "A test value" history c "Another test" -1 test history-4.2 {change option} {history e} "Another test" test history-4.3 {change option} {history event [expr {[history n]-1}]} \ "A test value" test history-4.4 {change option} {catch {history change Foo 4 10}} 1 test history-4.5 {change option} { catch {history change Foo 4 10} msg set msg } {wrong # args: should be "history change newValue ?event?"} test history-4.6 {change option} { catch {history change Foo [expr {[history n]-4}]} } 1 test history-4.7 {change option} { catch {history change Foo [expr {[history n]-4}]} set msg } {wrong # args: should be "history change newValue ?event?"} # "history info" set num [history n] history add set\ a\ {b\nc\ d\ e} history add {set b 1234} history add set\ c\ {a\nb\nc} test history-5.1 {info option} {history info} [format {%6d set a {b c d e} %6d set b 1234 %6d set c {a b c}} $num [expr $num+1] [expr $num+2]] test history-5.2 {info option} {history i 2} [format {%6d set b 1234 %6d set c {a b c}} [expr $num+1] [expr $num+2]] test history-5.3 {info option} {catch {history i 2 3}} 1 test history-5.4 {info option} { catch {history i 2 3} msg set msg } {wrong # args: should be "history info ?count?"} test history-5.5 {info option} {history} [format {%6d set a {b c d e} %6d set b 1234 %6d set c {a b c}} $num [expr $num+1] [expr $num+2]] # "history keep" history add "foo1" history add "foo2" history add "foo3" history keep 2 test history-6.1 {keep option} {history event [expr [history n]-1]} foo3 test history-6.2 {keep option} {history event -1} foo2 test history-6.3 {keep option} {catch {history event -3}} 1 test history-6.4 {keep option} { catch {history event -3} msg set msg } {event "-3" is too far in the past} history k 5 test history-6.5 {keep option} {history event -1} foo2 test history-6.6 {keep option} {history event -2} {} test history-6.7 {keep option} {history event -3} {} test history-6.8 {keep option} {history event -4} {} test history-6.9 {keep option} {catch {history event -5}} 1 test history-6.10 {keep option} {catch {history keep 4 6}} 1 test history-6.11 {keep option} { catch {history keep 4 6} msg set msg } {wrong # args: should be "history keep number"} test history-6.12 {keep option} {catch {history keep}} 1 test history-6.13 {keep option} { catch {history keep} msg set msg } {wrong # args: should be "history keep number"} test history-6.14 {keep option} {catch {history keep -3}} 1 test history-6.15 {keep option} { catch {history keep -3} msg set msg } {illegal keep count "-3"} # "history nextid" set num [history n] history add "Testing" history add "Testing2" test history-7.1 {nextid option} {history event} "Testing" test history-7.2 {nextid option} {history next} [expr $num+2] test history-7.3 {nextid option} {catch {history nextid garbage}} 1 test history-7.4 {nextid option} { catch {history nextid garbage} msg set msg } {wrong # args: should be "history nextid"} # "history substitute" test history-8.1 {substitute option} { history add "set a {test foo test b c test}" history add "Test command 2" set a 0 history substitute foo bar -1 set a } {test bar test b c test} test history-8.2 {substitute option} { history add "set a {test foo test b c test}" history add "Test command 2" set a 0 history substitute test gorp set a } {gorp foo gorp b c gorp} test history-8.3 {substitute option} { history add "set a {test foo test b c test}" history add "Test command 2" set a 0 history sub " te" to set a } {test footost b ctost} test history-8.4 {substitute option} {catch {history sub xxx yyy}} 1 test history-8.5 {substitute option} { catch {history sub xxx yyy} msg set msg } {"xxx" doesn't appear in event} test history-8.6 {substitute option} {catch {history s a b -10}} 1 test history-8.7 {substitute option} { catch {history s a b -10} msg set msg } {event "-10" is too far in the past} test history-8.8 {substitute option} {catch {history s a b -1 20}} 1 test history-8.9 {substitute option} { catch {history s a b -1 20} msg set msg } {wrong # args: should be "history substitute old new ?event?"} # "history words" test history-9.1 {words option} { history add {word0 word1 word2 a b c word6} history add foo history words 0-$ } {word0 word1 word2 a b c word6} test history-9.2 {words option} { history add {word0 word1 word2 a b c word6} history add foo history w 2 -1 } word2 test history-9.3 {words option} { history add {word0 word1 word2 a b c word6} history add foo history wo $ } word6 test history-9.4 {words option} {catch {history w 1--1} msg} 1 test history-9.5 {words option} { catch {history w 1--1} msg set msg } {bad word selector "1--1": should be num-num or pattern} test history-9.6 {words option} { history add {word0 word1 word2 a b c word6} history add foo history w w } {} test history-9.7 {words option} { history add {word0 word1 word2 a b c word6} history add foo history w *2 } word2 test history-9.8 {words option} { history add {word0 word1 word2 a b c word6} history add foo history w *or* } {word0 word1 word2 word6} test history-9.9 {words option} {catch {history words 10}} 1 test history-9.10 {words option} { catch {history words 10} msg set msg } {word selector "10" specified non-existent words} test history-9.11 {words option} {catch {history words 1 -1 20}} 1 test history-9.12 {words option} { catch {history words 1 -1 20} msg set msg } {wrong # args: should be "history words num-num/pat ?event?"} # history revision test history-10.1 {history revision} { set a 0 history a {set a 12345} history a {set a [history e]} exec set a } {set a 12345} test history-10.2 {history revision} { set a 0 history a {set a 12345} history a {set a [history e]} exec history a foo history ev -1 } {set a {set a 12345}} test history-10.3 {history revision} { set a 0 history a {set a 12345} history a {set a [history e]} exec history a foo history a {history r -2} exec history a {set a 12345} history ev -1 } {set a {set a 12345}} test history-10.4 {history revision} { history a {set a 12345} history a {history s 123 999} exec history a foo history ev -1 } {set a 99945} test history-10.5 {history revision} { history add {word0 word1 word2 a b c word6} history add {set [history w 3] [list [history w 0] [history w {[ab]}]]} exec set a } {word0 {a b}} test history-10.6 {history revision} { history add {word0 word1 word2 a b c word6} history add {set [history w 3] [list [history w 0] [history w {[ab]}]]} exec history add foo history ev } {set a [list word0 {a b}]} test history-10.7 {history revision} { history add {word0 word1 word2 a b c word6} history add {set [history w 3] [list [history w 0] [history w {[ab]}]]} exec history add {format b} history add {word0 word1 word2 a b c word6} set a 0 history add {set [history subs b a -2] [list abc [history r -2] [history w 1-3]]} exec history add foo history ev } {set [format a] [list abc [format b] {word1 word2 a}]} test history-10.8 {history revision} { history add {set a 12345} concat a b c history add {history redo; set b 44} exec history add foo history ev } {set a 12345; set b 44} test history-10.9 {history revision} { history add {set a 12345} history add {history redo; history change "A simple test"; history subs 45 xx} exec set a } 123xx test history-10.10 {history revision} { history add {set a 12345} history add {history redo; history change "A simple test"; history subs 45 xx} exec history add foo history e } {A simple test} test history-10.11 {history revision} { history add {word0 word1 $ a b c word6} history add {set a [history w 4-[history word 2]]} exec set a } {b c word6} test history-10.12 {history revision} { history add {word0 word1 $ a b c word6} history add {set a [history w 4-[history word 2]]} exec history add foo history e } {set a {b c word6}} test history-10.13 {history revision} { history add {history word 0} exec history add foo history e } {history word 0} test history-10.14 {history revision} { history add {set a [history word 0; format c]} exec history add foo history e } {set a [history word 0; format c]} test history-10.15 {history revision even when nested} { proc x {a b} {history word $a $b} history add {word1 word2 word3 word4} history add {set a [x 1-3 -1]} exec history add foo history e } {set a {word2 word3 word4}} test history-10.16 {disable history revision in nested history evals} { history add {word1 word2 word3 word4} history add {set a [history words 0]; history add foo; set a [history words 0]} exec history e } {set a word1; history add foo; set a [history words 0]} # miscellaneous test history-11.1 {miscellaneous} {catch {history gorp} msg} 1 test history-11.2 {miscellaneous} { catch {history gorp} msg set msg } {bad option "gorp": must be add, change, event, info, keep, nextid, redo, substitute, or words} tcl7.4b4/tests/if.test010044400630510000012000000101670567470012000154710ustar00ousterstaff00002300000001# Commands covered: if # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # @(#) if.test 1.7 94/12/17 16:20:01 if {[string compare test [info procs test]] == 1} then {source defs} test if-1.1 {taking proper branch} { set a {} if 0 {set a 1} else {set a 2} set a } 2 test if-1.2 {taking proper branch} { set a {} if 1 {set a 1} else {set a 2} set a } 1 test if-1.3 {taking proper branch} { set a {} if 1<2 {set a 1} set a } 1 test if-1.4 {taking proper branch} { set a {} if 1>2 {set a 1} set a } {} test if-1.5 {taking proper branch} { set a {} if 0 {set a 1} else {} set a } {} test if-1.5 {taking proper branch} { set a {} if 0 {set a 1} elseif 1 {set a 2} elseif 1 {set a 3} else {set a 4} set a } {2} test if-1.6 {taking proper branch} { set a {} if 0 {set a 1} elseif 0 {set a 2} elseif 1 {set a 3} else {set a 4} set a } {3} test if-1.7 {taking proper branch} { set a {} if 0 {set a 1} elseif 0 {set a 2} elseif 0 {set a 3} else {set a 4} set a } {4} test if-2.1 {optional then-else args} { set a 44 if 0 then {set a 1} elseif 0 then {set a 3} else {set a 2} set a } 2 test if-2.2 {optional then-else args} { set a 44 if 1 then {set a 1} else {set a 2} set a } 1 test if-2.3 {optional then-else args} { set a 44 if 0 {set a 1} else {set a 2} set a } 2 test if-2.4 {optional then-else args} { set a 44 if 1 {set a 1} else {set a 2} set a } 1 test if-2.5 {optional then-else args} { set a 44 if 0 then {set a 1} {set a 2} set a } 2 test if-2.6 {optional then-else args} { set a 44 if 1 then {set a 1} {set a 2} set a } 1 test if-2.7 {optional then-else args} { set a 44 if 0 then {set a 1} else {set a 2} set a } 2 test if-2.8 {optional then-else args} { set a 44 if 0 then {set a 1} elseif 0 {set a 2} elseif 0 {set a 3} {set a 4} set a } 4 test if-3.1 {return value} { if 1 then {set a 22; concat abc} } abc test if-3.2 {return value} { if 0 then {set a 22; concat abc} elseif 1 {concat def} {concat ghi} } def test if-3.3 {return value} { if 0 then {set a 22; concat abc} else {concat def} } def test if-3.4 {return value} { if 0 then {set a 22; concat abc} } {} test if-3.5 {return value} { if 0 then {set a 22; concat abc} elseif 0 {concat def} } {} test if-4.1 {error conditions} { list [catch {if} msg] $msg } {1 {wrong # args: no expression after "if" argument}} test if-4.2 {error conditions} { list [catch {if {[error "error in condition"]}} msg] $msg } {1 {error in condition}} test if-4.3 {error conditions} { list [catch {if 2} msg] $msg } {1 {wrong # args: no script following "2" argument}} test if-4.4 {error conditions} { list [catch {if 2 then} msg] $msg } {1 {wrong # args: no script following "then" argument}} test if-4.5 {error conditions} { list [catch {if 2 the} msg] $msg } {1 {invalid command name "the"}} test if-4.6 {error conditions} { list [catch {if 2 then {[error "error in then clause"]}} msg] $msg } {1 {error in then clause}} test if-4.7 {error conditions} { list [catch {if 0 then foo elseif} msg] $msg } {1 {wrong # args: no expression after "elseif" argument}} test if-4.8 {error conditions} { list [catch {if 0 then foo elsei} msg] $msg } {1 {invalid command name "elsei"}} test if-4.9 {error conditions} { list [catch {if 0 then foo elseif 0 bar else} msg] $msg } {1 {wrong # args: no script following "else" argument}} test if-4.10 {error conditions} { list [catch {if 0 then foo elseif 0 bar els} msg] $msg } {1 {invalid command name "els"}} test if-4.11 {error conditions} { list [catch {if 0 then foo elseif 0 bar else {[error "error in else clause"]}} msg] $msg } {1 {error in else clause}} tcl7.4b4/tests/incr.test010044400630510000012000000052040567470012100160230ustar00ousterstaff00002300000001# Commands covered: lreplace # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # @(#) incr.test 1.7 94/12/17 16:20:02 if {[string compare test [info procs test]] == 1} then {source defs} catch {unset x} test incr-1.1 {basic incr operation} { set x 23 list [incr x] $x } {24 24} test incr-1.2 {basic incr operation} { set x 106 list [incr x -5] $x } {101 101} test incr-1.3 {basic incr operation} { set x " -106" list [incr x 1] $x } {-105 -105} test incr-1.3 {basic incr operation} { set x " +106" list [incr x 1] $x } {107 107} test incr-2.1 {incr errors} { list [catch incr msg] $msg } {1 {wrong # args: should be "incr varName ?increment?"}} test incr-2.2 {incr errors} { list [catch {incr a b c} msg] $msg } {1 {wrong # args: should be "incr varName ?increment?"}} test incr-2.3 {incr errors} { catch {unset x} list [catch {incr x} msg] $msg $errorInfo } {1 {can't read "x": no such variable} {can't read "x": no such variable while executing "incr x"}} test incr-2.4 {incr errors} { set x abc list [catch {incr x} msg] $msg $errorInfo } {1 {expected integer but got "abc"} {expected integer but got "abc" (reading value of variable to increment) invoked from within "incr x"}} test incr-2.5 {incr errors} { set x 123 list [catch {incr x 1a} msg] $msg $errorInfo } {1 {expected integer but got "1a"} {expected integer but got "1a" (reading increment) invoked from within "incr x 1a"}} test incr-2.6 {incr errors} { proc readonly args {error "variable is read-only"} set x 123 trace var x w readonly list [catch {incr x 1} msg] $msg $errorInfo } {1 {can't set "x": variable is read-only} {can't set "x": variable is read-only while executing "incr x 1"}} catch {unset x} test incr-2.7 {incr errors} { set x - list [catch {incr x 1} msg] $msg } {1 {expected integer but got "-"}} test incr-2.8 {incr errors} { set x { - } list [catch {incr x 1} msg] $msg } {1 {expected integer but got " - "}} test incr-2.9 {incr errors} { set x + list [catch {incr x 1} msg] $msg } {1 {expected integer but got "+"}} test incr-2.10 {incr errors} { set x {20 x} list [catch {incr x 1} msg] $msg } {1 {expected integer but got "20 x"}} concat {} tcl7.4b4/tests/info.test010044400630510000012000000342270574525306700160450ustar00ousterstaff00002300000001# Commands covered: info # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1994 The Regents of the University of California. # Copyright (c) 1994-1995 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # @(#) info.test 1.23 95/04/19 11:28:07 if {[string compare test [info procs test]] == 1} then {source defs} test info-1.1 {info args option} { proc t1 {a bbb c} {return foo} info args t1 } {a bbb c} test info-1.2 {info args option} { proc t1 {{a default1} {bbb default2} {c default3} args} {return foo} info a t1 } {a bbb c args} test info-1.3 {info args option} { proc t1 "" {return foo} info args t1 } {} test info-1.4 {info args option} { catch {rename t1 {}} list [catch {info args t1} msg] $msg } {1 {"t1" isn't a procedure}} test info-1.5 {info args option} { list [catch {info args set} msg] $msg } {1 {"set" isn't a procedure}} test info-2.1 {info body option} { proc t1 {} {body of t1} info body t1 } {body of t1} test info-2.2 {info body option} { list [catch {info body set} msg] $msg } {1 {"set" isn't a procedure}} test info-2.3 {info body option} { list [catch {info args set 1} msg] $msg } {1 {wrong # args: should be "info args procname"}} test info-3.1 {info cmdcount option} { set x [info cmdcount] set y 12345 set z [info cm] expr $z-$x } 3 test info-3.2 {info body option} { list [catch {info cmdcount 1} msg] $msg } {1 {wrong # args: should be "info cmdcount"}} test info-4.1 {info commands option} { proc t1 {} {} proc t2 {} {} set x " [info commands] " list [string match {* t1 *} $x] [string match {* t2 *} $x] \ [string match {* set *} $x] [string match {* list *} $x] } {1 1 1 1} test info-4.2 {info commands option} { proc t1 {} {} rename t1 {} set x [info comm] string match {* t1 *} $x } 0 test info-4.3 {info commands option} { proc _t1_ {} {} proc _t2_ {} {} info commands _t1_ } _t1_ test info-4.4 {info commands option} { proc _t1_ {} {} proc _t2_ {} {} lsort [info commands _t*] } {_t1_ _t2_} catch {rename _t1_ {}} catch {rename _t2_ {}} test info-4.5 {info commands option} { list [catch {info commands a b} msg] $msg } {1 {wrong # args: should be "info commands [pattern]"}} test info-5.1 {info complete option} { info complete "" } 1 test info-5.2 {info complete option} { info complete " \n" } 1 test info-5.3 {info complete option} { info complete "abc def" } 1 test info-5.4 {info complete option} { info complete "a b c d e f \t\n" } 1 test info-5.5 {info complete option} { info complete {a b c"d} } 1 test info-5.6 {info complete option} { info complete {a b "c d" e} } 1 test info-5.7 {info complete option} { info complete {a b "c d"} } 1 test info-5.8 {info complete option} { info complete {a b "c d"} } 1 test info-5.9 {info complete option} { info complete {a b "c d} } 0 test info-5.10 {info complete option} { info complete {a b "} } 0 test info-5.11 {info complete option} { info complete {a b "cd"xyz} } 1 test info-5.12 {info complete option} { info complete {a b "c $d() d"} } 1 test info-5.13 {info complete option} { info complete {a b "c $dd("} } 0 test info-5.14 {info complete option} { info complete {a b "c \"} } 0 test info-5.15 {info complete option} { info complete {a b "c [d e f]"} } 1 test info-5.16 {info complete option} { info complete {a b "c [d e f] g"} } 1 test info-5.17 {info complete option} { info complete {a b "c [d e f"} } 0 test info-5.18 {info complete option} { info complete {a {b c d} e} } 1 test info-5.19 {info complete option} { info complete {a {b c d}} } 1 test info-5.20 {info complete option} { info complete "a b\{c d" } 1 test info-5.21 {info complete option} { info complete "a b \{c" } 0 test info-5.22 {info complete option} { info complete "a b \{c{ }" } 0 test info-5.23 {info complete option} { info complete "a b {c d e}xxx" } 1 test info-5.24 {info complete option} { info complete "a b {c \\\{d e}xxx" } 1 test info-5.25 {info complete option} { info complete {a b [ab cd ef]} } 1 test info-5.26 {info complete option} { info complete {a b x[ab][cd][ef] gh} } 1 test info-5.27 {info complete option} { info complete {a b x[ab][cd[ef] gh} } 0 test info-5.28 {info complete option} { info complete {a b x[ gh} } 0 test info-5.29 {info complete option} { info complete {[]]]} } 1 test info-5.30 {info complete option} { info complete {abc x$yyy} } 1 test info-5.31 {info complete option} { info complete "abc x\${abc\[\\d} xyz" } 1 test info-5.32 {info complete option} { info complete "abc x\$\{ xyz" } 0 test info-5.33 {info complete option} { info complete {word $a(xyz)} } 1 test info-5.34 {info complete option} { info complete {word $a(} } 0 test info-5.35 {info complete option} { info complete "set a \\\n" } 0 test info-5.36 {info complete option} { info complete "set a \\n " } 1 test info-5.37 {info complete option} { info complete "set a \\" } 1 test info-5.38 {info complete option} { info complete "foo \\\n\{" } 0 test info-5.39 {info complete option} { info complete " # \{" } 1 test info-5.40 {info complete option} { info complete "foo bar;# \{" } 1 test info-5.41 {info complete option} { info complete "a\nb\n# \{\n# \{\nc\n" } 1 test info-6.1 {info default option} { proc t1 {a b {c d} {e "long default value"}} {} info default t1 a value } 0 test info-6.2 {info default option} { proc t1 {a b {c d} {e "long default value"}} {} set value 12345 info d t1 a value set value } {} test info-6.3 {info default option} { proc t1 {a b {c d} {e "long default value"}} {} info default t1 c value } 1 test info-6.4 {info default option} { proc t1 {a b {c d} {e "long default value"}} {} set value 12345 info default t1 c value set value } d test info-6.5 {info default option} { proc t1 {a b {c d} {e "long default value"}} {} set value 12345 set x [info default t1 e value] list $x $value } {1 {long default value}} test info-6.6 {info default option} { list [catch {info default a b} msg] $msg } {1 {wrong # args: should be "info default procname arg varname"}} test info-6.7 {info default option} { list [catch {info default _nonexistent_ a b} msg] $msg } {1 {"_nonexistent_" isn't a procedure}} test info-6.8 {info default option} { proc t1 {a b} {} list [catch {info default t1 x value} msg] $msg } {1 {procedure "t1" doesn't have an argument "x"}} test info-6.9 {info default option} { catch {unset a} set a(0) 88 proc t1 {a b} {} list [catch {info default t1 a a} msg] $msg } {1 {couldn't store default value in variable "a"}} test info-6.10 {info default option} { catch {unset a} set a(0) 88 proc t1 {{a 18} b} {} list [catch {info default t1 a a} msg] $msg } {1 {couldn't store default value in variable "a"}} catch {unset a} test info-7.1 {info exists option} { set value foo info exists value } 1 catch {unset _nonexistent_} test info-7.2 {info exists option} { info exists _nonexistent_ } 0 test info-7.3 {info exists option} { proc t1 {x} {return [info exists x]} t1 2 } 1 test info-7.4 {info exists option} { proc t1 {x} { global _nonexistent_ return [info exists _nonexistent_] } t1 2 } 0 test info-7.5 {info exists option} { proc t1 {x} { set y 47 return [info exists y] } t1 2 } 1 test info-7.6 {info exists option} { proc t1 {x} {return [info exists value]} t1 2 } 0 test info-7.7 {info exists option} { catch {unset x} set x(2) 44 list [info exists x] [info exists x(1)] [info exists x(2)] } {1 0 1} catch {unset x} test info-7.8 {info exists option} { list [catch {info exists} msg] $msg } {1 {wrong # args: should be "info exists varName"}} test info-7.9 {info exists option} { list [catch {info exists 1 2} msg] $msg } {1 {wrong # args: should be "info exists varName"}} test info-8.1 {info globals option} { set x 1 set y 2 set value 23 set a " [info globals] " list [string match {* x *} $a] [string match {* y *} $a] \ [string match {* value *} $a] [string match {* _foobar_ *} $a] } {1 1 1 0} test info-8.2 {info globals option} { set _xxx1 1 set _xxx2 2 lsort [info g _xxx*] } {_xxx1 _xxx2} test info-8.3 {info globals option} { list [catch {info globals 1 2} msg] $msg } {1 {wrong # args: should be "info globals [pattern]"}} test info-9.1 {info level option} { info level } 0 test info-9.2 {info level option} { proc t1 {a b} { set x [info le] set y [info level 1] list $x $y } t1 146 testString } {1 {t1 146 testString}} test info-9.3 {info level option} { proc t1 {a b} { t2 [expr $a*2] $b } proc t2 {x y} { list [info level] [info level 1] [info level 2] [info level -1] \ [info level 0] } t1 146 {a {b c} {{{c}}}} } {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}}}}}} test info-9.4 {info level option} { proc t1 {} { set x [info level] set y [info level 1] list $x $y } t1 } {1 t1} test info-9.5 {info level option} { list [catch {info level 1 2} msg] $msg } {1 {wrong # args: should be "info level [number]"}} test info-9.6 {info level option} { list [catch {info level 123a} msg] $msg } {1 {expected integer but got "123a"}} test info-9.7 {info level option} { list [catch {info level 0} msg] $msg } {1 {bad level "0"}} test info-9.8 {info level option} { proc t1 {} {info level -1} list [catch {t1} msg] $msg } {1 {bad level "-1"}} test info-9.9 {info level option} { proc t1 {x} {info level $x} list [catch {t1 -3} msg] $msg } {1 {bad level "-3"}} set savedLibrary tcl_library test info-10.1 {info library option} { list [catch {info library x} msg] $msg } {1 {wrong # args: should be "info library"}} test info-10.2 {info library option} { set tcl_library 12345 info library } {12345} test info-10.3 {info library option} { unset tcl_library list [catch {info library} msg] $msg } {1 {no library has been specified for Tcl}} set tcl_library $savedLibrary test info-11.1 {info locals option} { set a 22 proc t1 {x y} { set b 13 set c testing global a return [info locals] } lsort [t1 23 24] } {b c x y} test info-11.2 {info locals option} { proc t1 {x y} { set xx1 2 set xx2 3 set y 4 return [info lo x*] } lsort [t1 2 3] } {x xx1 xx2} test info-11.3 {info locals option} { list [catch {info locals 1 2} msg] $msg } {1 {wrong # args: should be "info locals [pattern]"}} test info-11.4 {info locals option} { info locals } {} test info-11.5 {info locals option} { proc t1 {} {return [info locals]} t1 } {} test info-12.1 {info patchlevel option} { set a [info patchlevel] regexp {[0-9]+\.[0-9]+([p[0-9]+)?} $a } 1 test info-12.2 {info patchlevel option} { list [catch {info patchlevel a} msg] $msg } {1 {wrong # args: should be "info patchlevel"}} test info-13.1 {info procs option} { proc t1 {} {} proc t2 {} {} set x " [info procs] " list [string match {* t1 *} $x] [string match {* t2 *} $x] \ [string match {* _undefined_ *} $x] } {1 1 0} test info-13.2 {info procs option} { proc _tt1 {} {} proc _tt2 {} {} lsort [info pr _tt*] } {_tt1 _tt2} catch {rename _tt1 {}} catch {rename _tt2 {}} test info-13.3 {info procs option} { list [catch {info procs 2 3} msg] $msg } {1 {wrong # args: should be "info procs [pattern]"}} test info-14.1 {info script option} { list [catch {info script x} msg] $msg } {1 {wrong # args: should be "info script"}} test info-14.2 {info script option} { file tail [info s] } info.test catch {exec rm -f gorp.info} exec cat > gorp.info << "info script\n" test info-14.3 {info script option} { list [source gorp.info] [file tail [info script]] } {gorp.info info.test} test info-14.4 {resetting "info script" after errors} { catch {source ~_nobody_/foo} file tail [info script] } {info.test} test info-14.5 {resetting "info script" after errors} { catch {source _nonexistent_} file tail [info script] } {info.test} exec rm -f gorp.info test info-15.1 {info tclversion option} { set x [info tclversion] scan $x "%d.%d%c" a b c } 2 test info-15.2 {info tclversion option} { list [catch {info t 2} msg] $msg } {1 {wrong # args: should be "info tclversion"}} test info-16.1 {info vars option} { set a 1 set b 2 proc t1 {x y} { global a b set c 33 return [info vars] } lsort [t1 18 19] } {a b c x y} test info-16.2 {info vars option} { set xxx1 1 set xxx2 2 proc t1 {xxa y} { global xxx1 xxx2 set c 33 return [info vars x*] } lsort [t1 18 19] } {xxa xxx1 xxx2} test info-16.3 {info vars option} { lsort [info vars] } [lsort [info globals]] test info-16.4 {info vars option} { list [catch {info vars a b} msg] $msg } {1 {wrong # args: should be "info vars [pattern]"}} test info-17.1 {miscellaneous error conditions} { list [catch {info} msg] $msg } {1 {wrong # args: should be "info option ?arg arg ...?"}} test info-17.2 {miscellaneous error conditions} { list [catch {info gorp} msg] $msg } {1 {bad option "gorp": should be args, body, cmdcount, commands, complete, default, exists, globals, level, library, locals, patchlevel, procs, script, tclversion, or vars}} test info-17.3 {miscellaneous error conditions} { list [catch {info c} msg] $msg } {1 {bad option "c": should be args, body, cmdcount, commands, complete, default, exists, globals, level, library, locals, patchlevel, procs, script, tclversion, or vars}} test info-17.4 {miscellaneous error conditions} { list [catch {info l} msg] $msg } {1 {bad option "l": should be args, body, cmdcount, commands, complete, default, exists, globals, level, library, locals, patchlevel, procs, script, tclversion, or vars}} e "a b {c d e}xxx" } 1 test info-5.24 {info complete option} { info complete "a b {c \\\{d e}xxx" } 1 test info-5.25 {info complete option} { info complete {a b [ab cd ef]} } 1 test info-5.26 {info complete option} { info complete {a b x[ab][cd][ef] gh} } 1 test info-5.27 {info complete option} { info complete {a b x[ab][cd[ef] gh} } 0 test intcl7.4b4/tests/join.test010044400630510000012000000023660567470012100160350ustar00ousterstaff00002300000001# Commands covered: join # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # @(#) join.test 1.5 94/12/17 16:20:04 if {[string compare test [info procs test]] == 1} then {source defs} test join-1.1 {basic join commands} { join {a b c} xyz } axyzbxyzc test join-1.2 {basic join commands} { join {a b c} {} } abc test join-1.3 {basic join commands} { join {} xyz } {} test join-1.4 {basic join commands} { join {12 34 56} } {12 34 56} test join-2.1 {join errors} { list [catch join msg] $msg $errorCode } {1 {wrong # args: should be "join list ?joinString?"} NONE} test join-2.2 {join errors} { list [catch {join a b c} msg] $msg $errorCode } {1 {wrong # args: should be "join list ?joinString?"} NONE} test join-2.3 {join errors} { list [catch {join "a \{ c" 111} msg] $msg $errorCode } {1 {unmatched open brace in list} NONE} tcl7.4b4/tests/README010044400630510000012000000071020564727514000150560ustar00ousterstaff00002300000001Tcl Test Suite -------------- @(#) README 1.1 94/08/09 12:59:51 This directory contains a set of validation tests for the Tcl commands. Each of the files whose name ends in ".test" is intended to fully exercise one or a few Tcl commands. The commands tested by a given file are listed in the first line of the file. You can run the tests in two ways: (a) type "make test" in the parent directory to this one; this will run all of the tests. (b) start up tcltest in this directory, then "source" the test file (for example, type "source parse.test"). To run all of the tests, type "source all". In either case no output will be generated if all goes well, except for a listing of the tests.. If there are errors then additional messages will appear in the format described below. The rest of this file provides additional information on the features of the testing environment. This approach to testing was designed and initially implemented by Mary Ann May-Pumphrey of Sun Microsystems. Many thanks to her for donating her work back to the public Tcl release. Definitions file: ----------------- The file "defs" defines a collection of procedures and variables used to run the tests. It is read in automatically by each of the .test files if needed, but once it has been read once it will not be read again by the .test files. If you change defs while running tests you'll have to "source" it by hand to load its new contents. Test output: ------------ Normally, output only appears when there are errors. However, if the variable VERBOSE is set to 1 then tests will be run in "verbose" mode and output will be generated for each test regardless of whether it succeeded or failed. Test output consists of the following information: - the test identifier (which can be used to locate the test code in the .test file) - a brief description of the test - the contents of the test code - the actual results produced by the tests - a "PASSED" or "FAILED" message - the expected results (if the test failed) You can set VERBOSE either interactively (after the defs file has been read in), or you can change the default value in "defs". Selecting tests for execution: ------------------------------ Normally, all the tests in a file are run whenever the file is "source"d. However, you can select a specific set of tests using the global variable TESTS. This variable contains a pattern; any test whose identifier matches TESTS will be run. For example, the following interactive command causes all of the "for" tests in groups 2 and 4 to be executed: set TESTS {for-[24]*} TESTS defaults to *, but you can change the default in "defs" if you wish. Saving keystrokes: ------------------ A convenience procedure named "dotests" is included in file "defs". It takes two arguments--the name of the test file (such as "parse.test"), and a pattern selecting the tests you want to execute. It sets TESTS to the second argument, calls "source" on the file specified in the first argument, and restores TESTS to its pre-call value at the end. Batch vs. interactive execution: -------------------------------- The tests can be run in either batch or interactive mode. Batch mode refers to using I/O redirection from a UNIX shell. For example, the following command causes the tests in the file named "parse.test" to be executed: tclTest < parse.test > parse.test.results Users who want to execute the tests in this fashion need to first ensure that the file "defs" has proper values for the global variables that control the testing environment (VERBOSE and TESTS). tcl7.4b4/tests/lindex.test010044400630510000012000000044340567470012100163570ustar00ousterstaff00002300000001# Commands covered: lindex # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # @(#) lindex.test 1.4 94/12/17 16:20:05 if {[string compare test [info procs test]] == 1} then {source defs} test lindex-1.1 {basic tests} { lindex {a b c} 0} a test lindex-1.2 {basic tests} { lindex {a {b c d} x} 1} {b c d} test lindex-1.3 {basic tests} { lindex {a b\ c\ d x} 1} {b c d} test lindex-1.4 {basic tests} { lindex {a b c} 3} {} test lindex-1.5 {basic tests} { list [catch {lindex {a b c} -1} msg] $msg } {0 {}} test lindex-1.6 {basic tests} { lindex {a b c d} end } d test lindex-1.7 {basic tests} { lindex {a b c d} 100 } {} test lindex-1.8 {basic tests} { lindex {a} e } a test lindex-1.9 {basic tests} { lindex {} end } {} test lindex-1.10 {basic tests} { lindex {a b c d} 3 } d test lindex-2.1 {error conditions} { list [catch {lindex msg} msg] $msg } {1 {wrong # args: should be "lindex list index"}} test lindex-2.2 {error conditions} { list [catch {lindex 1 2 3 4} msg] $msg } {1 {wrong # args: should be "lindex list index"}} test lindex-2.3 {error conditions} { list [catch {lindex 1 2a2} msg] $msg } {1 {expected integer but got "2a2"}} test lindex-2.4 {error conditions} { list [catch {lindex "a \{" 2} msg] $msg } {1 {unmatched open brace in list}} test lindex-2.5 {error conditions} { list [catch {lindex {a {b c}d e} 2} msg] $msg } {1 {list element in braces followed by "d" instead of space}} test lindex-2.6 {error conditions} { list [catch {lindex {a "b c"def ghi} 2} msg] $msg } {1 {list element in quotes followed by "def" instead of space}} test lindex-3.1 {quoted elements} { lindex {a "b c" d} 1 } {b c} test lindex-3.2 {quoted elements} { lindex {"{}" b c} 0 } {{}} test lindex-3.3 {quoted elements} { lindex {ab "c d \" x" y} 1 } {c d " x} test lindex-3.4 {quoted elements} { lindex {a b {c d "e} {f g"}} 2 } {c d "e} tcl7.4b4/tests/link.test010044400630510000012000000137320567470012100160320ustar00ousterstaff00002300000001# Commands covered: none # # This file contains a collection of tests for Tcl_LinkVar and related # library procedures. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # @(#) link.test 1.8 94/12/17 16:20:06 if {[info commands testlink] == {}} { puts "This application hasn't been compiled with the \"testlink\"" puts "command, so I can't test Tcl_LinkVar et al." return } if {[string compare test [info procs test]] == 1} then {source defs} foreach i {int real bool string} { catch {unset $i} } test link-1.1 {reading C variables from Tcl} { testlink delete testlink set 43 1.23 4 - testlink create 1 1 1 1 list $int $real $bool $string } {43 1.23 1 NULL} test link-1.2 {reading C variables from Tcl} { testlink delete testlink create 1 1 1 1 testlink set -3 2 0 "A long string with spaces" list $int $real $bool $string $int $real $bool $string } {-3 2.0 0 {A long string with spaces} -3 2.0 0 {A long string with spaces}} test link-2.1 {writing C variables from Tcl} { testlink delete testlink set 43 1.23 4 - testlink create 1 1 1 1 set int "00721" set real -8e13 set bool true set string abcdef concat [testlink get] $int $real $bool $string } {465 -8e+13 1 abcdef 00721 -8e13 true abcdef} test link-2.2 {writing bad values into variables} { testlink delete testlink set 43 1.23 4 - testlink create 1 1 1 1 list [catch {set int 09a} msg] $msg $int } {1 {can't set "int": variable must have integer value} 43} test link-2.3 {writing bad values into variables} { testlink delete testlink set 43 1.23 4 - testlink create 1 1 1 1 list [catch {set real 1.x3} msg] $msg $real } {1 {can't set "real": variable must have real value} 1.23} test link-2.4 {writing bad values into variables} { testlink delete testlink set 43 1.23 4 - testlink create 1 1 1 1 list [catch {set bool gorp} msg] $msg $bool } {1 {can't set "bool": variable must have boolean value} 1} test link-3.1 {read-only variables} { testlink delete testlink set 43 1.23 4 - testlink create 0 1 1 0 list [catch {set int 4} msg] $msg $int \ [catch {set real 10.6} msg] $msg $real \ [catch {set bool no} msg] $msg $bool \ [catch {set string "new value"} msg] $msg $string } {1 {can't set "int": linked variable is read-only} 43 0 10.6 10.6 0 no no 1 {can't set "string": linked variable is read-only} NULL} test link-3.2 {read-only variables} { testlink delete testlink set 43 1.23 4 - testlink create 1 0 0 1 list [catch {set int 4} msg] $msg $int \ [catch {set real 10.6} msg] $msg $real \ [catch {set bool no} msg] $msg $bool \ [catch {set string "new value"} msg] $msg $string } {0 4 4 1 {can't set "real": linked variable is read-only} 1.23 1 {can't set "bool": linked variable is read-only} 1 0 {new value} {new value}} test link-4.1 {unsetting linked variables} { testlink delete testlink set -6 -2.1 0 stringValue testlink create 1 1 1 1 unset int real bool string list [catch {set int} msg] $msg [catch {set real} msg] $msg \ [catch {set bool} msg] $msg [catch {set string} msg] $msg } {0 -6 0 -2.1 0 0 0 stringValue} test link-4.2 {unsetting linked variables} { testlink delete testlink set -6 -2.1 0 stringValue testlink create 1 1 1 1 unset int real bool string set int 102 set real 16 set bool true set string newValue testlink get } {102 16.0 1 newValue} test link-5.1 {unlinking variables} { testlink delete testlink set -6 -2.1 0 stringValue testlink delete set int xx1 set real qrst set bool bogus set string 12345 testlink get } {-6 -2.1 0 stringValue} test link-5.2 {unlinking variables} { testlink delete testlink set -6 -2.1 0 stringValue testlink create 1 1 1 1 testlink delete testlink set 25 14.7 7 - list $int $real $bool $string } {-6 -2.1 0 stringValue} test link-6.1 {errors in setting up link} { testlink delete catch {unset int} set int(44) 1 list [catch {testlink create 1 1 1 1} msg] $msg } {1 {can't set "int": variable is array}} catch {unset int} test link-7.1 {access to linked variables via upvar} { proc x {} { upvar int y unset y } testlink delete testlink create 1 0 0 0 testlink set 14 {} {} {} x list [catch {set int} msg] $msg } {0 14} test link-7.2 {access to linked variables via upvar} { proc x {} { upvar int y return [set y] } testlink delete testlink create 1 0 0 0 testlink set 0 {} {} {} set int testlink set 23 {} {} {} x list [x] $int } {23 23} test link-7.3 {access to linked variables via upvar} { proc x {} { upvar int y set y 44 } testlink delete testlink create 0 0 0 0 testlink set 11 {} {} {} list [catch x msg] $msg $int } {1 {can't set "y": linked variable is read-only} 11} test link-7.4 {access to linked variables via upvar} { proc x {} { upvar int y set y abc } testlink delete testlink create 1 1 1 1 testlink set -4 {} {} {} list [catch x msg] $msg $int } {1 {can't set "y": variable must have integer value} -4} test link-7.5 {access to linked variables via upvar} { proc x {} { upvar real y set y abc } testlink delete testlink create 1 1 1 1 testlink set -4 16.3 {} {} list [catch x msg] $msg $real } {1 {can't set "y": variable must have real value} 16.3} test link-7.6 {access to linked variables via upvar} { proc x {} { upvar bool y set y abc } testlink delete testlink create 1 1 1 1 testlink set -4 16.3 1 {} list [catch x msg] $msg $bool } {1 {can't set "y": variable must have boolean value} 1} testlink delete foreach i {int real bool string} { catch {unset $i} } tcl7.4b4/tests/linsert.test010044400630510000012000000054130567470012100165520ustar00ousterstaff00002300000001# Commands covered: linsert # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # @(#) linsert.test 1.7 94/12/17 16:20:07 if {[string compare test [info procs test]] == 1} then {source defs} test linsert-1.1 {linsert command} { linsert {1 2 3 4 5} 0 a } {a 1 2 3 4 5} test linsert-1.2 {linsert command} { linsert {1 2 3 4 5} 1 a } {1 a 2 3 4 5} test linsert-1.3 {linsert command} { linsert {1 2 3 4 5} 2 a } {1 2 a 3 4 5} test linsert-1.4 {linsert command} { linsert {1 2 3 4 5} 3 a } {1 2 3 a 4 5} test linsert-1.5 {linsert command} { linsert {1 2 3 4 5} 4 a } {1 2 3 4 a 5} test linsert-1.6 {linsert command} { linsert {1 2 3 4 5} 5 a } {1 2 3 4 5 a} test linsert-1.7 {linsert command} { linsert {1 2 3 4 5} 2 one two \{three \$four } {1 2 one two \{three {$four} 3 4 5} test linsert-1.8 {linsert command} { linsert {\{one \$two \{three \ four \ five} 2 a b c } {\{one \$two a b c \{three \ four \ five} test linsert-1.9 {linsert command} { linsert {{1 2} {3 4} {5 6} {7 8}} 2 {x y} {a b} } {{1 2} {3 4} {x y} {a b} {5 6} {7 8}} test linsert-1.10 {linsert command} { linsert {} 2 a b c } {a b c} test linsert-1.11 {linsert command} { linsert {} 2 {} } {{}} test linsert-1.12 {linsert command} { linsert {a b "c c" d e} 3 1 } {a b "c c" 1 d e} test linsert-1.13 {linsert command} { linsert { a b c d} 0 1 2 } {1 2 a b c d} test linsert-1.14 {linsert command} { linsert {a b c {d e f}} 4 1 2 } {a b c {d e f} 1 2} test linsert-1.15 {linsert command} { linsert {a b c \{\ abc} 4 q r } {a b c \{\ q r abc} test linsert-1.16 {linsert command} { linsert {a b c \{ abc} 4 q r } {a b c \{ q r abc} test linsert-1.17 {linsert command} { linsert {a b c} end q r } {a b c q r} test linsert-1.18 {linsert command} { linsert {a} end q r } {a q r} test linsert-1.19 {linsert command} { linsert {} end q r } {q r} test linsert-2.1 {linsert errors} { list [catch linsert msg] $msg } {1 {wrong # args: should be "linsert list index element ?element ...?"}} test linsert-2.2 {linsert errors} { list [catch {linsert a b} msg] $msg } {1 {wrong # args: should be "linsert list index element ?element ...?"}} test linsert-2.3 {linsert errors} { list [catch {linsert a 12x 2} msg] $msg } {1 {expected integer but got "12x"}} test linsert-2.4 {linsert errors} { list [catch {linsert \{ 12 2} msg] $msg } {1 {unmatched open brace in list}} \ five} 2 a b c } {\{one \$two a b c \{three \ four \ five} test linsert-1.9 {linsert command} { linsert {{1 2} {3 4} {5 6} {7 8}} 2 {x y} {a b} } {{1 2} {3 4} {x y} {a b} {5 6} {7 8}} test linsert-1.10 {linsert command} { linsert {} 2 tcl7.4b4/tests/list.test010044400630510000012000000054530567470012100160510ustar00ousterstaff00002300000001# Commands covered: list # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # @(#) list.test 1.19 94/12/17 16:20:08 if {[string compare test [info procs test]] == 1} then {source defs} # First, a bunch of individual tests test list-1.1 {basic tests} {list a b c} {a b c} test list-1.2 {basic tests} {list {a b} c} {{a b} c} test list-1.3 {basic tests} {list \{a b c} {\{a b c} test list-1.4 {basic tests} "list a{}} b{} c}" "a\\{\\}\\} b{} c\\}" test list-1.5 {basic tests} {list a\[ b\] } "{a\[} b\\]" test list-1.6 {basic tests} {list c\ d\t } "{c } {d\t}" test list-1.7 {basic tests} {list e\n f\$ } "{e\n} {f\$}" test list-1.8 {basic tests} {list g\; h\\} {{g;} h\\} test list-1.9 {basic tests} "list a\\\[} b\\\]} " "a\\\[\\\} b\\\]\\\}" test list-1.10 {basic tests} "list c\\\} d\\t} " "c\\} d\\t\\}" test list-1.11 {basic tests} "list e\\n} f\\$} " "e\\n\\} f\\$\\}" test list-1.12 {basic tests} "list g\\;} h\\\\} " "g\\;\\} {h\\}}" test list-1.13 {basic tests} {list a {{}} b} {a {{}} b} test list-1.14 {basic tests} {list a b xy\\} "a b xy\\\\" test list-1.15 {basic tests} "list a b\} e\\" "a b\\} e\\\\" test list-1.16 {basic tests} "list a b\}\\\$ e\\\$\\" "a b\\}\\\$ e\\\$\\\\" test list-1.17 {basic tests} {list a\f \{\f} "{a\f} \\\{\\f" test list-1.18 {basic tests} {list a\r \{\r} "{a\r} \\\{\\r" test list-1.19 {basic tests} {list a\v \{\v} "{a\v} \\\{\\v" test list-1.20 {basic tests} {list \"\}\{} "\\\"\\}\\{" test list-1.21 {basic tests} {list a b c\\\nd} "a b c\\\\\\nd" test list-1.22 {basic tests} {list "{ab}\\"} \\{ab\\}\\\\ test list-1.23 {basic tests} {list \{} "\\{" test list-1.24 {basic tests} {list} {} # For the next round of tests create a list and then pick it apart # with "index" to make sure that we get back exactly what went in. set num 1 proc lcheck {a b c} { global num d set d [list $a $b $c] test list-2.$num {what goes in must come out} {lindex $d 0} $a set num [expr $num+1] test list-2.$num {what goes in must come out} {lindex $d 1} $b set num [expr $num+1] test list-2.$num {what goes in must come out} {lindex $d 2} $c set num [expr $num+1] } lcheck a b c lcheck "a b" c\td e\nf lcheck {{a b}} {} { } lcheck \$ \$ab ab\$ lcheck \; \;ab ab\; lcheck \[ \[ab ab\[ lcheck \\ \\ab ab\\ lcheck {"} {"ab} {ab"} lcheck {a b} { ab} {ab } lcheck a{ a{b \{ab lcheck a} a}b }ab lcheck a\\} {a \}b} {a \{c} lcheck xyz \\ 1\\\n2 lcheck "{ab}\\" "{ab}xy" abc concat {} tcl7.4b4/tests/llength.test010044400630510000012000000022170567470012200165270ustar00ousterstaff00002300000001# Commands covered: llength # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # @(#) llength.test 1.3 94/12/17 16:20:09 if {[string compare test [info procs test]] == 1} then {source defs} test llength-1.1 {length of list} { llength {a b c d} } 4 test llength-1.2 {length of list} { llength {a b c {a b {c d}} d} } 5 test llength-1.3 {length of list} { llength {} } 0 test llength-2.1 {error conditions} { list [catch {llength} msg] $msg } {1 {wrong # args: should be "llength list"}} test llength-2.2 {error conditions} { list [catch {llength 123 2} msg] $msg } {1 {wrong # args: should be "llength list"}} test llength-2.3 {error conditions} { list [catch {llength "a b c \{"} msg] $msg } {1 {unmatched open brace in list}} tcl7.4b4/tests/lrange.test010044400630510000012000000050240567470012200163410ustar00ousterstaff00002300000001# Commands covered: lrange # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # @(#) lrange.test 1.4 94/12/17 16:20:10 if {[string compare test [info procs test]] == 1} then {source defs} test lrange-1.1 {range of list elements} { lrange {a b c d} 1 2 } {b c} test lrange-1.2 {range of list elements} { lrange {a {bcd e {f g {}}} l14 l15 d} 1 1 } {{bcd e {f g {}}}} test lrange-1.3 {range of list elements} { lrange {a {bcd e {f g {}}} l14 l15 d} 3 end } {l15 d} test lrange-1.4 {range of list elements} { lrange {a {bcd e {f g {}}} l14 l15 d} 4 10000 } {d} test lrange-1.5 {range of list elements} { lrange {a {bcd e {f g {}}} l14 l15 d} 4 3 } {} test lrange-1.6 {range of list elements} { lrange {a {bcd e {f g {}}} l14 l15 d} 10 11 } {} test lrange-1.7 {range of list elements} { lrange {a b c d e} -1 2 } {a b c} test lrange-1.8 {range of list elements} { lrange {a b c d e} -2 -1 } {} test lrange-1.9 {range of list elements} { lrange {a b c d e} -2 e } {a b c d e} test lrange-1.10 {range of list elements} { lrange "a b\{c d" 1 2 } "b\{c d" test lrange-1.11 {range of list elements} { lrange "a b c d" end end } d test lrange-1.12 {range of list elements} { lrange "a b c d" end 100000 } d test lrange-1.13 {range of list elements} { lrange "a b c d" e 3 } d test lrange-1.14 {range of list elements} { lrange "a b c d" end 2 } {} test lrange-2.1 {error conditions} { list [catch {lrange a b} msg] $msg } {1 {wrong # args: should be "lrange list first last"}} test lrange-2.2 {error conditions} { list [catch {lrange a b 6 7} msg] $msg } {1 {wrong # args: should be "lrange list first last"}} test lrange-2.3 {error conditions} { list [catch {lrange a b 6} msg] $msg } {1 {expected integer but got "b"}} test lrange-2.4 {error conditions} { list [catch {lrange a 0 enigma} msg] $msg } {1 {expected integer or "end" but got "enigma"}} test lrange-2.5 {error conditions} { list [catch {lrange "a \{b c" 3 4} msg] $msg } {1 {unmatched open brace in list}} test lrange-2.6 {error conditions} { list [catch {lrange "a b c \{ d e" 1 4} msg] $msg } {1 {unmatched open brace in list}} lrange # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # @(#) lrange.test 1.tcl7.4b4/tests/lreplace.test010044400630510000012000000071240567470012200166630ustar00ousterstaff00002300000001# Commands covered: lreplace # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # @(#) lreplace.test 1.7 94/12/17 16:20:11 if {[string compare test [info procs test]] == 1} then {source defs} test lreplace-1.1 {lreplace command} { lreplace {1 2 3 4 5} 0 0 a } {a 2 3 4 5} test lreplace-1.2 {lreplace command} { lreplace {1 2 3 4 5} 1 1 a } {1 a 3 4 5} test lreplace-1.3 {lreplace command} { lreplace {1 2 3 4 5} 2 2 a } {1 2 a 4 5} test lreplace-1.4 {lreplace command} { lreplace {1 2 3 4 5} 3 3 a } {1 2 3 a 5} test lreplace-1.5 {lreplace command} { lreplace {1 2 3 4 5} 4 4 a } {1 2 3 4 a} test lreplace-1.6 {lreplace command} { lreplace {1 2 3 4 5} 4 5 a } {1 2 3 4 a} test lreplace-1.7 {lreplace command} { lreplace {1 2 3 4 5} -1 -1 a } {a 2 3 4 5} test lreplace-1.8 {lreplace command} { lreplace {1 2 3 4 5} 2 end a b c d } {1 2 a b c d} test lreplace-1.9 {lreplace command} { lreplace {1 2 3 4 5} 0 3 } {5} test lreplace-1.10 {lreplace command} { lreplace {1 2 3 4 5} 0 4 } {} test lreplace-1.11 {lreplace command} { lreplace {1 2 3 4 5} 0 1 } {3 4 5} test lreplace-1.12 {lreplace command} { lreplace {1 2 3 4 5} 2 3 } {1 2 5} test lreplace-1.13 {lreplace command} { lreplace {1 2 3 4 5} 3 end } {1 2 3} test lreplace-1.14 {lreplace command} { lreplace {1 2 3 4 5} -1 4 a b c } {a b c} test lreplace-1.15 {lreplace command} { lreplace {a b "c c" d e f} 3 3 } {a b "c c" e f} test lreplace-1.16 {lreplace command} { lreplace { 1 2 3 4 5} 0 0 a } {a 2 3 4 5} test lreplace-1.17 {lreplace command} { lreplace {1 2 3 4 "5 6"} 4 4 a } {1 2 3 4 a} test lreplace-1.18 {lreplace command} { lreplace {1 2 3 4 {5 6}} 4 4 a } {1 2 3 4 a} test lreplace-1.19 {lreplace command} { lreplace {1 2 3 4} 2 end x y z } {1 2 x y z} test lreplace-1.20 {lreplace command} { lreplace {1 2 3 4} end end a } {1 2 3 a} test lreplace-1.21 {lreplace command} { lreplace {1 2 3 4} end 3 a } {1 2 3 a} test lreplace-1.22 {lreplace command} { lreplace {1 2 3 4} end end } {1 2 3} test lreplace-2.1 {lreplace errors} { list [catch lreplace msg] $msg } {1 {wrong # args: should be "lreplace list first last ?element element ...?"}} test lreplace-2.2 {lreplace errors} { list [catch {lreplace a b} msg] $msg } {1 {wrong # args: should be "lreplace list first last ?element element ...?"}} test lreplace-2.3 {lreplace errors} { list [catch {lreplace x a 10} msg] $msg } {1 {expected integer but got "a"}} test lreplace-2.4 {lreplace errors} { list [catch {lreplace x 10 x} msg] $msg } {1 {bad index "x": must be integer or "end"}} test lreplace-2.5 {lreplace errors} { list [catch {lreplace x 10 1x} msg] $msg } {1 {expected integer but got "1x"}} test lreplace-2.6 {lreplace errors} { list [catch {lreplace x 3 2} msg] $msg } {1 {list doesn't contain element 3}} test lreplace-2.7 {lreplace errors} { list [catch {lreplace x 1 1} msg] $msg } {1 {list doesn't contain element 1}} test lreplace-2.8 {lreplace errors} { list [catch {lreplace {a b c d} 3 2} msg] $msg } {1 {first index must not be greater than second}} test lreplace-2.9 {lreplace errors} { list [catch {lreplace {a b c d} end 1} msg] $msg } {1 {first index must not be greater than second}} tcl7.4b4/tests/lsearch.test010044400630510000012000000043360567470012200165170ustar00ousterstaff00002300000001# Commands covered: lsearch # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # @(#) lsearch.test 1.4 94/12/17 16:20:12 if {[string compare test [info procs test]] == 1} then {source defs} set x {abcd bbcd 123 234 345} test lsearch-1.1 {lsearch command} { lsearch $x 123 } 2 test lsearch-1.2 {lsearch command} { lsearch $x 3456 } -1 test lsearch-1.3 {lsearch command} { lsearch $x *5 } 4 test lsearch-1.4 {lsearch command} { lsearch $x *bc* } 0 test lsearch-2.1 {search modes} { lsearch -exact {xyz bbcc *bc*} *bc* } 2 test lsearch-2.2 {search modes} { lsearch -exact {b.x ^bc xy bcx} ^bc } 1 test lsearch-2.3 {search modes} { list [catch {lsearch -regexp {xyz bbcc *bc*} *bc*} msg] $msg } {1 {couldn't compile regular expression pattern: ?+* follows nothing}} test lsearch-2.4 {search modes} { lsearch -regexp {b.x ^bc xy bcx} ^bc } 3 test lsearch-2.5 {search modes} { lsearch -glob {xyz bbcc *bc*} *bc* } 1 test lsearch-2.6 {search modes} { lsearch -glob {b.x ^bc xy bcx} ^bc } 1 test lsearch-2.7 {search modes} { list [catch {lsearch -glib {b.x bx xy bcx} b.x} msg] $msg } {1 {bad search mode "-glib": must be -exact, -glob, or -regexp}} test lsearch-3.1 {lsearch errors} { list [catch lsearch msg] $msg } {1 {wrong # args: should be "lsearch ?mode? list pattern"}} test lsearch-3.2 {lsearch errors} { list [catch {lsearch a} msg] $msg } {1 {wrong # args: should be "lsearch ?mode? list pattern"}} test lsearch-3.3 {lsearch errors} { list [catch {lsearch a b c} msg] $msg } {1 {bad search mode "a": must be -exact, -glob, or -regexp}} test lsearch-3.4 {lsearch errors} { list [catch {lsearch a b c d} msg] $msg } {1 {wrong # args: should be "lsearch ?mode? list pattern"}} test lsearch-3.5 {lsearch errors} { list [catch {lsearch "\{" b} msg] $msg } {1 {unmatched open brace in list}} tcl7.4b4/tests/lsort.test010044400630510000012000000120640576471520200162430ustar00ousterstaff00002300000001# Commands covered: lsort # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # @(#) lsort.test 1.6 95/06/05 17:00:02 if {[string compare test [info procs test]] == 1} then {source defs} test lsort-1.1 {lsort command} { lsort {abdeq ab 1 ac a} } {1 a ab abdeq ac} test lsort-1.2 {lsort command} { lsort -decreasing {abdeq ab 1 ac a} } {ac abdeq ab a 1} test lsort-1.3 {lsort command} { lsort -increasing {abdeq ab 1 ac a} } {1 a ab abdeq ac} test lsort-1.4 {lsort command} { lsort {{one long element}} } {{one long element}} test lsort-1.5 {lsort command} { lsort {} } {} test lsort-1.6 {lsort with characters needing backslashes} { lsort {$ \\ [] \{} } {{$} {[]} \\ \{} test lsort-2.1 {lsort -integer} { lsort -integer -inc {1 180 62 040 180 -42 33 0x40} } {-42 1 040 33 62 0x40 180 180} test lsort-2.2 {lsort -integer} { lsort -int -dec {1 180 62 040 180 -42 33 0x40} } {180 180 0x40 62 33 040 1 -42} test lsort-2.3 {lsort -integer} { list [catch {lsort -integer {xxx 180.2 62 040 180 -42 33 0x40}} msg] $msg $errorInfo } {1 {expected integer but got "xxx"} {expected integer but got "xxx" (converting list element from string to integer) invoked from within "lsort -integer {xxx 180.2 62 040 180 -42 33 0x40}"}} test lsort-2.4 {lsort -integer} { list [catch {lsort -integer {1 180.2 62 040 180 -42 33 0x40}} msg] $msg $errorInfo } {1 {expected integer but got "180.2"} {expected integer but got "180.2" (converting list element from string to integer) invoked from within "lsort -integer {1 180.2 62 040 180 -42 33 0x40}"}} test lsort-3.1 {lsort -real} { lsort -real {1 180.1 62 040 180 -42.7 33} } {-42.7 1 33 040 62 180 180.1} test lsort-3.2 {lsort -real} { lsort -r -d {1 180.1 62 040 180 -42.7 33} } {180.1 180 62 040 33 1 -42.7} test lsort-3.3 {lsort -real} { list [catch {lsort -real -inc {xxx 20 62 180 -42.7 33}} msg] $msg $errorInfo } {1 {expected floating-point number but got "xxx"} {expected floating-point number but got "xxx" (converting list element from string to real) invoked from within "lsort -real -inc {xxx 20 62 180 -42.7 33}"}} test lsort-3.4 {lsort -real} { list [catch {lsort -real -inc {1 0x40 62 180 -42.7 33}} msg] $msg $errorInfo } {1 {expected floating-point number but got "0x40"} {expected floating-point number but got "0x40" (converting list element from string to real) invoked from within "lsort -real -inc {1 0x40 62 180 -42.7 33}"}} proc lsort1 {a b} { expr {2*([string match x* $a] - [string match x* $b]) + [string match *y $a] - [string match *y $b]} } proc lsort2 {a b} { error "comparison error" } proc lsort3 {a b} { concat "foobar" } test lsort-4.1 {lsort -command} { lsort -command lsort1 {xxx yyy abc {xx y}} } {abc yyy xxx {xx y}} test lsort-4.2 {lsort -command} { lsort -command lsort1 -dec {xxx yyy abc {xx y}} } {{xx y} xxx yyy abc} test lsort-4.3 {lsort -command} { list [catch {lsort -command lsort2 -dec {1 1 1 1}} msg] $msg $errorInfo } {1 {comparison error} {comparison error while executing "error "comparison error"" (procedure "lsort2" line 2) invoked from within "lsort2 1 1" (user-defined comparison command) invoked from within "lsort -command lsort2 -dec {1 1 1 1}"}} test lsort-4.4 {lsort -command} { list [catch {lsort -command lsort3 -dec {1 2 3 4}} msg] $msg $errorInfo } {1 {comparison command returned non-numeric result} {comparison command returned non-numeric result while executing "lsort -command lsort3 -dec {1 2 3 4}"}} test lsort-4.5 {lsort -command} { list [catch {lsort -command {xxx yyy xxy abc}} msg] $msg } {1 {"-command" must be followed by comparison command}} test lsort-5.1 {lsort errors} { list [catch lsort msg] $msg } {1 {wrong # args: should be "lsort ?-ascii? ?-integer? ?-real? ?-increasing? ?-decreasing? ?-command string? list"}} test lsort-5.2 {lsort errors} { list [catch {lsort a b} msg] $msg } {1 {bad switch "a": must be -ascii, -integer, -real, -increasing -decreasing, or -command}} test lsort-5.3 {lsort errors} { list [catch {lsort "\{"} msg] $msg } {1 {unmatched open brace in list}} test lsort-5.4 {lsort errors} { list [catch {lsort -in {1 180.0 040 62 180 -42.7 33}} msg] $msg } {1 {bad switch "-in": must be -ascii, -integer, -real, -increasing -decreasing, or -command}} test lsort-5.5 {lsort errors: disallow recursion} { proc x args {lsort {a b c}} list [catch {lsort -command x {3 7}} msg] $msg $errorInfo } {1 {can't invoke "lsort" recursively} {can't invoke "lsort" recursively while executing "lsort {a b c}" (procedure "x" line 1) invoked from within "x 3 7" (user-defined comparison command) invoked from within "lsort -command x {3 7}"}} tcl7.4b4/tests/misc.test010044400630510000012000000037770567470012200160410ustar00ousterstaff00002300000001# Commands covered: various # # This file contains a collection of miscellaneous Tcl tests that # don't fit naturally in any of the other test files. Many of these # tests are pathological cases that caused bugs in earlier Tcl # releases. # # Copyright (c) 1992-1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # @(#) misc.test 1.4 94/12/17 16:20:14 if {[string compare test [info procs test]] == 1} then {source defs} test misc-1.1 {error in variable ref. in command in array reference} { proc tstProc {} { global a set tst $a([winfo name $zz]) # this is a bogus comment # this is a bogus comment # this is a bogus comment # this is a bogus comment # this is a bogus comment # this is a bogus comment # this is a bogus comment # this is a bogus comment } set msg {} list [catch tstProc msg] $msg } {1 {can't read "zz": no such variable}} test misc-1.2 {error in variable ref. in command in array reference} { proc tstProc {} " global a set tst \$a(\[winfo name \$\{zz) # this is a bogus comment # this is a bogus comment # this is a bogus comment # this is a bogus comment # this is a bogus comment # this is a bogus comment # this is a bogus comment # this is a bogus comment " set msg {} list [catch tstProc msg] $msg $errorInfo } [list 1 {missing close-brace for variable name} \ [format {missing close-brace for variable name while executing "winfo name $%szz) # this is a bogus comment # this is a bogus comment # this is a bogus comment # this is a bogus comment # this is a bogus commen ..." (parsing index for array "a") invoked from within "set tst $a([winfo name $%szz) # this is a bogus comment # this is a bogus comment # this is a bogus comment # this is a bogus comment # this is a ..." (procedure "tstProc" line 4) invoked from within "tstProc"} \{ \{]] tcl7.4b4/tests/open.test010044400630510000012000000474650572223247600160570ustar00ousterstaff00002300000001# Commands covered: open, close, gets, puts, read, seek, tell, eof, flush # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1994 The Regents of the University of California. # Copyright (c) 1994-1995 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # @(#) open.test 1.27 95/02/20 16:35:10 if {[string compare test [info procs test]] == 1} then {source defs} catch {exec rm -f test1 test2 test3} exec cat > test1 << "Two lines: this one\nand this one\n" exec cat > test2 << "line1\nline2\nline3\nline4\nline5\n" test open-1.1 {open command (files only)} { set f [open test1] set x [gets $f] close $f set x } {Two lines: this one} test open-1.2 {open command (files only)} { set f [open test1] set f2 [open test2] set f3 [open test1] set f4 [open test1] set x [list [gets $f] [gets $f2] [gets $f3] [gets $f4] \ [gets $f] [gets $f2]] close $f close $f2 close $f3 close $f4 set x } {{Two lines: this one} line1 {Two lines: this one} {Two lines: this one} {and this one} line2} test open-1.3 {open command (files only)} { set f [open test3 w] puts $f xyz close $f exec cat test3 } "xyz" test open-1.4 {open command (files only)} { set f [open test3 w] puts $f xyz close $f set f [open test3 a] puts $f 123 close $f exec cat test3 } "xyz\n123" test open-1.5 {open command (files only)} { set f [open test3 w] puts $f xyz\n123 close $f set f [open test3 r+] set x [gets $f] seek $f 0 current puts $f 456 close $f list $x [exec cat test3] } "xyz {xyz 456}" test open-1.6 {open command (files only)} { set f [open test3 w] puts $f xyz\n123 close $f set f [open test3 w+] puts $f xyzzy seek $f 2 set x [gets $f] close $f list $x [exec cat test3] } "zzy xyzzy" test open-1.7 {open command (files only)} { set f [open test3 w] puts $f xyz\n123 close $f set f [open test3 a+] puts $f xyzzy flush $f set x [tell $f] seek $f -4 cur set y [gets $f] close $f list $x [exec cat test3] $y } {14 {xyz 123 xyzzy} zzy} test open-2.1 {errors in open command} { list [catch {open} msg] $msg } {1 {wrong # args: should be "open filename ?access? ?permissions?"}} test open-2.2 {errors in open command} { list [catch {open a b c d} msg] $msg } {1 {wrong # args: should be "open filename ?access? ?permissions?"}} test open-2.3 {errors in open command} { list [catch {open test1 x} msg] $msg } {1 {illegal access mode "x"}} test open-2.4 {errors in open command} { list [catch {open test1 rw} msg] $msg } {1 {illegal access mode "rw"}} test open-2.5 {errors in open command} { list [catch {open test1 r+1} msg] $msg } {1 {illegal access mode "r+1"}} test open-2.6 {errors in open command} { string tolower [list [catch {open _non_existent_} msg] $msg $errorCode] } {1 {couldn't open "_non_existent_": no such file or directory} {posix enoent {no such file or directory}}} if {![file exists ~/_test_] && [file writable ~]} { test open-3.1 {tilde substitution in open} { set f [open ~/_test_ w] puts $f "Some text" close $f set x [file exists $env(HOME)/_test_] exec rm -f $env(HOME)/_test_ set x } 1 } test open-3.2 {tilde substitution in open} { set home $env(HOME) unset env(HOME) set x [list [catch {open ~/foo} msg] $msg] set env(HOME) $home set x } {1 {couldn't find HOME environment variable to expand "~/foo"}} test open-4.1 {file id parsing errors} { list [catch {eof gorp} msg] $msg $errorCode } {1 {bad file identifier "gorp"} NONE} test open-4.2 {file id parsing errors} { list [catch {eof filex} msg] $msg } {1 {bad file identifier "filex"}} test open-4.3 {file id parsing errors} { list [catch {eof file12a} msg] $msg } {1 {bad file identifier "file12a"}} test open-4.4 {file id parsing errors} { list [catch {eof file123} msg] $msg } {1 {file "file123" isn't open}} test open-4.5 {file id parsing errors} { list [catch {eof file1} msg] $msg } {0 0} test open-4.6 {file id parsing errors} { list [catch {eof stdin} msg] $msg } {0 0} test open-4.7 {file id parsing errors} { list [catch {eof stdout} msg] $msg } {0 0} test open-4.8 {file id parsing errors} { list [catch {eof stderr} msg] $msg } {0 0} test open-4.9 {file id parsing errors} { list [catch {eof stderr1} msg] $msg } {1 {bad file identifier "stderr1"}} set f [open test1] close $f set expect "1 {file \"$f\" isn't open}" test open-4.10 {file id parsing errors} { list [catch {eof $f} msg] $msg } $expect test open-5.1 {close command (files only)} { list [catch {close} msg] $msg $errorCode } {1 {wrong # args: should be "close fileId"} NONE} test open-5.2 {close command (files only)} { list [catch {close a b} msg] $msg $errorCode } {1 {wrong # args: should be "close fileId"} NONE} test open-5.3 {close command (files only)} { list [catch {close gorp} msg] $msg $errorCode } {1 {bad file identifier "gorp"} NONE} test open-5.4 {close command (files only)} { list [catch {close file4} msg] \ [string range $msg [string first {" } $msg] end] $errorCode } {1 {" isn't open} NONE} test open-6.1 {puts command} { list [catch {puts} msg] $msg $errorCode } {1 {wrong # args: should be "puts ?-nonewline? ?fileId? string"} NONE} test open-6.2 {puts command} { list [catch {puts a b c d} msg] $msg $errorCode } {1 {wrong # args: should be "puts ?-nonewline? ?fileId? string"} NONE} test open-6.3 {puts command} { list [catch {puts a b nonewlinx} msg] $msg $errorCode } {1 {bad argument "nonewlinx": should be "nonewline"} NONE} test open-6.4 {puts command} { list [catch {puts gorp "New text"} msg] $msg $errorCode } {1 {bad file identifier "gorp"} NONE} test open-6.5 {puts command} { set f [open test3] set x [list [catch {puts $f "New text"} msg] \ [string range $msg [string first " " $msg] end] $errorCode] close $f set x } {1 { wasn't opened for writing} NONE} test open-6.6 {puts command} { set f [open test3 w] puts -nonewline $f "Text1" puts -nonewline $f " Text 2" puts $f " Text 3" close $f exec cat test3 } {Text1 Text 2 Text 3} test open-7.1 {gets command} { list [catch {gets} msg] $msg $errorCode } {1 {wrong # args: should be "gets fileId ?varName?"} NONE} test open-7.2 {gets command} { list [catch {gets a b c} msg] $msg $errorCode } {1 {wrong # args: should be "gets fileId ?varName?"} NONE} test open-7.3 {gets command} { list [catch {gets a} msg] $msg $errorCode } {1 {bad file identifier "a"} NONE} test open-7.4 {gets command} { set f [open test3 w] set x [list [catch {gets $f} msg] \ [string range $msg [string first " " $msg] end] $errorCode] close $f set x } {1 { wasn't opened for reading} NONE} set f [open test3 w] puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" puts $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" close $f test open-7.5 {gets command with long line} { set f [open test3] set x [gets $f] close $f set x } {abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ} test open-7.6 {gets command with long line} { set f [open test3] set x [gets $f y] close $f list $x $y } {260 abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ} test open-7.7 {gets command and end of file} { set f [open test3 w] puts -nonewline $f "Test1\nTest2" close $f set f [open test3] set x {} set y {} lappend x [gets $f y] $y set y {} lappend x [gets $f y] $y set y {} lappend x [gets $f y] $y close $f set x } {5 Test1 5 Test2 -1 {}} set f [open test3 w] puts $f "Line 1" puts $f "Line 2" close $f test open-7.8 {gets command and bad variable} { catch {unset x} set x 24 set f [open test3 r] set result [list [catch {gets $f x(0)} msg] $msg] close $f set result } {1 {can't set "x(0)": variable isn't array}} test open-8.1 {read command} { list [catch {read} msg] $msg $errorCode } {1 {wrong # args: should be "read fileId ?numBytes?" or "read ?-nonewline? fileId"} NONE} test open-8.2 {read command} { list [catch {read -nonewline} msg] $msg $errorCode } {1 {bad file identifier "-nonewline"} NONE} test open-8.3 {read command} { list [catch {read a b c} msg] $msg $errorCode } {1 {wrong # args: should be "read fileId ?numBytes?" or "read ?-nonewline? fileId"} NONE} test open-8.4 {read command} { list [catch {read -nonew file4} msg] $msg $errorCode } {1 {bad file identifier "-nonew"} NONE} test open-8.5 {read command} { list [catch {read stdin foo} msg] $msg $errorCode } {1 {bad argument "foo": should be "nonewline"} NONE} test open-8.6 {read command} { list [catch {read file10} msg] $msg $errorCode } {1 {file "file10" isn't open} NONE} test open-8.7 {read command} { set f [open test3 w] set x [list [catch {read $f} msg] \ [string range $msg [string first " " $msg] end] $errorCode] close $f set x } {1 { wasn't opened for reading} NONE} test open-8.8 {read command} { set f [open test1] set x [list [catch {read $f 12z} msg] $msg $errorCode] close $f set x } {1 {expected integer but got "12z"} NONE} test open-8.9 {read command} { set f [open test1] set x [list [catch {read $f z} msg] $msg $errorCode] close $f set x } {1 {bad argument "z": should be "nonewline"} NONE} test open-8.10 {read command} { set f [open test1] set x [list [read $f 1] [read $f 2] [read $f]] close $f set x } {T wo { lines: this one and this one }} test open-8.11 {read command, with over-large count} { set f [open test1] set x [read $f 100] close $f set x } {Two lines: this one and this one } test open-8.12 {read command, -nonewline switch} { set f [open test1] set x [read -nonewline $f] close $f set x } {Two lines: this one and this one} test open-9.1 {seek command} { list [catch {seek foo} msg] $msg $errorCode } {1 {wrong # args: should be "seek fileId offset ?origin?"} NONE} test open-9.2 {seek command} { list [catch {seek foo a b c} msg] $msg $errorCode } {1 {wrong # args: should be "seek fileId offset ?origin?"} NONE} test open-9.3 {seek command} { list [catch {seek foo 0} msg] $msg $errorCode } {1 {bad file identifier "foo"} NONE} test open-9.4 {seek command} { set f [open test2] set x [list [catch {seek $f xyz} msg] $msg $errorCode] close $f set x } {1 {expected integer but got "xyz"} NONE} test open-9.5 {seek command} { set f [open test2] set x [list [catch {seek $f 100 gorp} msg] $msg $errorCode] close $f set x } {1 {bad origin "gorp": should be start, current, or end} NONE} set f [open test3 w] puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" close $f test open-9.6 {seek command} { set f [open test3] set x [read $f 1] seek $f 3 lappend x [read $f 1] seek $f 0 start lappend x [read $f 1] seek $f 10 current lappend x [read $f 1] seek $f -2 end lappend x [read $f 1] seek $f 50 end lappend x [read $f 1] seek $f 1 lappend x [read $f 1] close $f set x } {a d a l Y {} b} test open-10.1 {tell command} { list [catch {tell} msg] $msg $errorCode } {1 {wrong # args: should be "tell fileId"} NONE} test open-10.2 {tell command} { list [catch {tell a b} msg] $msg $errorCode } {1 {wrong # args: should be "tell fileId"} NONE} test open-10.3 {tell command} { list [catch {tell a} msg] $msg $errorCode } {1 {bad file identifier "a"} NONE} test open-10.4 {tell command} { set f [open test2] set x [tell $f] read $f 3 lappend x [tell $f] seek $f 2 lappend x [tell $f] seek $f 10 current lappend x [tell $f] seek $f 0 end lappend x [tell $f] close $f set x } {0 3 2 12 30} test open-11.1 {eof command} { list [catch {eof} msg] $msg $errorCode } {1 {wrong # args: should be "eof fileId"} NONE} test open-11.2 {eof command} { list [catch {eof a b} msg] $msg $errorCode } {1 {wrong # args: should be "eof fileId"} NONE} test open-11.3 {eof command} { list [catch {eof file100} msg] $msg $errorCode } {1 {file "file100" isn't open} NONE} test open-11.4 {eof command} { set f [open test1] set x [eof $f] lappend x [eof $f] gets $f lappend x [eof $f] gets $f lappend x [eof $f] gets $f lappend x [eof $f] lappend x [eof $f] close $f set x } {0 0 0 0 1 1} test open-12.1 {flush command} { list [catch {flush} msg] $msg $errorCode } {1 {wrong # args: should be "flush fileId"} NONE} test open-12.2 {flush command} { list [catch {flush a b} msg] $msg $errorCode } {1 {wrong # args: should be "flush fileId"} NONE} test open-12.3 {flush command} { list [catch {flush a} msg] $msg $errorCode } {1 {bad file identifier "a"} NONE} test open-12.4 {flush command} { set f [open test3] set x [list [catch {flush $f} msg] \ [string range $msg [string first " " $msg] end] $errorCode] close $f set x } {1 { wasn't opened for writing} NONE} test open-12.5 {flush command} { set f [open test3 w] puts $f "Line 1" puts $f "Line 2" set f2 [open test3] set x {} lappend x [read -nonewline $f2] close $f2 flush $f set f2 [open test3] lappend x [read -nonewline $f2] close $f2 close $f set x } {{} {Line 1 Line 2}} test open-13.1 {I/O to command pipelines} { list [catch {open "| cat < test1 > test3" w} msg] $msg $errorCode } {1 {can't write input to command: standard input was redirected} NONE} test open-13.2 {I/O to command pipelines} { list [catch {open "| echo > test3" r} msg] $msg $errorCode } {1 {can't read output from command: standard output was redirected} NONE} test open-13.3 {I/O to command pipelines} { list [catch {open "| echo > test3" r+} msg] $msg $errorCode } {1 {can't read output from command: standard output was redirected} NONE} test open-13.4 {writing to command pipelines} { exec rm test3 set f [open "| cat | cat > test3" w] puts $f "Line 1" puts $f "Line 2" close $f exec cat test3 } {Line 1 Line 2} test open-13.5 {reading from command pipelines} { set f [open "| cat test2" r] set x [list [gets $f] [gets $f] [gets $f]] close $f set x } {line1 line2 line3} test open-13.6 {both reading and writing from/to command pipelines} { set f [open "| cat -u" r+] puts $f "Line1" flush $f set x [gets $f] close $f set x } {Line1} test open-13.7 {errors in command pipelines} { list [catch {open "|gorp"} msg] [string tolower $msg] \ [string tolower $errorCode] } {1 {couldn't execute "gorp": no such file or directory} {posix enoent {no such file or directory}}} test open-13.8 {errors in command pipelines} { set f [open "|sleep 1" w] exec sleep 3 puts $f output set x [list [catch {flush $f} msg] [concat \ [string range $msg 0 [string first {"} $msg]] \ [string range $msg [string first : $msg] end]] $errorCode] catch {close $f} string tolower $x } {1 {error flushing " : broken pipe} {posix epipe {broken pipe}}} test open-14.1 {POSIX open access modes: RDONLY} { set f [open test1 RDONLY] set x [list [gets $f] [catch {puts $f Test} msg] $msg] close $f # The regsub is needed to avoid false errors if the file # number varies from system to system. regsub {"file[0-9]*"} $x {"file"} x set x } {{Two lines: this one} 1 {"file" wasn't opened for writing}} test open-14.2 {POSIX open access modes: RDONLY} { catch {exec rm -f test3} string tolower [list [catch {open test3 RDONLY} msg] $msg] } {1 {couldn't open "test3": no such file or directory}} test open-14.3 {POSIX open access modes: WRONLY} { catch {exec rm -f test3} string tolower [list [catch {open test3 WRONLY} msg] $msg] } {1 {couldn't open "test3": no such file or directory}} test open-14.4 {POSIX open access modes: WRONLY} { exec echo xyzzy > test3 set f [open test3 WRONLY] puts -nonewline $f "ab" seek $f 0 current set x [list [catch {gets $f} msg] $msg] close $f lappend x [exec cat test3] # The regsub is needed to avoid false errors if the file # number varies from system to system. regsub {"file[0-9]*"} $x {"file"} x set x } {1 {"file" wasn't opened for reading} abzzy} test open-14.5 {POSIX open access modes: RDWR} { catch {exec rm -f test3} string tolower [list [catch {open test3 RDWR} msg] $msg] } {1 {couldn't open "test3": no such file or directory}} test open-14.6 {POSIX open access modes: RDWR} { exec echo xyzzy > test3 set f [open test3 RDWR] puts -nonewline $f "ab" seek $f 0 current set x [gets $f] close $f lappend x [exec cat test3] } {zzy abzzy} test open-14.7 {POSIX open access modes: CREAT} { catch {exec rm -f test3} set f [open test3 {WRONLY CREAT} 0600] file stat test3 stats set x [format "0%o" [expr $stats(mode)&0777]] puts $f "line 1" close $f lappend x [exec cat test3] } {0600 {line 1}} if $doNonPortableTests { test open-14.8 {POSIX open access modes: CREAT} { catch {exec rm -f test3} set f [open test3 {WRONLY CREAT}] close $f file stat test3 stats format "0%o" [expr $stats(mode)&0777] } 0664 } test open-14.9 {POSIX open access modes: CREAT} { exec echo xyzzy > test3 set f [open test3 {WRONLY CREAT}] puts -nonewline $f "ab" close $f exec cat test3 } abzzy test open-14.10 {POSIX open access modes: APPEND} { exec echo xyzzy > test3 set f [open test3 {WRONLY APPEND}] puts $f "new line" seek $f 0 puts $f "abc" close $f exec cat test3 } {xyzzy new line abc} test open-14.11 {POSIX open access modes: EXCL} { exec echo xyzzy > test3 set msg [list [catch {open test3 {WRONLY CREAT EXCL}} msg] $msg] regsub " already " $msg " " msg string tolower $msg } {1 {couldn't open "test3": file exists}} test open-14.12 {POSIX open access modes: EXCL} { catch {exec rm -f test3} set x [catch {set f [open test3 {WRONLY CREAT EXCL}]}] puts $f "A test line" close $f lappend x [exec cat test3] } {0 {A test line}} test open-14.13 {POSIX open access modes: TRUNC} { exec echo xyzzy > test3 set f [open test3 {WRONLY TRUNC}] puts $f abc close $f exec cat test3 } {abc} if $doNonPortableTests { test open-14.14 {POSIX open access modes: NONBLOCK} { catch {exec rm -f test3} set f [open test3 {WRONLY NONBLOCK CREAT}] puts $f "NONBLOCK test" close $f exec cat test3 } {NONBLOCK test} } test open-14.15 {POSIX open access modes: errors} { concat [catch {open test3 "FOO \{BAR BAZ"} msg] $msg\n$errorInfo } "1 unmatched open brace in list unmatched open brace in list while processing open access modes \"FOO {BAR BAZ\" invoked from within \"open test3 \"FOO \\{BAR BAZ\"\"" test open-14.16 {POSIX open access modes: errors} { list [catch {open test3 {FOO BAR BAZ}} msg] $msg } {1 {invalid access mode "FOO": must be RDONLY, WRONLY, RDWR, APPEND, CREAT EXCL, NOCTTY, NONBLOCK, or TRUNC}} test open-14.17 {POSIX open access modes: errors} { list [catch {open test3 {TRUNC CREAT}} msg] $msg } {1 {access mode must include either RDONLY, WRONLY, or RDWR}} catch {exec rm -f test1 test2 test3} concat {} list [catch {read $f 12z} msg] $msg $errorCode] close $f set x } {1 {expected integer but got "12z"} NONE} test open-8.9 {read command} { set f [open test1] set x [list [catch {read $f z}tcl7.4b4/tests/parse.test010044400630510000012000000262740574500242200162120ustar00ousterstaff00002300000001# Commands covered: set (plus basic command syntax) # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # @(#) parse.test 1.28 95/04/18 11:29:40 if {[string compare test [info procs test]] == 1} then {source defs} proc fourArgs {a b c d} { global arg1 arg2 arg3 arg4 set arg1 $a set arg2 $b set arg3 $c set arg4 $d } proc getArgs args { global argv set argv $args } # Basic argument parsing. test parse-1.1 {basic argument parsing} { set arg1 {} fourArgs a b c d list $arg1 $arg2 $arg3 $arg4 } {a b c d} test parse-1.2 {basic argument parsing} { set arg1 {} eval "fourArgs 123\v4\f56\r7890" list $arg1 $arg2 $arg3 $arg4 } {123 4 56 7890} # Quotes. test parse-2.1 {quotes and variable-substitution} { getArgs "a b c" d set argv } {{a b c} d} test parse-2.2 {quotes and variable-substitution} { set a 101 getArgs "a$a b c" set argv } {{a101 b c}} test parse-2.3 {quotes and variable-substitution} { set argv "xy[format xabc]" set argv } {xyxabc} test parse-2.4 {quotes and variable-substitution} { set argv "xy\t" set argv } xy\t test parse-2.5 {quotes and variable-substitution} { set argv "a b c d e f" set argv } a\ b\tc\nd\ e\ f test parse-2.6 {quotes and variable-substitution} { set argv a"bcd"e set argv } {a"bcd"e} # Braces. test parse-3.1 {braces} { getArgs {a b c} d set argv } "{a b c} d" test parse-3.2 {braces} { set a 101 set argv {a$a b c} set b [string index $argv 1] set b } {$} test parse-3.3 {braces} { set argv {a[format xyz] b} string length $argv } 15 test parse-3.4 {braces} { set argv {a\nb\}} string length $argv } 6 test parse-3.5 {braces} { set argv {{{{}}}} set argv } "{{{}}}" test parse-3.6 {braces} { set argv a{{}}b set argv } "a{{}}b" test parse-3.7 {braces} { set a [format "last]"] set a } {last]} # Command substitution. test parse-4.1 {command substitution} { set a [format xyz] set a } xyz test parse-4.2 {command substitution} { set a a[format xyz]b[format q] set a } axyzbq test parse-4.3 {command substitution} { set a a[ set b 22; format %s $b ]b set a } a22b # Variable substitution. test parse-5.1 {variable substitution} { set a 123 set b $a set b } 123 test parse-5.2 {variable substitution} { set a 345 set b x$a.b set b } x345.b test parse-5.3 {variable substitution} { set _123z xx set b $_123z^ set b } xx^ test parse-5.4 {variable substitution} { set a 78 set b a${a}b set b } a78b test parse-5.5 {variable substitution} {catch {$_non_existent_} msg} 1 test parse-5.6 {variable substitution} { catch {$_non_existent_} msg set msg } {can't read "_non_existent_": no such variable} test parse-5.7 {array variable substitution} { catch {unset a} set a(xyz) 123 set b $a(xyz)foo set b } 123foo test parse-5.8 {array variable substitution} { catch {unset a} set "a(x y z)" 123 set b $a(x y z)foo set b } 123foo test parse-5.9 {array variable substitution} { catch {unset a}; catch {unset qqq} set "a(x y z)" qqq set $a([format x]\ y [format z]) foo set qqq } foo test parse-5.10 {array variable substitution} { catch {unset a} list [catch {set b $a(22)} msg] $msg } {1 {can't read "a(22)": no such variable}} test parse-5.11 {array variable substitution} { set b a$! set b } {a$!} test parse-5.12 {array variable substitution} { set b a$() set b } {a$()} catch {unset a} test parse-5.13 {array variable substitution} { catch {unset a} set long {This is a very long variable, long enough to cause storage \ allocation to occur in Tcl_ParseVar. If that storage isn't getting \ freed up correctly, then a core leak will occur when this test is \ run. This text is probably beginning to sound like drivel, but I've \ run out of things to say and I need more characters still.} set a($long) 777 set b $a($long) list $b [array names a] } {777 {{This is a very long variable, long enough to cause storage \ allocation to occur in Tcl_ParseVar. If that storage isn't getting \ freed up correctly, then a core leak will occur when this test is \ run. This text is probably beginning to sound like drivel, but I've \ run out of things to say and I need more characters still.}}} test parse-5.14 {array variable substitution} { catch {unset a}; catch {unset b}; catch {unset a1} set a1(22) foo set a(foo) bar set b $a($a1(22)) set b } bar catch {unset a}; catch {unset a1} # Backslash substitution. set errNum 1 proc bsCheck {char num} { global errNum test parse-6.$errNum {backslash substitution} { scan $char %c value set value } $num set errNum [expr $errNum+1] } bsCheck \b 8 bsCheck \e 101 bsCheck \f 12 bsCheck \n 10 bsCheck \r 13 bsCheck \t 9 bsCheck \v 11 bsCheck \{ 123 bsCheck \} 125 bsCheck \[ 91 bsCheck \] 93 bsCheck \$ 36 bsCheck \ 32 bsCheck \; 59 bsCheck \\ 92 bsCheck \Ca 67 bsCheck \Ma 77 bsCheck \CMa 67 bsCheck \8a 8 bsCheck \14 12 bsCheck \141 97 bsCheck \340 224 bsCheck b\0 98 bsCheck \x 120 bsCheck \xa 10 bsCheck \x41 65 bsCheck \x541 65 test parse-6.1 {backslash substitution} { set a "\a\c\n\]\}" string length $a } 5 test parse-6.2 {backslash substitution} { set a {\a\c\n\]\}} string length $a } 10 test parse-6.3 {backslash substitution} { set a "abc\ def" set a } {abc def} test parse-6.4 {backslash substitution} { set a {abc\ def} set a } {abc def} test parse-6.5 {backslash substitution} { set msg {} set a xxx set error [catch {if {24 < \ 35} {set a 22} {set \ a 33}} msg] list $error $msg $a } {0 22 22} test parse-6.6 {backslash substitution} { eval "concat abc\\" } "abc\\" test parse-6.7 {backslash substitution} { eval "concat \\\na" } "a" test parse-6.8 {backslash substitution} { eval "concat x\\\n \na" } "x a" test parse-6.9 {backslash substitution} { eval "concat \\x" } "x" test parse-6.10 {backslash substitution} { eval "list a b\\\nc d" } {a b c d} test parse-6.11 {backslash substitution} { eval "list a \"b c\"\\\nd e" } {a {b c} d e} # Semi-colon. test parse-7.1 {semi-colons} { set b 0 getArgs a;set b 2 set argv } a test parse-7.2 {semi-colons} { set b 0 getArgs a;set b 2 set b } 2 test parse-7.3 {semi-colons} { getArgs a b ; set b 1 set argv } {a b} test parse-7.4 {semi-colons} { getArgs a b ; set b 1 set b } 1 # The following checks are to ensure that the interpreter's result # gets re-initialized by Tcl_Eval in all the right places. test parse-8.1 {result initialization} {concat abc} abc test parse-8.2 {result initialization} {concat abc; proc foo {} {}} {} test parse-8.3 {result initialization} {concat abc; proc foo {} $a} {} test parse-8.4 {result initialization} {proc foo {} [concat abc]} {} test parse-8.5 {result initialization} {concat abc; } abc test parse-8.6 {result initialization} { eval { concat abc }} abc test parse-8.7 {result initialization} {} {} test parse-8.8 {result initialization} {concat abc; ; ;} abc # Syntax errors. test parse-9.1 {syntax errors} {catch "set a \{bcd" msg} 1 test parse-9.2 {syntax errors} { catch "set a \{bcd" msg set msg } {missing close-brace} test parse-9.3 {syntax errors} {catch {set a "bcd} msg} 1 test parse-9.4 {syntax errors} { catch {set a "bcd} msg set msg } {missing "} test parse-9.5 {syntax errors} {catch {set a "bcd"xy} msg} 1 test parse-9.6 {syntax errors} { catch {set a "bcd"xy} msg set msg } {extra characters after close-quote} test parse-9.7 {syntax errors} {catch "set a {bcd}xy" msg} 1 test parse-9.8 {syntax errors} { catch "set a {bcd}xy" msg set msg } {extra characters after close-brace} test parse-9.9 {syntax errors} {catch {set a [format abc} msg} 1 test parse-9.10 {syntax errors} { catch {set a [format abc} msg set msg } {missing close-bracket} test parse-9.11 {syntax errors} {catch gorp-a-lot msg} 1 test parse-9.12 {syntax errors} { catch gorp-a-lot msg set msg } {invalid command name "gorp-a-lot"} test parse-9.13 {syntax errors} { set a [concat {a}\ {b}] set a } {a b} # Long values (stressing storage management) set a {1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH} test parse-10.1 {long values} { string length $a } 214 test parse-10.2 {long values} { llength $a } 43 test parse-1a1.3 {long values} { set b "1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH" set b } $a test parse-10.3 {long values} { set b "$a" set b } $a test parse-10.4 {long values} { set b [set a] set b } $a test parse-10.5 {long values} { set b [concat 1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH] string length $b } 214 test parse-10.6 {long values} { set b [concat 1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH] llength $b } 43 test parse-10.7 {long values} { set b } $a test parse-10.8 {long values} { set a [concat 0000 1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH IIII JJJJ KKKK LLLL MMMM NNNN OOOO PPPP QQQQ RRRR SSSS TTTT UUUU VVVV WWWW XXXX YYYY ZZZZ] llength $a } 62 set i 0 foreach j [concat 0000 1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH IIII JJJJ KKKK LLLL MMMM NNNN OOOO PPPP QQQQ RRRR SSSS TTTT UUUU VVVV WWWW XXXX YYYY ZZZZ] { set test [string index 0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ $i] set test $test$test$test$test set i [expr $i+1] test parse-10.9 {long values} { set j } $test } test parse-10.10 {test buffer overflow in backslashes in braces} { expr {"a" == {xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyy\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101}} } 0 tcl7.4b4/tests/pid.test010044400630510000012000000024550575722336600156660ustar00ousterstaff00002300000001# Commands covered: pid # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # @(#) pid.test 1.3 95/05/19 16:17:10 if {[string compare test [info procs test]] == 1} then {source defs} catch {exec rm -f test1} test pid-1.1 {pid command} { regexp {^[0-9]+$} [pid] } 1 test pid-1.2 {pid command} { set f [open {| echo foo | cat > /dev/null} w] set pids [pid $f] close $f list [llength $pids] [regexp {^[0-9]+$} [lindex $pids 0]] \ [regexp {^[0-9]+$} [lindex $pids 1]] \ [expr {[lindex $pids 0] == [lindex $pids 1]}] } {2 1 1 0} test pid-1.3 {pid command} { set f [open test1 w] set pids [pid $f] close $f set pids } {} test pid-1.4 {pid command} { list [catch {pid a b} msg] $msg } {1 {wrong # args: should be "pid ?fileId?"}} test pid-1.5 {pid command} { list [catch {pid gorp} msg] $msg } {1 {bad file identifier "gorp"}} catch {exec rm -f test1} concat {} tcl7.4b4/tests/proc.test010044400630510000012000000316070567470012300160430ustar00ousterstaff00002300000001# Commands covered: proc, return, global # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # @(#) proc.test 1.18 94/12/17 16:20:19 if {[string compare test [info procs test]] == 1} then {source defs} proc tproc {} {return a; return b} test proc-1.1 {simple procedure call and return} {tproc} a proc tproc x { set x [expr $x+1] return $x } test proc-1.2 {simple procedure call and return} {tproc 2} 3 test proc-1.3 {simple procedure call and return} { proc tproc {} {return foo} } {} test proc-1.4 {simple procedure call and return} { proc tproc {} {return} tproc } {} test proc-2.1 {local and global variables} { proc tproc x { set x [expr $x+1] return $x } set x 42 list [tproc 6] $x } {7 42} test proc-2.2 {local and global variables} { proc tproc x { set y [expr $x+1] return $y } set y 18 list [tproc 6] $y } {7 18} test proc-2.3 {local and global variables} { proc tproc x { global y set y [expr $x+1] return $y } set y 189 list [tproc 6] $y } {7 7} test proc-2.4 {local and global variables} { proc tproc x { global y return [expr $x+$y] } set y 189 list [tproc 6] $y } {195 189} catch {unset _undefined_} test proc-2.5 {local and global variables} { proc tproc x { global _undefined_ return $_undefined_ } list [catch {tproc xxx} msg] $msg } {1 {can't read "_undefined_": no such variable}} test proc-2.6 {local and global variables} { set a 114 set b 115 global a b list $a $b } {114 115} proc do {cmd} {eval $cmd} test proc-3.1 {local and global arrays} { catch {unset a} set a(0) 22 list [catch {do {global a; set a(0)}} msg] $msg } {0 22} test proc-3.2 {local and global arrays} { catch {unset a} set a(x) 22 list [catch {do {global a; set a(x) newValue}} msg] $msg $a(x) } {0 newValue newValue} test proc-3.3 {local and global arrays} { catch {unset a} set a(x) 22 set a(y) 33 list [catch {do {global a; unset a(y)}; array names a} msg] $msg } {0 x} test proc-3.4 {local and global arrays} { catch {unset a} set a(x) 22 set a(y) 33 list [catch {do {global a; unset a; info exists a}} msg] $msg \ [info exists a] } {0 0 0} test proc-3.5 {local and global arrays} { catch {unset a} set a(x) 22 set a(y) 33 list [catch {do {global a; unset a(y); array names a}} msg] $msg } {0 x} catch {unset a} test proc-3.6 {local and global arrays} { catch {unset a} set a(x) 22 set a(y) 33 do {global a; do {global a; unset a}; set a(z) 22} list [catch {array names a} msg] $msg } {0 z} test proc-3.7 {local and global arrays} { proc t1 {args} {global info; set info 1} catch {unset a} set info {} do {global a; trace var a(1) w t1} set a(1) 44 set info } 1 test proc-3.8 {local and global arrays} { proc t1 {args} {global info; set info 1} catch {unset a} trace var a(1) w t1 set info {} do {global a; trace vdelete a(1) w t1} set a(1) 44 set info } {} test proc-3.9 {local and global arrays} { proc t1 {args} {global info; set info 1} catch {unset a} trace var a(1) w t1 do {global a; trace vinfo a(1)} } {{w t1}} catch {unset a} test proc-3.1 {arguments and defaults} { proc tproc {x y z} { return [list $x $y $z] } tproc 11 12 13 } {11 12 13} test proc-3.2 {arguments and defaults} { proc tproc {x y z} { return [list $x $y $z] } list [catch {tproc 11 12} msg] $msg } {1 {no value given for parameter "z" to "tproc"}} test proc-3.3 {arguments and defaults} { proc tproc {x y z} { return [list $x $y $z] } list [catch {tproc 11 12 13 14} msg] $msg } {1 {called "tproc" with too many arguments}} test proc-3.4 {arguments and defaults} { proc tproc {x {y y-default} {z z-default}} { return [list $x $y $z] } tproc 11 12 13 } {11 12 13} test proc-3.5 {arguments and defaults} { proc tproc {x {y y-default} {z z-default}} { return [list $x $y $z] } tproc 11 12 } {11 12 z-default} test proc-3.6 {arguments and defaults} { proc tproc {x {y y-default} {z z-default}} { return [list $x $y $z] } tproc 11 } {11 y-default z-default} test proc-3.7 {arguments and defaults} { proc tproc {x {y y-default} {z z-default}} { return [list $x $y $z] } list [catch {tproc} msg] $msg } {1 {no value given for parameter "x" to "tproc"}} test proc-3.8 {arguments and defaults} { list [catch { proc tproc {x {y y-default} z} { return [list $x $y $z] } tproc 2 3 } msg] $msg } {1 {no value given for parameter "z" to "tproc"}} test proc-3.9 {arguments and defaults} { proc tproc {x {y y-default} args} { return [list $x $y $args] } tproc 2 3 4 5 } {2 3 {4 5}} test proc-3.10 {arguments and defaults} { proc tproc {x {y y-default} args} { return [list $x $y $args] } tproc 2 3 } {2 3 {}} test proc-3.11 {arguments and defaults} { proc tproc {x {y y-default} args} { return [list $x $y $args] } tproc 2 } {2 y-default {}} test proc-3.12 {arguments and defaults} { proc tproc {x {y y-default} args} { return [list $x $y $args] } list [catch {tproc} msg] $msg } {1 {no value given for parameter "x" to "tproc"}} test proc-4.1 {variable numbers of arguments} { proc tproc args {return $args} tproc } {} test proc-4.2 {variable numbers of arguments} { proc tproc args {return $args} tproc 1 2 3 4 5 6 7 8 } {1 2 3 4 5 6 7 8} test proc-4.3 {variable numbers of arguments} { proc tproc args {return $args} tproc 1 {2 3} {4 {5 6} {{{7}}}} 8 } {1 {2 3} {4 {5 6} {{{7}}}} 8} test proc-4.4 {variable numbers of arguments} { proc tproc {x y args} {return $args} tproc 1 2 3 4 5 6 7 } {3 4 5 6 7} test proc-4.5 {variable numbers of arguments} { proc tproc {x y args} {return $args} tproc 1 2 } {} test proc-4.6 {variable numbers of arguments} { proc tproc {x missing args} {return $args} list [catch {tproc 1} msg] $msg } {1 {no value given for parameter "missing" to "tproc"}} test proc-5.1 {error conditions} { list [catch {proc} msg] $msg } {1 {wrong # args: should be "proc name args body"}} test proc-5.2 {error conditions} { list [catch {proc tproc b} msg] $msg } {1 {wrong # args: should be "proc name args body"}} test proc-5.3 {error conditions} { list [catch {proc tproc b c d e} msg] $msg } {1 {wrong # args: should be "proc name args body"}} test proc-5.4 {error conditions} { list [catch {proc tproc \{xyz {return foo}} msg] $msg } {1 {unmatched open brace in list}} test proc-5.5 {error conditions} { list [catch {proc tproc {{} y} {return foo}} msg] $msg } {1 {procedure "tproc" has argument with no name}} test proc-5.6 {error conditions} { list [catch {proc tproc {{} y} {return foo}} msg] $msg } {1 {procedure "tproc" has argument with no name}} test proc-5.7 {error conditions} { list [catch {proc tproc {{x 1 2} y} {return foo}} msg] $msg } {1 {too many fields in argument specifier "x 1 2"}} test proc-5.8 {error conditions} { catch {return} } 2 test proc-5.9 {error conditions} { list [catch {global} msg] $msg } {1 {wrong # args: should be "global varName ?varName ...?"}} proc tproc {} { set a 22 global a } test proc-5.10 {error conditions} { list [catch {tproc} msg] $msg } {1 {variable "a" already exists}} test proc-5.11 {error conditions} { catch {rename tproc {}} catch { proc tproc {x {} z} {return foo} } list [catch {tproc 1} msg] $msg } {1 {invalid command name "tproc"}} test proc-5.12 {error conditions} { proc tproc {} { set a 22 error "error in procedure" return } list [catch tproc msg] $msg } {1 {error in procedure}} test proc-5.13 {error conditions} { proc tproc {} { set a 22 error "error in procedure" return } catch tproc msg set errorInfo } {error in procedure while executing "error "error in procedure"" (procedure "tproc" line 3) invoked from within "tproc"} test proc-5.14 {error conditions} { proc tproc {} { set a 22 break return } catch tproc msg set errorInfo } {invoked "break" outside of a loop while executing "tproc"} test proc-5.15 {error conditions} { proc tproc {} { set a 22 continue return } catch tproc msg set errorInfo } {invoked "continue" outside of a loop while executing "tproc"} test proc-5.16 {error conditions} { proc foo args { global fooMsg set fooMsg "foo was called: $args" } proc tproc {} { set x 44 trace var x u foo while {$x < 100} { error "Nested error" } } set fooMsg "foo not called" list [catch tproc msg] $msg $errorInfo $fooMsg } {1 {Nested error} {Nested error while executing "error "Nested error"" ("while" body line 2) invoked from within "while {$x < 100} { error "Nested error" }" (procedure "tproc" line 4) invoked from within "tproc"} {foo was called: x {} u}} # The tests below will really only be useful when run under Purify or # some other system that can detect accesses to freed memory... test proc-6.1 {procedure that redefines itself} { proc tproc {} { proc tproc {} { return 44 } return 45 } tproc } 45 test proc-6.2 {procedure that deletes itself} { proc tproc {} { rename tproc {} return 45 } tproc } 45 proc tproc code { return -code $code abc } test proc-7.1 {return with special completion code} { list [catch {tproc ok} msg] $msg } {0 abc} test proc-7.2 {return with special completion code} { list [catch {tproc error} msg] $msg $errorInfo $errorCode } {1 abc {abc while executing "tproc error"} NONE} test proc-7.3 {return with special completion code} { list [catch {tproc return} msg] $msg } {2 abc} test proc-7.4 {return with special completion code} { list [catch {tproc break} msg] $msg } {3 abc} test proc-7.5 {return with special completion code} { list [catch {tproc continue} msg] $msg } {4 abc} test proc-7.6 {return with special completion code} { list [catch {tproc -14} msg] $msg } {-14 abc} test proc-7.7 {return with special completion code} { list [catch {tproc gorp} msg] $msg } {1 {bad completion code "gorp": must be ok, error, return, break, continue, or an integer}} test proc-7.8 {return with special completion code} { list [catch {tproc 10b} msg] $msg } {1 {bad completion code "10b": must be ok, error, return, break, continue, or an integer}} test proc-7.9 {return with special completion code} { proc tproc2 {} { tproc return } list [catch tproc2 msg] $msg } {0 abc} test proc-7.10 {return with special completion code} { proc tproc2 {} { return -code error } list [catch tproc2 msg] $msg } {1 {}} test proc-7.11 {return with special completion code} { proc tproc2 {} { global errorCode errorInfo catch {open _bad_file_name r} msg return -code error -errorinfo $errorInfo -errorcode $errorCode $msg } string tolower [list [catch tproc2 msg] $msg $errorInfo $errorCode] } {1 {couldn't open "_bad_file_name": no such file or directory} {couldn't open "_bad_file_name": no such file or directory while executing "open _bad_file_name r" invoked from within "tproc2"} {posix enoent {no such file or directory}}} test proc-7.12 {return with special completion code} { proc tproc2 {} { global errorCode errorInfo catch {open _bad_file_name r} msg return -code error -errorcode $errorCode $msg } string tolower [list [catch tproc2 msg] $msg $errorInfo $errorCode] } {1 {couldn't open "_bad_file_name": no such file or directory} {couldn't open "_bad_file_name": no such file or directory while executing "tproc2"} {posix enoent {no such file or directory}}} test proc-7.13 {return with special completion code} { proc tproc2 {} { global errorCode errorInfo catch {open _bad_file_name r} msg return -code error -errorinfo $errorInfo $msg } string tolower [list [catch tproc2 msg] $msg $errorInfo $errorCode] } {1 {couldn't open "_bad_file_name": no such file or directory} {couldn't open "_bad_file_name": no such file or directory while executing "open _bad_file_name r" invoked from within "tproc2"} none} test proc-7.14 {return with special completion code} { proc tproc2 {} { global errorCode errorInfo catch {open _bad_file_name r} msg return -code error $msg } string tolower [list [catch tproc2 msg] $msg $errorInfo $errorCode] } {1 {couldn't open "_bad_file_name": no such file or directory} {couldn't open "_bad_file_name": no such file or directory while executing "tproc2"} none} test proc-7.14 {return with special completion code} { list [catch {return -badOption foo message} msg] $msg } {1 {bad option "-badOption: must be -code, -errorcode, or -errorinfo}} { proc tproc {x {y y-default} {z z-default}} { return [list $x $y $z] } tproc 11 } {11 y-default z-default}tcl7.4b4/tests/regexp.test010044400630510000012000000253150567470012300163710ustar00ousterstaff00002300000001# Commands covered: regexp, regsub # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # @(#) regexp.test 1.18 94/12/17 16:20:20 if {[string compare test [info procs test]] == 1} then {source defs} catch {unset foo} test regexp-1.1 {basic regexp operation} { regexp ab*c abbbc } 1 test regexp-1.2 {basic regexp operation} { regexp ab*c ac } 1 test regexp-1.3 {basic regexp operation} { regexp ab*c ab } 0 test regexp-1.4 {basic regexp operation} { regexp -- -gorp abc-gorpxxx } 1 test regexp-2.1 {getting substrings back from regexp} { set foo {} list [regexp ab*c abbbbc foo] $foo } {1 abbbbc} test regexp-2.2 {getting substrings back from regexp} { set foo {} set f2 {} list [regexp a(b*)c abbbbc foo f2] $foo $f2 } {1 abbbbc bbbb} test regexp-2.3 {getting substrings back from regexp} { set foo {} set f2 {} list [regexp a(b*)(c) abbbbc foo f2] $foo $f2 } {1 abbbbc bbbb} test regexp-2.4 {getting substrings back from regexp} { set foo {} set f2 {} set f3 {} list [regexp a(b*)(c) abbbbc foo f2 f3] $foo $f2 $f3 } {1 abbbbc bbbb c} test regexp-2.5 {getting substrings back from regexp} { set foo {}; set f1 {}; set f2 {}; set f3 {}; set f4 {}; set f5 {}; set f6 {}; set f7 {}; set f8 {}; set f9 {} list [regexp (1*)(2*)(3*)(4*)(5*)(6*)(7*)(8*)(9*) 12223345556789999 \ foo f1 f2 f3 f4 f5 f6 f7 f8 f9] $foo $f1 $f2 $f3 $f4 $f5 \ $f6 $f7 $f8 $f9 } {1 12223345556789999 1 222 33 4 555 6 7 8 9999} test regexp-2.6 {getting substrings back from regexp} { set foo 2; set f2 2; set f3 2; set f4 2 list [regexp (a)(b)? xay foo f2 f3 f4] $foo $f2 $f3 $f4 } {1 a a {} {}} test regexp-2.7 {getting substrings back from regexp} { set foo 1; set f2 1; set f3 1; set f4 1 list [regexp (a)(b)?(c) xacy foo f2 f3 f4] $foo $f2 $f3 $f4 } {1 ac a {} c} test regexp-3.1 {-indices option to regexp} { set foo {} list [regexp -indices ab*c abbbbc foo] $foo } {1 {0 5}} test regexp-3.2 {-indices option to regexp} { set foo {} set f2 {} list [regexp -indices a(b*)c abbbbc foo f2] $foo $f2 } {1 {0 5} {1 4}} test regexp-3.3 {-indices option to regexp} { set foo {} set f2 {} list [regexp -indices a(b*)(c) abbbbc foo f2] $foo $f2 } {1 {0 5} {1 4}} test regexp-3.4 {-indices option to regexp} { set foo {} set f2 {} set f3 {} list [regexp -indices a(b*)(c) abbbbc foo f2 f3] $foo $f2 $f3 } {1 {0 5} {1 4} {5 5}} test regexp-3.5 {-indices option to regexp} { set foo {}; set f1 {}; set f2 {}; set f3 {}; set f4 {}; set f5 {}; set f6 {}; set f7 {}; set f8 {}; set f9 {} list [regexp -indices (1*)(2*)(3*)(4*)(5*)(6*)(7*)(8*)(9*) \ 12223345556789999 \ foo f1 f2 f3 f4 f5 f6 f7 f8 f9] $foo $f1 $f2 $f3 $f4 $f5 \ $f6 $f7 $f8 $f9 } {1 {0 16} {0 0} {1 3} {4 5} {6 6} {7 9} {10 10} {11 11} {12 12} {13 16}} test regexp-3.6 {getting substrings back from regexp} { set foo 2; set f2 2; set f3 2; set f4 2 list [regexp -indices (a)(b)? xay foo f2 f3 f4] $foo $f2 $f3 $f4 } {1 {1 1} {1 1} {-1 -1} {-1 -1}} test regexp-3.7 {getting substrings back from regexp} { set foo 1; set f2 1; set f3 1; set f4 1 list [regexp -indices (a)(b)?(c) xacy foo f2 f3 f4] $foo $f2 $f3 $f4 } {1 {1 2} {1 1} {-1 -1} {2 2}} test regexp-4.1 {-nocase option to regexp} { regexp -nocase foo abcFOo } 1 test regexp-4.2 {-nocase option to regexp} { set f1 22 set f2 33 set f3 44 list [regexp -nocase {a(b*)([xy]*)z} aBbbxYXxxZ22 f1 f2 f3] $f1 $f2 $f3 } {1 aBbbxYXxxZ Bbb xYXxx} test regexp-4.3 {-nocase option to regexp} { regexp -nocase FOo abcFOo } 1 set x abcdefghijklmnopqrstuvwxyz1234567890 set x $x$x$x$x$x$x$x$x$x$x$x$x test regexp-4.4 {case conversion in regsub} { list [regexp -nocase $x $x foo] $foo } "1 $x" unset x test regexp-5.1 {exercise cache of compiled expressions} { regexp .*a b regexp .*b c regexp .*c d regexp .*d e regexp .*e f regexp .*a bbba } 1 test regexp-5.2 {exercise cache of compiled expressions} { regexp .*a b regexp .*b c regexp .*c d regexp .*d e regexp .*e f regexp .*b xxxb } 1 test regexp-5.3 {exercise cache of compiled expressions} { regexp .*a b regexp .*b c regexp .*c d regexp .*d e regexp .*e f regexp .*c yyyc } 1 test regexp-5.4 {exercise cache of compiled expressions} { regexp .*a b regexp .*b c regexp .*c d regexp .*d e regexp .*e f regexp .*d 1d } 1 test regexp-5.5 {exercise cache of compiled expressions} { regexp .*a b regexp .*b c regexp .*c d regexp .*d e regexp .*e f regexp .*e xe } 1 test regexp-6.1 {regexp errors} { list [catch {regexp a} msg] $msg } {1 {wrong # args: should be "regexp ?switches? exp string ?matchVar? ?subMatchVar subMatchVar ...?"}} test regexp-6.2 {regexp errors} { list [catch {regexp -nocase a} msg] $msg } {1 {wrong # args: should be "regexp ?switches? exp string ?matchVar? ?subMatchVar subMatchVar ...?"}} test regexp-6.3 {regexp errors} { list [catch {regexp -gorp a} msg] $msg } {1 {bad switch "-gorp": must be -indices, -nocase, or --}} test regexp-6.4 {regexp errors} { list [catch {regexp a( b} msg] $msg } {1 {couldn't compile regular expression pattern: unmatched ()}} test regexp-6.5 {regexp errors} { list [catch {regexp a( b} msg] $msg } {1 {couldn't compile regular expression pattern: unmatched ()}} test regexp-6.6 {regexp errors} { list [catch {regexp a a f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1} msg] $msg } {0 1} test regexp-6.7 {regexp errors} { list [catch {regexp (x)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.) xyzzy} msg] $msg } {1 {couldn't compile regular expression pattern: too many ()}} test regexp-6.8 {regexp errors} { set f1 44 list [catch {regexp abc abc f1(f2)} msg] $msg } {1 {couldn't set variable "f1(f2)"}} test regexp-7.1 {basic regsub operation} { list [regsub aa+ xaxaaaxaa 111&222 foo] $foo } {1 xax111aaa222xaa} test regexp-7.2 {basic regsub operation} { list [regsub aa+ aaaxaa &111 foo] $foo } {1 aaa111xaa} test regexp-7.3 {basic regsub operation} { list [regsub aa+ xaxaaa 111& foo] $foo } {1 xax111aaa} test regexp-7.4 {basic regsub operation} { list [regsub aa+ aaa 11&2&333 foo] $foo } {1 11aaa2aaa333} test regexp-7.5 {basic regsub operation} { list [regsub aa+ xaxaaaxaa &2&333 foo] $foo } {1 xaxaaa2aaa333xaa} test regexp-7.6 {basic regsub operation} { list [regsub aa+ xaxaaaxaa 1&22& foo] $foo } {1 xax1aaa22aaaxaa} test regexp-7.7 {basic regsub operation} { list [regsub a(a+) xaxaaaxaa {1\122\1} foo] $foo } {1 xax1aa22aaxaa} test regexp-7.8 {basic regsub operation} { list [regsub a(a+) xaxaaaxaa {1\\\122\1} foo] $foo } "1 {xax1\\aa22aaxaa}" test regexp-7.9 {basic regsub operation} { list [regsub a(a+) xaxaaaxaa {1\\122\1} foo] $foo } "1 {xax1\\122aaxaa}" test regexp-7.10 {basic regsub operation} { list [regsub a(a+) xaxaaaxaa {1\\&\1} foo] $foo } "1 {xax1\\aaaaaxaa}" test regexp-7.11 {basic regsub operation} { list [regsub a(a+) xaxaaaxaa {1\&\1} foo] $foo } {1 xax1&aaxaa} test regexp-7.12 {basic regsub operation} { list [regsub a(a+) xaxaaaxaa {\1\1\1\1&&} foo] $foo } {1 xaxaaaaaaaaaaaaaaxaa} test regexp-7.13 {basic regsub operation} { set foo xxx list [regsub abc xyz 111 foo] $foo } {0 xyz} test regexp-7.14 {basic regsub operation} { set foo xxx list [regsub ^ xyz "111 " foo] $foo } {1 {111 xyz}} test regexp-7.15 {basic regsub operation} { set foo xxx list [regsub -- -foo abc-foodef "111 " foo] $foo } {1 {abc111 def}} test regexp-7.16 {basic regsub operation} { set foo xxx list [regsub x "" y foo] $foo } {0 {}} test regexp-8.1 {case conversion in regsub} { list [regsub -nocase a(a+) xaAAaAAay & foo] $foo } {1 xaAAaAAay} test regexp-8.2 {case conversion in regsub} { list [regsub -nocase a(a+) xaAAaAAay & foo] $foo } {1 xaAAaAAay} test regexp-8.3 {case conversion in regsub} { set foo 123 list [regsub a(a+) xaAAaAAay & foo] $foo } {0 xaAAaAAay} test regexp-8.4 {case conversion in regsub} { set foo 123 list [regsub -nocase a CaDE b foo] $foo } {1 CbDE} test regexp-8.5 {case conversion in regsub} { set foo 123 list [regsub -nocase XYZ CxYzD b foo] $foo } {1 CbD} test regexp-8.6 {case conversion in regsub} { set x abcdefghijklmnopqrstuvwxyz1234567890 set x $x$x$x$x$x$x$x$x$x$x$x$x set foo 123 list [regsub -nocase $x $x b foo] $foo } {1 b} test regexp-9.1 {-all option to regsub} { set foo 86 list [regsub -all x+ axxxbxxcxdx |&| foo] $foo } {4 a|xxx|b|xx|c|x|d|x|} test regexp-9.2 {-all option to regsub} { set foo 86 list [regsub -nocase -all x+ aXxXbxxcXdx |&| foo] $foo } {4 a|XxX|b|xx|c|X|d|x|} test regexp-9.3 {-all option to regsub} { set foo 86 list [regsub x+ axxxbxxcxdx |&| foo] $foo } {1 a|xxx|bxxcxdx} test regexp-9.4 {-all option to regsub} { set foo 86 list [regsub -all bc axxxbxxcxdx |&| foo] $foo } {0 axxxbxxcxdx} test regexp-9.5 {-all option to regsub} { set foo xxx list [regsub -all node "node node more" yy foo] $foo } {2 {yy yy more}} test regexp-9.6 {-all option to regsub} { set foo xxx list [regsub -all ^ xxx 123 foo] $foo } {1 123xxx} test regexp-10.1 {regsub errors} { list [catch {regsub a b c} msg] $msg } {1 {wrong # args: should be "regsub ?switches? exp string subSpec varName"}} test regexp-10.2 {regsub errors} { list [catch {regsub -nocase a b c} msg] $msg } {1 {wrong # args: should be "regsub ?switches? exp string subSpec varName"}} test regexp-10.3 {regsub errors} { list [catch {regsub -nocase -all a b c} msg] $msg } {1 {wrong # args: should be "regsub ?switches? exp string subSpec varName"}} test regexp-10.4 {regsub errors} { list [catch {regsub a b c d e f} msg] $msg } {1 {wrong # args: should be "regsub ?switches? exp string subSpec varName"}} test regexp-10.5 {regsub errors} { list [catch {regsub -gorp a b c} msg] $msg } {1 {bad switch "-gorp": must be -all, -nocase, or --}} test regexp-10.6 {regsub errors} { list [catch {regsub -nocase a( b c d} msg] $msg } {1 {couldn't compile regular expression pattern: unmatched ()}} test regexp-10.7 {regsub errors} { list [catch {regsub -nocase aaa aaa xxx f1(f2)} msg] $msg } {1 {couldn't set variable "f1(f2)"}} tcl7.4b4/tests/rename.test010044400630510000012000000047540567470012300163520ustar00ousterstaff00002300000001# Commands covered: rename # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # @(#) rename.test 1.8 94/12/17 16:20:21 if {[string compare test [info procs test]] == 1} then {source defs} # Must eliminate the "unknown" command while the test is running, # especially if the test is being run in a program with its # own special-purpose unknown command. catch {rename unknown unknown.old} catch {rename r2 {}} proc r1 {} {return "procedure r1"} rename r1 r2 test rename-1.1 {simple renaming} { r2 } {procedure r1} test rename-1.2 {simple renaming} { list [catch r1 msg] $msg } {1 {invalid command name "r1"}} rename r2 {} test rename-1.3 {simple renaming} { list [catch r2 msg] $msg } {1 {invalid command name "r2"}} # The test below is tricky because it renames a built-in command. # It's possible that the test procedure uses this command, so must # restore the command before calling test again. rename list l.new set a [catch list msg1] set b [l.new a b c] rename l.new list set c [catch l.new msg2] set d [list 111 222] test 2.1 {renaming built-in command} { list $a $msg1 $b $c $msg2 $d } {1 {invalid command name "list"} {a b c} 1 {invalid command name "l.new"} {111 222}} test rename-3.1 {error conditions} { list [catch {rename r1} msg] $msg $errorCode } {1 {wrong # args: should be "rename oldName newName"} NONE} test rename-3.2 {error conditions} { list [catch {rename r1 r2 r3} msg] $msg $errorCode } {1 {wrong # args: should be "rename oldName newName"} NONE} test rename-3.3 {error conditions} { proc r1 {} {} proc r2 {} {} list [catch {rename r1 r2} msg] $msg } {1 {can't rename to "r2": command already exists}} test rename-3.4 {error conditions} { catch {rename r1 {}} catch {rename r2 {}} list [catch {rename r1 r2} msg] $msg } {1 {can't rename "r1": command doesn't exist}} test rename-3.5 {error conditions} { catch {rename _non_existent_command {}} list [catch {rename _non_existent_command {}} msg] $msg } {1 {can't delete "_non_existent_command": command doesn't exist}} catch {rename unknown {}} catch {rename unknown.old unknown} concat tcl7.4b4/tests/scan.test010044400630510000012000000226310572223406500160220ustar00ousterstaff00002300000001# Commands covered: scan # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1994 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # @(#) scan.test 1.21 95/02/20 16:47:50 if {[string compare test [info procs test]] == 1} then {source defs} test scan-1.1 {integer scanning} { set a {}; set b {}; set c {}; set d {} list [scan "-20 1476 \n33 0" "%d %d %d %d" a b c d] $a $b $c $d } {4 -20 1476 33 0} test scan-1.2 {integer scanning} { set a {}; set b {}; set c {} list [scan "-45 16 7890 +10" "%2d %*d %10d %d" a b c] $a $b $c } {3 -4 16 7890} test scan-1.3 {integer scanning} { set a {}; set b {}; set c {}; set d {} list [scan "-45 16 +10 987" "%ld %d %ld %d" a b c d] $a $b $c $d } {4 -45 16 10 987} test scan-1.4 {integer scanning} { set a {}; set b {}; set c {}; set d {} list [scan "14 1ab 62 10" "%d %x %lo %x" a b c d] $a $b $c $d } {4 14 427 50 16} test scan-1.5 {integer scanning} { set a {}; set b {}; set c {}; set d {} list [scan "12345670 1234567890ab cdefg" "%o %o %x %lx" a b c d] \ $a $b $c $d } {4 2739128 342391 561323 52719} test scan-1.6 {integer scanning} { set a {}; set b {}; set c {}; set d {} list [scan "ab123-24642" "%2x %3x %3o %2o" a b c d] $a $b $c $d } {4 171 291 -20 52} test scan-1.7 {integer scanning} { set a {}; set b {} list [scan "1234567 234 567 " "%*3x %x %*o %4o" a b] $a $b } {2 17767 375} test scan-1.8 {integer scanning} { set a {}; set b {} list [scan "a 1234" "%d %d" a b] $a $b } {0 {} {}} test scan-1.9 {integer scanning} { set a {}; set b {}; set c {}; set d {}; list [scan "12345678" "%2d %2d %2ld %2d" a b c d] $a $b $c $d } {4 12 34 56 78} test scan-1.10 {integer scanning} { set a {}; set b {}; set c {}; set d {} list [scan "1 2 " "%hd %d %d %d" a b c d] $a $b $c $d } {2 1 2 {} {}} if $doNonPortableTests { test scan-1.11 {integer scanning} { set a {}; set b {}; list [scan "4294967280 4294967280" "%u %d" a b] $a $b } {2 4294967280 -16} } test scan-2.1 {floating-point scanning} { set a {}; set b {}; set c {}; set d {} list [scan "2.1 -3.0e8 .99962 a" "%f%g%e%f" a b c d] $a $b $c $d } {3 2.1 -3e+08 0.99962 {}} test scan-2.2 {floating-point scanning} { set a {}; set b {}; set c {}; set d {} list [scan "-1.2345 +8.2 9" "%3e %3lf %f %f" a b c d] $a $b $c $d } {4 -1.0 234.0 5.0 8.2} test scan-2.3 {floating-point scanning} { set a {}; set b {}; set c {} list [scan "1e00004 332E-4 3e+4" "%Lf %*2e %f %f" a b c] $a $c } {3 10000.0 30000.0} if $doNonPortableTests { test scan-2.4 {floating-point scanning} { set a {}; set b {}; set c {} list [scan "1. 47.6 2.e2 3.e-" "%f %*f %f %f" a b c] $a $b $c } {3 1.0 200.0 3.0} } test scan-2.5 {floating-point scanning} { set a {}; set b {}; set c {}; set d {} list [scan "4.6 99999.7 876.43e-1 118" "%f %f %f %e" a b c d] $a $b $c $d } {4 4.6 99999.7 87.643 118.0} test scan-2.6 {floating-point scanning} { set a {}; set b {}; set c {}; set d {} list [scan "1.2345 697.0e-3 124 .00005" "%f %e %f %e" a b c d] $a $b $c $d } {4 1.2345 0.697 124.0 5e-05} test scan-2.7 {floating-point scanning} { set a {}; set b {}; set c {}; set d {} list [scan "4.6abc" "%f %f %f %f" a b c d] $a $b $c $d } {1 4.6 {} {} {}} test scan-2.8 {floating-point scanning} { set a {}; set b {}; set c {}; set d {} list [scan "4.6 5.2" "%f %f %f %f" a b c d] $a $b $c $d } {2 4.6 5.2 {} {}} test scan-3.1 {string and character scanning} { set a {}; set b {}; set c {}; set d {} list [scan "abc defghijk dum " "%s %3s %20s %s" a b c d] $a $b $c $d } {4 abc def ghijk dum} test scan-3.2 {string and character scanning} { set a {}; set b {}; set c {}; set d {} list [scan "a bcdef" "%c%c%1s %s" a b c d] $a $b $c $d } {4 97 32 b cdef} test scan-3.3 {string and character scanning} { set a {}; set b {}; set c {} list [scan "123456 test " "%*c%*s %s %s %s" a b c] $a $b $c } {1 test {} {}} test scan-3.4 {string and character scanning} { set a {}; set b {}; set c {}; set d list [scan "ababcd01234 f 123450" {%4[abcd] %4[abcd] %[^abcdef] %[^0]} a b c d] $a $b $c $d } {4 abab cd {01234 } {f 12345}} test scan-3.5 {string and character scanning} { set a {}; set b {}; set c {} list [scan "aaaaaabc aaabcdefg + + XYZQR" {%*4[a] %s %*4[a]%s%*4[ +]%c} a b c] $a $b $c } {3 aabc bcdefg 43} test scan-4.1 {error conditions} { catch {scan a} } 1 test scan-4.2 {error conditions} { catch {scan a} msg set msg } {wrong # args: should be "scan string format ?varName varName ...?"} test scan-4.3 {error conditions} { catch {scan "1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21" "%d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d" a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 a21} } 1 test scan-4.4 {error conditions} { catch {scan "1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21" "%d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d" a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 a21} msg set msg } {too many fields to scan} test scan-4.5 {error conditions} { list [catch {scan a %D} msg] $msg } {1 {bad scan conversion character "D"}} test scan-4.6 {error conditions} { list [catch {scan a %O} msg] $msg } {1 {bad scan conversion character "O"}} test scan-4.7 {error conditions} { list [catch {scan a %X} msg] $msg } {1 {bad scan conversion character "X"}} test scan-4.8 {error conditions} { list [catch {scan a %F} msg] $msg } {1 {bad scan conversion character "F"}} test scan-4.9 {error conditions} { list [catch {scan a %E} msg] $msg } {1 {bad scan conversion character "E"}} test scan-4.10 {error conditions} { list [catch {scan a "%d %d" a} msg] $msg } {1 {different numbers of variable names and field specifiers}} test scan-4.11 {error conditions} { list [catch {scan a "%d %d" a b c} msg] $msg } {1 {different numbers of variable names and field specifiers}} test scan-4.12 {error conditions} { set a {}; set b {}; set c {}; set d {} list [expr {[scan " a" " a %d %d %d %d" a b c d] <= 0}] $a $b $c $d } {1 {} {} {} {}} test scan-4.13 {error conditions} { set a {}; set b {}; set c {}; set d {} list [scan "1 2" "%d %d %d %d" a b c d] $a $b $c $d } {2 1 2 {} {}} test scan-4.14 {error conditions} { catch {unset a} set a(0) 44 list [catch {scan 44 %d a} msg] $msg } {1 {couldn't set variable "a"}} test scan-4.15 {error conditions} { catch {unset a} set a(0) 44 list [catch {scan 44 %c a} msg] $msg } {1 {couldn't set variable "a"}} test scan-4.16 {error conditions} { catch {unset a} set a(0) 44 list [catch {scan 44 %s a} msg] $msg } {1 {couldn't set variable "a"}} test scan-4.17 {error conditions} { catch {unset a} set a(0) 44 list [catch {scan 44 %f a} msg] $msg } {1 {couldn't set variable "a"}} test scan-4.18 {error conditions} { catch {unset a} set a(0) 44 list [catch {scan 44 %f a} msg] $msg } {1 {couldn't set variable "a"}} catch {unset a} test scan-4.19 {error conditions} { list [catch {scan 44 %2c a} msg] $msg } {1 {field width may not be specified in %c conversion}} test scan-4.20 {error conditions} { list [catch {scan abc {%[}} msg] $msg } {1 {unmatched [ in format string}} test scan-5.1 {lots of arguments} { scan "10 20 30 40 50 60 70 80 90 100 110 120 130 140 150 160 170 180 190 200" "%d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d" a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 } 20 test scan-5.2 {lots of arguments} { scan "10 20 30 40 50 60 70 80 90 100 110 120 130 140 150 160 170 180 190 200" "%d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d" a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 set a20 } 200 test scan-6.1 {miscellaneous tests} { set a {} list [scan ab16c ab%dc a] $a } {1 16} test scan-6.2 {miscellaneous tests} { set a {} list [scan ax16c ab%dc a] $a } {0 {}} test scan-6.3 {miscellaneous tests} { set a {} list [catch {scan ab%c114 ab%%c%d a} msg] $msg $a } {0 1 114} test scan-6.4 {miscellaneous tests} { set a {} list [catch {scan ab%c14 ab%%c%d a} msg] $msg $a } {0 1 14} test scan-6.5 {miscellaneous tests} { catch {unset tcl_precision} set a {} scan 1.111122223333 %f a set a } {1.11112} test scan-6.6 {miscellaneous tests} { set tcl_precision 10 set a {} scan 1.111122223333 %lf a unset tcl_precision set a } {1.111122223} test scan-6.7 {miscellaneous tests} { set tcl_precision 10 set a {} scan 1.111122223333 %f a unset tcl_precision set a } {1.111122223} test scan-7.1 {alignment in results array (TCL_ALIGN)} { scan "123 13.6" "%s %f" a b set b } 13.6 test scan-7.2 {alignment in results array (TCL_ALIGN)} { scan "1234567 13.6" "%s %f" a b set b } 13.6 test scan-7.3 {alignment in results array (TCL_ALIGN)} { scan "12345678901 13.6" "%s %f" a b set b } 13.6 test scan-7.4 {alignment in results array (TCL_ALIGN)} { scan "123456789012345 13.6" "%s %f" a b set b } 13.6 test scan-7.5 {alignment in results array (TCL_ALIGN)} { scan "1234567890123456789 13.6" "%s %f" a b set b } 13.6 tcl7.4b4/tests/set.test010044400630510000012000000517730574726556000157150ustar00ousterstaff00002300000001# Commands covered: set, unset, array # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1995 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # @(#) set.test 1.17 95/04/25 14:36:48 if {[string compare test [info procs test]] == 1} then {source defs} proc ignore args {} # Simple variable operations. catch {unset a} test set-1.1 {basic variable setting and unsetting} { set a 22 } 22 test set-1.2 {basic variable setting and unsetting} { set a 123 set a } 123 test set-1.3 {basic variable setting and unsetting} { set a xxx format %s $a } xxx test set-1.4 {basic variable setting and unsetting} { set a 44 unset a list [catch {set a} msg] $msg } {1 {can't read "a": no such variable}} # Basic array operations. catch {unset a} set a(xyz) 2 set a(44) 3 set {a(a long name)} test test set-2.1 {basic array operations} { lsort [array names a] } {44 {a long name} xyz} test set-2.2 {basic array operations} { set a(44) } 3 test set-2.3 {basic array operations} { set a(xyz) } 2 test set-2.4 {basic array operations} { set "a(a long name)" } test test set-2.5 {basic array operations} { list [catch {set a(other)} msg] $msg } {1 {can't read "a(other)": no such element in array}} test set-2.6 {basic array operations} { list [catch {set a} msg] $msg } {1 {can't read "a": variable is array}} test set-2.7 {basic array operations} { format %s $a(44) } 3 test set-2.8 {basic array operations} { format %s $a(a long name) } test unset a(44) test set-2.9 {basic array operations} { lsort [array names a] } {{a long name} xyz} test set-2.10 {basic array operations} { catch {unset b} list [catch {set b(123)} msg] $msg } {1 {can't read "b(123)": no such variable}} test set-2.11 {basic array operations} { catch {unset b} set b 44 list [catch {set b(123)} msg] $msg } {1 {can't read "b(123)": variable isn't array}} test set-2.12 {basic array operations} { list [catch {set a 14} msg] $msg } {1 {can't set "a": variable is array}} unset a test set-2.13 {basic array operations} { list [catch {set a(xyz)} msg] $msg } {1 {can't read "a(xyz)": no such variable}} # Test the set commands, and exercise the corner cases of the code # that parses array references into two parts. test set-3.1 {set command} { list [catch {set} msg] $msg } {1 {wrong # args: should be "set varName ?newValue?"}} test set-3.2 {set command} { list [catch {set x y z} msg] $msg } {1 {wrong # args: should be "set varName ?newValue?"}} test set-3.3 {set command} { catch {unset a} list [catch {set a} msg] $msg } {1 {can't read "a": no such variable}} test set-3.4 {set command} { catch {unset a} set a(14) 83 list [catch {set a 22} msg] $msg } {1 {can't set "a": variable is array}} # Test the corner-cases of parsing array names, using set and unset. test set-4.1 {parsing array names} { catch {unset a} set a(()) 44 list [catch {array names a} msg] $msg } {0 ()} test set-4.2 {parsing array names} { catch {unset a a(abcd} set a(abcd 33 info exists a(abcd } 1 test set-4.3 {parsing array names} { catch {unset a a(abcd} set a(abcd 33 list [catch {array names a} msg] $msg } {0 {}} test set-4.4 {parsing array names} { catch {unset a abcd)} set abcd) 33 info exists abcd) } 1 test set-4.5 {parsing array names} { set a(bcd yyy catch {unset a} list [catch {set a(bcd} msg] $msg } {0 yyy} test set-4.6 {parsing array names} { catch {unset a} set a 44 list [catch {set a(bcd test} msg] $msg } {0 test} # Errors in reading variables test set-5.1 {errors in reading variables} { catch {unset a} list [catch {set a} msg] $msg } {1 {can't read "a": no such variable}} test set-5.2 {errors in reading variables} { catch {unset a} set a 44 list [catch {set a(18)} msg] $msg } {1 {can't read "a(18)": variable isn't array}} test set-5.3 {errors in reading variables} { catch {unset a} set a(6) 44 list [catch {set a(18)} msg] $msg } {1 {can't read "a(18)": no such element in array}} test set-5.4 {errors in reading variables} { catch {unset a} set a(6) 44 list [catch {set a} msg] $msg } {1 {can't read "a": variable is array}} # Errors and other special cases in writing variables test set-6.1 {creating array during write} { catch {unset a} trace var a rwu ignore list [catch {set a(14) 186} msg] $msg [array names a] } {0 186 14} test set-6.2 {errors in writing variables} { catch {unset a} set a xxx list [catch {set a(14) 186} msg] $msg } {1 {can't set "a(14)": variable isn't array}} test set-6.3 {errors in writing variables} { catch {unset a} set a(100) yyy list [catch {set a 2} msg] $msg } {1 {can't set "a": variable is array}} test set-6.4 {expanding variable size} { catch {unset a} list [set a short] [set a "longer name"] [set a "even longer name"] \ [set a "a much much truly longer name"] } {short {longer name} {even longer name} {a much much truly longer name}} # Unset command, Tcl_UnsetVar procedures test set-7.1 {unset command} { catch {unset a}; catch {unset b}; catch {unset c}; catch {unset d} set a 44 set b 55 set c 66 set d 77 unset a b c list [catch {set a(0) 0}] [catch {set b(0) 0}] [catch {set c(0) 0}] \ [catch {set d(0) 0}] } {0 0 0 1} test set-7.2 {unset command} { list [catch {unset} msg] $msg } {1 {wrong # args: should be "unset varName ?varName ...?"}} test set-7.3 {unset command} { catch {unset a} list [catch {unset a} msg] $msg } {1 {can't unset "a": no such variable}} test set-7.4 {unset command} { catch {unset a} set a 44 list [catch {unset a(14)} msg] $msg } {1 {can't unset "a(14)": variable isn't array}} test set-7.5 {unset command} { catch {unset a} set a(0) xx list [catch {unset a(14)} msg] $msg } {1 {can't unset "a(14)": no such element in array}} test set-7.6 {unset command} { catch {unset a}; catch {unset b}; catch {unset c} set a foo set c gorp list [catch {unset a a a(14)} msg] $msg [info exists c] } {1 {can't unset "a": no such variable} 1} test set-7.7 {unsetting globals from within procedures} { set y 0 proc p1 {} { global y set z [p2] return [list $z [catch {set y} msg] $msg] } proc p2 {} {global y; unset y; list [catch {set y} msg] $msg} p1 } {{1 {can't read "y": no such variable}} 1 {can't read "y": no such variable}} test set-7.8 {unsetting globals from within procedures} { set y 0 proc p1 {} { global y p2 return [list [catch {set y 44} msg] $msg] } proc p2 {} {global y; unset y} concat [p1] [list [catch {set y} msg] $msg] } {0 44 0 44} test set-7.9 {unsetting globals from within procedures} { set y 0 proc p1 {} { global y unset y return [list [catch {set y 55} msg] $msg] } concat [p1] [list [catch {set y} msg] $msg] } {0 55 0 55} test set-7.10 {unset command} { catch {unset a} set a(14) 22 unset a(14) list [catch {set a(14)} msg] $msg [catch {array names a} msg2] $msg2 } {1 {can't read "a(14)": no such element in array} 0 {}} test set-7.11 {unset command} { catch {unset a} set a(14) 22 unset a list [catch {set a(14)} msg] $msg [catch {array names a} msg2] $msg2 } {1 {can't read "a(14)": no such variable} 0 {}} # Array command. test set-8.1 {array command} { list [catch {array} msg] $msg } {1 {wrong # args: should be "array option arrayName ?arg ...?"}} test set-8.2 {array command} { list [catch {array a} msg] $msg } {1 {wrong # args: should be "array option arrayName ?arg ...?"}} test set-8.3 {array command} { catch {unset a} list [catch {array anymore a b} msg] $msg } {1 {"a" isn't an array}} test set-8.4 {array command} { catch {unset a} set a 44 list [catch {array anymore a b} msg] $msg } {1 {"a" isn't an array}} test set-8.5 {array command} { proc foo {} { set a 44 upvar 0 a x list [catch {array anymore x b} msg] $msg } foo } {1 {"x" isn't an array}} test set-8.6 {array command} { catch {unset a} set a(22) 3 list [catch {array gorp a} msg] $msg } {1 {bad option "gorp": should be anymore, donesearch, exists, get, names, nextelement, set, size, or startsearch}} test set-8.7 {array command, anymore option} { catch {unset a} list [catch {array anymore a x} msg] $msg } {1 {"a" isn't an array}} test set-8.8 {array command, donesearch option} { catch {unset a} list [catch {array donesearch a x} msg] $msg } {1 {"a" isn't an array}} test set-8.9 {array command, exists option} { list [catch {array exists a b} msg] $msg } {1 {wrong # args: should be "array exists arrayName"}} test set-8.10 {array command, exists option} { catch {unset a} array exists a } {0} test set-8.11 {array command, exists option} { catch {unset a} set a(0) 1 array exists a } {1} test set-8.12 {array command, get option} { list [catch {array get} msg] $msg } {1 {wrong # args: should be "array option arrayName ?arg ...?"}} test set-8.13 {array command, get option} { list [catch {array get a b c} msg] $msg } {1 {wrong # args: should be "array get arrayName ?pattern?"}} test set-8.14 {array command, get option} { catch {unset a} array get a } {} test set-8.15 {array command, get option} { catch {unset a} set a(22) 3 set {a(long name)} {} array get a } {22 3 {long name} {}} test set-8.16 {array command, get option (unset variable)} { catch {unset a} set a(x) 3 trace var a(y) w ignore array get a } {x 3} test set-8.17 {array command, get option, with pattern} { catch {unset a} set a(x1) 3 set a(x2) 4 set a(x3) 5 set a(b1) 24 set a(b2) 25 array get a x* } {x1 3 x2 4 x3 5} test set-8.18 {array command, names option} { catch {unset a} set a(22) 3 list [catch {array names a 4 5} msg] $msg } {1 {wrong # args: should be "array names arrayName ?pattern?"}} test set-8.19 {array command, names option} { catch {unset a} array names a } {} test set-8.20 {array command, names option} { catch {unset a} set a(22) 3; set a(Textual_name) 44; set "a(name with spaces)" xxx list [catch {lsort [array names a]} msg] $msg } {0 {22 Textual_name {name with spaces}}} test set-8.21 {array command, names option} { catch {unset a} set a(22) 3; set a(33) 44; trace var a(xxx) w ignore list [catch {lsort [array names a]} msg] $msg } {0 {22 33}} test set-8.22 {array command, names option} { catch {unset a} set a(22) 3; set a(33) 44; trace var a(xxx) w ignore set a(xxx) value list [catch {lsort [array names a]} msg] $msg } {0 {22 33 xxx}} test set-8.23 {array command, names option} { catch {unset a} set a(axy) 3 set a(bxy) 44 set a(no) yes set a(xxx) value list [lsort [array names a *xy]] [lsort [array names a]] } {{axy bxy} {axy bxy no xxx}} test set-8.24 {array command, nextelement option} { list [catch {array nextelement a} msg] $msg } {1 {wrong # args: should be "array nextelement arrayName searchId"}} test set-8.25 {array command, nextelement option} { catch {unset a} list [catch {array nextelement a b} msg] $msg } {1 {"a" isn't an array}} test set-8.26 {array command, set option} { list [catch {array set a} msg] $msg } {1 {wrong # args: should be "array set arrayName list"}} test set-8.27 {array command, set option} { list [catch {array set a 1 2} msg] $msg } {1 {wrong # args: should be "array set arrayName list"}} test set-8.28 {array command, set option} { list [catch {array set a "a \{ c"} msg] $msg } {1 {unmatched open brace in list}} test set-8.29 {array command, set option} { catch {unset a} set a 44 list [catch {array set a {a b c d}} msg] $msg } {1 {can't set "a(a)": variable isn't array}} test set-8.30 {array command, set option} { catch {unset a} set a(xx) yy array set a {b c d e} array get a } {d e xx yy b c} test set-8.31 {array command, size option} { list [catch {array size a 4} msg] $msg } {1 {wrong # args: should be "array size arrayName"}} test set-8.32 {array command, size option} { catch {unset a} array size a } {0} test set-8.33 {array command, size option} { catch {unset a} set a(22) 3; set a(Textual_name) 44; set "a(name with spaces)" xxx list [catch {array size a} msg] $msg } {0 3} test set-8.34 {array command, size option} { catch {unset a} set a(22) 3; set a(xx) 44; set a(y) xxx unset a(22) a(y) a(xx) list [catch {array size a} msg] $msg } {0 0} test set-8.35 {array command, size option} { catch {unset a} set a(22) 3; trace var a(33) rwu ignore list [catch {array size a} msg] $msg } {0 1} test set-8.36 {array command, startsearch option} { list [catch {array startsearch a b} msg] $msg } {1 {wrong # args: should be "array startsearch arrayName"}} test set-8.37 {array command, startsearch option} { catch {unset a} list [catch {array startsearch a} msg] $msg } {1 {"a" isn't an array}} test set-9.1 {ids for array enumeration} { catch {unset a} set a(a) 1 list [array st a] [array st a] [array done a s-1-a; array st a] \ [array done a s-2-a; array d a s-3-a; array start a] } {s-1-a s-2-a s-3-a s-1-a} test set-9.2 {array enumeration} { catch {unset a} set a(a) 1 set a(b) 1 set a(c) 1 set x [array startsearch a] list [array nextelement a $x] [array ne a $x] [array next a $x] \ [array next a $x] [array next a $x] } {a b c {} {}} test set-9.3 {array enumeration} { catch {unset a} set a(a) 1 set a(b) 1 set a(c) 1 set x [array startsearch a] set y [array startsearch a] set z [array startsearch a] list [array nextelement a $x] [array ne a $x] \ [array next a $y] [array next a $z] [array next a $y] \ [array next a $z] [array next a $y] [array next a $z] \ [array next a $y] [array next a $z] [array next a $x] \ [array next a $x] } {a b a a b b c c {} {} c {}} test set-9.4 {array enumeration: stopping searches} { catch {unset a} set a(a) 1 set a(b) 1 set a(c) 1 set x [array startsearch a] set y [array startsearch a] set z [array startsearch a] list [array next a $x] [array next a $x] [array next a $y] \ [array done a $z; array next a $x] \ [array done a $x; array next a $y] [array next a $y] } {a b a c b c} test set-9.5 {array enumeration: stopping searches} { catch {unset a} set a(a) 1 set x [array startsearch a] array done a $x list [catch {array next a $x} msg] $msg } {1 {couldn't find search "s-1-a"}} test set-9.6 {array enumeration: searches automatically stopped} { catch {unset a} set a(a) 1 set x [array startsearch a] set y [array startsearch a] set a(b) 1 list [catch {array next a $x} msg] $msg \ [catch {array next a $y} msg2] $msg2 } {1 {couldn't find search "s-1-a"} 1 {couldn't find search "s-2-a"}} test set-9.7 {array enumeration: searches automatically stopped} { catch {unset a} set a(a) 1 set x [array startsearch a] set y [array startsearch a] set a(a) 2 list [catch {array next a $x} msg] $msg \ [catch {array next a $y} msg2] $msg2 } {0 a 0 a} test set-9.8 {array enumeration: searches automatically stopped} { catch {unset a} set a(a) 1 set a(c) 2 set x [array startsearch a] set y [array startsearch a] catch {unset a(c)} list [catch {array next a $x} msg] $msg \ [catch {array next a $y} msg2] $msg2 } {1 {couldn't find search "s-1-a"} 1 {couldn't find search "s-2-a"}} test set-9.9 {array enumeration: searches automatically stopped} { catch {unset a} set a(a) 1 set x [array startsearch a] set y [array startsearch a] catch {unset a(c)} list [catch {array next a $x} msg] $msg \ [catch {array next a $y} msg2] $msg2 } {0 a 0 a} test set-9.10 {array enumeration: searches automatically stopped} { catch {unset a} set a(a) 1 set x [array startsearch a] set y [array startsearch a] trace var a(b) r {} list [catch {array next a $x} msg] $msg \ [catch {array next a $y} msg2] $msg2 } {1 {couldn't find search "s-1-a"} 1 {couldn't find search "s-2-a"}} test set-9.11 {array enumeration: searches automatically stopped} { catch {unset a} set a(a) 1 set x [array startsearch a] set y [array startsearch a] trace var a(a) r {} list [catch {array next a $x} msg] $msg \ [catch {array next a $y} msg2] $msg2 } {0 a 0 a} test set-9.12 {array enumeration with traced undefined elements} { catch {unset a} set a(a) 1 trace var a(b) r {} set x [array startsearch a] list [array next a $x] [array next a $x] } {a {}} test set-10.1 {array enumeration errors} { list [catch {array start} msg] $msg } {1 {wrong # args: should be "array option arrayName ?arg ...?"}} test set-10.2 {array enumeration errors} { list [catch {array start a b} msg] $msg } {1 {wrong # args: should be "array startsearch arrayName"}} test set-10.3 {array enumeration errors} { catch {unset a} list [catch {array start a} msg] $msg } {1 {"a" isn't an array}} test set-10.4 {array enumeration errors} { catch {unset a} set a(a) 1 set x [array startsearch a] list [catch {array next a} msg] $msg } {1 {wrong # args: should be "array nextelement arrayName searchId"}} test set-10.5 {array enumeration errors} { catch {unset a} set a(a) 1 set x [array startsearch a] list [catch {array next a b c} msg] $msg } {1 {wrong # args: should be "array nextelement arrayName searchId"}} test set-10.6 {array enumeration errors} { catch {unset a} set a(a) 1 set x [array startsearch a] list [catch {array next a a-1-a} msg] $msg } {1 {illegal search identifier "a-1-a"}} test set-10.7 {array enumeration errors} { catch {unset a} set a(a) 1 set x [array startsearch a] list [catch {array next a sx1-a} msg] $msg } {1 {illegal search identifier "sx1-a"}} test set-10.8 {array enumeration errors} { catch {unset a} set a(a) 1 set x [array startsearch a] list [catch {array next a s--a} msg] $msg } {1 {illegal search identifier "s--a"}} test set-10.9 {array enumeration errors} { catch {unset a} set a(a) 1 set x [array startsearch a] list [catch {array next a s-1-b} msg] $msg } {1 {search identifier "s-1-b" isn't for variable "a"}} test set-10.10 {array enumeration errors} { catch {unset a} set a(a) 1 set x [array startsearch a] list [catch {array next a s-1ba} msg] $msg } {1 {illegal search identifier "s-1ba"}} test set-10.11 {array enumeration errors} { catch {unset a} set a(a) 1 set x [array startsearch a] list [catch {array next a s-2-a} msg] $msg } {1 {couldn't find search "s-2-a"}} test set-10.12 {array enumeration errors} { list [catch {array done a} msg] $msg } {1 {wrong # args: should be "array donesearch arrayName searchId"}} test set-10.13 {array enumeration errors} { list [catch {array done a b c} msg] $msg } {1 {wrong # args: should be "array donesearch arrayName searchId"}} test set-10.14 {array enumeration errors} { list [catch {array done a b} msg] $msg } {1 {illegal search identifier "b"}} test set-10.15 {array enumeration errors} { list [catch {array anymore a} msg] $msg } {1 {wrong # args: should be "array anymore arrayName searchId"}} test set-10.16 {array enumeration errors} { list [catch {array any a b c} msg] $msg } {1 {wrong # args: should be "array anymore arrayName searchId"}} test set-10.17 {array enumeration errors} { catch {unset a} set a(0) 44 list [catch {array any a bogus} msg] $msg } {1 {illegal search identifier "bogus"}} # Array enumeration with "anymore" option test set-11.1 {array anymore option} { catch {unset a} set a(a) 1 set a(b) 2 set a(c) 3 array startsearch a list [array anymore a s-1-a] [array next a s-1-a] \ [array anymore a s-1-a] [array next a s-1-a] \ [array anymore a s-1-a] [array next a s-1-a] \ [array anymore a s-1-a] [array next a s-1-a] } {1 a 1 b 1 c 0 {}} test set-11.2 {array anymore option} { catch {unset a} set a(a) 1 set a(b) 2 set a(c) 3 array startsearch a list [array next a s-1-a] [array next a s-1-a] \ [array anymore a s-1-a] [array next a s-1-a] \ [array next a s-1-a] [array anymore a s-1-a] } {a b 1 c {} 0} # Special check to see that the value of a variable is handled correctly # if it is returned as the result of a procedure (must not free the variable # string while deleting the call frame). Errors will only be detected if # a memory consistency checker such as Purify is being used. test set-12.1 {cleanup on procedure return} { proc foo {} { set x 12345 } foo } 12345 test set-12.2 {cleanup on procedure return} { proc foo {} { set x(1) 23456 } foo } 23456 # Must delete variables when done, since these arrays get used as # scalars by other tests. catch {unset a} catch {unset b} catch {unset c} return "" ray ntcl7.4b4/tests/source.test010044400630510000012000000067640573633177200164170ustar00ousterstaff00002300000001# Commands covered: source # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # @(#) source.test 1.10 95/03/29 11:24:42 if {[string compare test [info procs test]] == 1} then {source defs} test source-1.1 {source command} { set x "old x value" set y "old y value" set z "old z value" exec cat << { set x 22 set y 33 set z 44 } > source.file source source.file list $x $y $z } {22 33 44} test source-1.2 {source command} { exec cat << {list result} > source.file source source.file } result test source-2.1 {source error conditions} { list [catch {source} msg] $msg } {1 {wrong # args: should be "source fileName"}} test source-2.2 {source error conditions} { list [catch {source a b} msg] $msg } {1 {wrong # args: should be "source fileName"}} test source-2.3 {source error conditions} { exec cat << { set x 146 error "error in sourced file" set y $x } > source.file list [catch {source source.file} msg] $msg $errorInfo } {1 {error in sourced file} {error in sourced file while executing "error "error in sourced file"" (file "source.file" line 3) invoked from within "source source.file"}} test source-2.4 {source error conditions} { exec cat << {break} > source.file catch {source source.file} } 3 test source-2.5 {source error conditions} { exec cat << {continue} > source.file catch {source source.file} } 4 test source-2.6 {source error conditions} { string tolower [list [catch {source _non_existent_} msg] $msg $errorCode] } {1 {couldn't read file "_non_existent_": no such file or directory} {posix enoent {no such file or directory}}} test source-3.1 {return in middle of source file} { exec cat << { set x new-x return allDone set y new-y } > source.file set x old-x set y old-y set z [source source.file] list $x $y $z } {new-x old-y allDone} test source-3.2 {return with special code etc.} { exec cat << { set x new-x return -code break "Silly result" set y new-y } > source.file list [catch {source source.file} msg] $msg } {3 {Silly result}} test source-3.3 {return with special code etc.} { exec cat << { set x new-x return -code error "Simulated error" set y new-y } > source.file list [catch {source source.file} msg] $msg $errorInfo $errorCode } {1 {Simulated error} {Simulated error while executing "source source.file"} NONE} test source-3.4 {return with special code etc.} { exec cat << { set x new-x return -code error -errorinfo "Simulated errorInfo stuff" set y new-y } > source.file list [catch {source source.file} msg] $msg $errorInfo $errorCode } {1 {} {Simulated errorInfo stuff invoked from within "source source.file"} NONE} test source-3.5 {return with special code etc.} { exec cat << { set x new-x return -code error -errorinfo "Simulated errorInfo stuff" \ -errorcode {a b c} set y new-y } > source.file list [catch {source source.file} msg] $msg $errorInfo $errorCode } {1 {} {Simulated errorInfo stuff invoked from within "source source.file"} {a b c}} catch {exec rm source.file} # Generate null final value concat {} tcl7.4b4/tests/split.test010044400630510000012000000026600567470012400162310ustar00ousterstaff00002300000001# Commands covered: split # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # @(#) split.test 1.7 94/12/17 16:20:25 if {[string compare test [info procs test]] == 1} then {source defs} test split-1.1 {basic split commands} { split "a\n b\t\r c\n " } {a {} b {} {} c {} {}} test split-1.2 {basic split commands} { split "word 1xyzword 2zword 3" xyz } {{word 1} {} {} {word 2} {word 3}} test split-1.3 {basic split commands} { split "12345" {} } {1 2 3 4 5} test split-1.4 {basic split commands} { split "a\}b\[c\{\]\$" } "a\\}b\\\[c\\{\\\]\\\$" test split-1.5 {basic split commands} { split {} {} } {} test split-1.6 {basic split commands} { split {} } {} test split-1.7 {basic split commands} { split { } } {{} {} {} {}} test split-2.1 {split errors} { list [catch split msg] $msg $errorCode } {1 {wrong # args: should be "split string ?splitChars?"} NONE} test split-2.2 {split errors} { list [catch {split a b c} msg] $msg $errorCode } {1 {wrong # args: should be "split string ?splitChars?"} NONE} tcl7.4b4/tests/string.test010044400630510000012000000266420567470012400164120ustar00ousterstaff00002300000001# Commands covered: string # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # @(#) string.test 1.11 94/12/17 16:20:26 if {[string compare test [info procs test]] == 1} then {source defs} test string-1.1 {string compare} { string compare abcde abdef } -1 test string-1.2 {string compare} { string c abcde ABCDE } 1 test string-1.3 {string compare} { string compare abcde abcde } 0 test string-1.4 {string compare} { list [catch {string compare a} msg] $msg } {1 {wrong # args: should be "string compare string1 string2"}} test string-1.5 {string compare} { list [catch {string compare a b c} msg] $msg } {1 {wrong # args: should be "string compare string1 string2"}} test string-2.1 {string first} { string first bq abcdefgbcefgbqrs } 12 test string-2.2 {string first} { string fir bcd abcdefgbcefgbqrs } 1 test string-2.3 {string first} { string f b abcdefgbcefgbqrs } 1 test string-2.4 {string first} { string first xxx x123xx345xxx789xxx012 } 9 test string-2.5 {string first} { list [catch {string first a} msg] $msg } {1 {wrong # args: should be "string first string1 string2"}} test string-2.6 {string first} { list [catch {string first a b c} msg] $msg } {1 {wrong # args: should be "string first string1 string2"}} test string-3.1 {string index} { string index abcde 0 } a test string-3.2 {string index} { string i abcde 4 } e test string-3.3 {string index} { string index abcde 5 } {} test string-3.4 {string index} { list [catch {string index abcde -10} msg] $msg } {0 {}} test string-3.5 {string index} { list [catch {string index} msg] $msg } {1 {wrong # args: should be "string index string charIndex"}} test string-3.6 {string index} { list [catch {string index a b c} msg] $msg } {1 {wrong # args: should be "string index string charIndex"}} test string-3.7 {string index} { list [catch {string index a xyz} msg] $msg } {1 {expected integer but got "xyz"}} test string-4.1 {string last} { string la xxx xxxx123xx345x678 } 1 test string-4.2 {string last} { string last xx xxxx123xx345x678 } 7 test string-4.3 {string last} { string las x xxxx123xx345x678 } 12 test string-4.4 {string last} { list [catch {string last a} msg] $msg } {1 {wrong # args: should be "string last string1 string2"}} test string-4.5 {string last} { list [catch {string last a b c} msg] $msg } {1 {wrong # args: should be "string last string1 string2"}} test string-5.1 {string length} { string length "a little string" } 15 test string-5.2 {string length} { string le "" } 0 test string-5.3 {string length} { list [catch {string length} msg] $msg } {1 {wrong # args: should be "string length string"}} test string-5.4 {string length} { list [catch {string length a b} msg] $msg } {1 {wrong # args: should be "string length string"}} test string-6.1 {string match} { string match abc abc } 1 test string-6.2 {string match} { string m abc abd } 0 test string-6.3 {string match} { string match ab*c abc } 1 test string-6.4 {string match} { string match ab**c abc } 1 test string-6.5 {string match} { string match ab* abcdef } 1 test string-6.6 {string match} { string match *c abc } 1 test string-6.7 {string match} { string match *3*6*9 0123456789 } 1 test string-6.8 {string match} { string match *3*6*9 01234567890 } 0 test string-6.9 {string match} { string match a?c abc } 1 test string-6.10 {string match} { string match a??c abc } 0 test string-6.11 {string match} { string match ?1??4???8? 0123456789 } 1 test string-6.12 {string match} { string match {[abc]bc} abc } 1 test string-6.13 {string match} { string match {a[abc]c} abc } 1 test string-6.14 {string match} { string match {a[xyz]c} abc } 0 test string-6.15 {string match} { string match {12[2-7]45} 12345 } 1 test string-6.16 {string match} { string match {12[ab2-4cd]45} 12345 } 1 test string-6.17 {string match} { string match {12[ab2-4cd]45} 12b45 } 1 test string-6.18 {string match} { string match {12[ab2-4cd]45} 12d45 } 1 test string-6.19 {string match} { string match {12[ab2-4cd]45} 12145 } 0 test string-6.20 {string match} { string match {12[ab2-4cd]45} 12545 } 0 test string-6.21 {string match} { string match {a\*b} a*b } 1 test string-6.22 {string match} { string match {a\*b} ab } 0 test string-6.23 {string match} { string match {a\*\?\[\]\\\x} "a*?\[\]\\x" } 1 test string-6.24 {string match} { string match ** "" } 1 test string-6.25 {string match} { string match *. "" } 0 test string-6.26 {string match} { string match "" "" } 1 test string-6.27 {string match} { string match \[a a } 1 test string-6.28 {string match} { list [catch {string match a} msg] $msg } {1 {wrong # args: should be "string match pattern string"}} test string-6.29 {string match} { list [catch {string match a b c} msg] $msg } {1 {wrong # args: should be "string match pattern string"}} test string-7.1 {string range} { string range abcdefghijklmnop 2 14 } {cdefghijklmno} test string-7.2 {string range} { string range abcdefghijklmnop 7 1000 } {hijklmnop} test string-7.3 {string range} { string range abcdefghijklmnop 10 e } {klmnop} test string-7.4 {string range} { string range abcdefghijklmnop 10 9 } {} test string-7.5 {string range} { string range abcdefghijklmnop -3 2 } {abc} test string-7.6 {string range} { string range abcdefghijklmnop -3 -2 } {} test string-7.7 {string range} { string range abcdefghijklmnop 1000 1010 } {} test string-7.8 {string range} { string range abcdefghijklmnop -100 end } {abcdefghijklmnop} test string-7.9 {string range} { list [catch {string range} msg] $msg } {1 {wrong # args: should be "string range string first last"}} test string-7.10 {string range} { list [catch {string range a 1} msg] $msg } {1 {wrong # args: should be "string range string first last"}} test string-7.11 {string range} { list [catch {string range a 1 2 3} msg] $msg } {1 {wrong # args: should be "string range string first last"}} test string-7.12 {string range} { list [catch {string range abc abc 1} msg] $msg } {1 {expected integer but got "abc"}} test string-7.13 {string range} { list [catch {string range abc 1 eof} msg] $msg } {1 {expected integer or "end" but got "eof"}} test string-8.1 {string trim} { string trim " XYZ " } {XYZ} test string-8.2 {string trim} { string trim "\t\nXYZ\t\n\r\n" } {XYZ} test string-8.3 {string trim} { string trim " A XYZ A " } {A XYZ A} test string-8.4 {string trim} { string trim "XXYYZZABC XXYYZZ" ZYX } {ABC } test string-8.5 {string trim} { string trim " \t\r " } {} test string-8.6 {string trim} { string trim {abcdefg} {} } {abcdefg} test string-8.7 {string trim} { string trim {} } {} test string-8.8 {string trim} { string trim ABC DEF } {ABC} test string-8.9 {string trim} { list [catch {string trim} msg] $msg } {1 {wrong # args: should be "string trim string ?chars?"}} test string-8.10 {string trim} { list [catch {string trim a b c} msg] $msg } {1 {wrong # args: should be "string trim string ?chars?"}} test string-9.1 {string trimleft} { string trimleft " XYZ " } {XYZ } test string-9.2 {string trimleft} { list [catch {string triml} msg] $msg } {1 {wrong # args: should be "string trimleft string ?chars?"}} test string-10.1 {string trimright} { string trimright " XYZ " } { XYZ} test string-10.2 {string trimright} { string trimright " " } {} test string-10.3 {string trimright} { string trimright "" } {} test string-10.4 {string trimright errors} { list [catch {string trimr} msg] $msg } {1 {wrong # args: should be "string trimright string ?chars?"}} test string-10.5 {string trimright errors} { list [catch {string trimg a} msg] $msg } {1 {bad option "trimg": should be compare, first, index, last, length, match, range, tolower, toupper, trim, trimleft, trimright, wordend, or wordstart}} test string-11.1 {string tolower} { string tolower ABCDeF } {abcdef} test string-11.2 {string tolower} { string tolower "ABC XyZ" } {abc xyz} test string-11.3 {string tolower} { string tolower {123#$&*()} } {123#$&*()} test string-11.4 {string tolower} { list [catch {string tolower} msg] $msg } {1 {wrong # args: should be "string tolower string"}} test string-11.5 {string tolower} { list [catch {string tolower a b} msg] $msg } {1 {wrong # args: should be "string tolower string"}} test string-12.1 {string toupper} { string toupper abCDEf } {ABCDEF} test string-12.2 {string toupper} { string toupper "abc xYz" } {ABC XYZ} test string-12.3 {string toupper} { string toupper {123#$&*()} } {123#$&*()} test string-12.4 {string toupper} { list [catch {string toupper} msg] $msg } {1 {wrong # args: should be "string toupper string"}} test string-12.5 {string toupper} { list [catch {string toupper a b} msg] $msg } {1 {wrong # args: should be "string toupper string"}} test string-13.1 {string wordend} { list [catch {string wordend a} msg] $msg } {1 {wrong # args: should be "string wordend string index"}} test string-13.2 {string wordend} { list [catch {string wordend a b c} msg] $msg } {1 {wrong # args: should be "string wordend string index"}} test string-13.3 {string wordend} { list [catch {string wordend a gorp} msg] $msg } {1 {expected integer but got "gorp"}} test string-13.4 {string wordend} { string wordend abc. -1 } 3 test string-13.5 {string wordend} { string wordend abc. 100 } 4 test string-13.6 {string wordend} { string wordend "word_one two three" 2 } 8 test string-13.7 {string wordend} { string wordend "one .&# three" 5 } 6 test string-13.8 {string wordend} { string worde "x.y" 0 } 1 test string-14.1 {string wordstart} { list [catch {string word a} msg] $msg } {1 {bad option "word": should be compare, first, index, last, length, match, range, tolower, toupper, trim, trimleft, trimright, wordend, or wordstart}} test string-14.2 {string wordstart} { list [catch {string wordstart a} msg] $msg } {1 {wrong # args: should be "string wordstart string index"}} test string-14.3 {string wordstart} { list [catch {string wordstart a b c} msg] $msg } {1 {wrong # args: should be "string wordstart string index"}} test string-14.4 {string wordstart} { list [catch {string wordstart a gorp} msg] $msg } {1 {expected integer but got "gorp"}} test string-14.5 {string wordstart} { string wordstart "one two three_words" 400 } 8 test string-14.6 {string wordstart} { string wordstart "one two three_words" 2 } 0 test string-14.7 {string wordend} { string wordstart "one two three_words" -2 } 0 test string-14.8 {string wordend} { string wordstart "one .*&^ three" 6 } 6 test string-14.9 {string wordend} { string wordstart "one two three" 4 } 4 test string-15.1 {error conditions} { list [catch {string gorp a b} msg] $msg } {1 {bad option "gorp": should be compare, first, index, last, length, match, range, tolower, toupper, trim, trimleft, trimright, wordend, or wordstart}} test string-15.2 {error conditions} { list [catch {string} msg] $msg } {1 {wrong # args: should be "string option arg ?arg ...?"}} tcl7.4b4/tests/subst.test010044400630510000012000000067430575122057200162440ustar00ousterstaff00002300000001# Commands covered: subst # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1994 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # @(#) subst.test 1.6 95/05/01 10:59:21 if {[string compare test [info procs test]] == 1} then {source defs} test subst-1.1 {basics} { list [catch {subst} msg] $msg } {1 {wrong # args: should be "subst ?-nobackslashes? ?-nocommands? ?-novariables? string"}} test subst-1.2 {basics} { list [catch {subst a b c} msg] $msg } {1 {wrong # args: should be "subst ?-nobackslashes? ?-nocommands? ?-novariables? string"}} test subst-2.1 {simple strings} { subst {} } {} test subst-2.2 {simple strings} { subst a } a test subst-2.3 {simple strings} { subst abcdefg } abcdefg test subst-3.1 {backslash substitutions} { subst {\x\$x\[foo bar]\\} } "x\$x\[foo bar]\\" test subst-4.1 {variable substitutions} { set a 44 subst {$a} } {44} test subst-4.2 {variable substitutions} { set a 44 subst {x$a.y{$a}.z} } {x44.y{44}.z} test subst-4.3 {variable substitutions} { catch {unset a} set a(13) 82 set i 13 subst {x.$a($i)} } {x.82} catch {unset a} set long {This is a very long string, intentionally made so long that it will overflow the static character size for dstrings, so that additional memory will have to be allocated by subst. That way, if the subst procedure forgets to free up memory while returning an error, there will be memory that isn't freed (this will be detected when the tests are run under a checking memory allocator such as Purify).} test subst-4.4 {variable substitutions} { list [catch {subst {$long $a}} msg] $msg } {1 {can't read "a": no such variable}} test subst-5.1 {command substitutions} { subst {[concat {}]} } {} test subst-5.2 {command substitutions} { subst {[concat A test string]} } {A test string} test subst-5.3 {command substitutions} { subst {x.[concat foo].y.[concat bar].z} } {x.foo.y.bar.z} test subst-5.3 {command substitutions} { list [catch {subst {$long [set long] [bogus_command]}} msg] $msg } {1 {invalid command name "bogus_command"}} test subst-6.1 {clear the result after command substitution} { catch {unset a} list [catch {subst {[concat foo] $a}} msg] $msg } {1 {can't read "a": no such variable}} test subst-7.1 {switches} { list [catch {subst foo bar} msg] $msg } {1 {wrong # args: should be "subst ?-nobackslashes? ?-nocommands? ?-novariables? string"}} test subst-7.2 {switches} { list [catch {subst -no bar} msg] $msg } {1 {bad switch "-no": must be -nobackslashes, -nocommands, or -novariables}} test subst-7.3 {switches} { list [catch {subst -bogus bar} msg] $msg } {1 {bad switch "-bogus": must be -nobackslashes, -nocommands, or -novariables}} test subst-7.4 {switches} { set x 123 subst -nobackslashes {abc $x [expr 1+2] \\\x41} } {abc 123 3 \\\x41} test subst-7.5 {switches} { set x 123 subst -nocommands {abc $x [expr 1+2] \\\x41} } {abc 123 [expr 1+2] \A} test subst-7.6 {switches} { set x 123 subst -novariables {abc $x [expr 1+2] \\\x41} } {abc $x 3 \A} test subst-7.7 {switches} { set x 123 subst -nov -nob -noc {abc $x [expr 1+2] \\\x41} } {abc $x [expr 1+2] \\\x41} tcl7.4b4/tests/switch.test010044400630510000012000000114630567470012500164010ustar00ousterstaff00002300000001# Commands covered: switch # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # @(#) switch.test 1.4 94/12/17 16:20:28 if {[string compare test [info procs test]] == 1} then {source defs} test switch-1.1 {simple patterns} { switch a a {format 1} b {format 2} c {format 3} default {format 4} } 1 test switch-1.2 {simple patterns} { switch b a {format 1} b {format 2} c {format 3} default {format 4} } 2 test switch-1.3 {simple patterns} { switch x a {format 1} b {format 2} c {format 3} default {format 4} } 4 test switch-1.4 {simple patterns} { switch x a {format 1} b {format 2} c {format 3} } {} test switch-1.5 {simple pattern matches many times} { switch b a {format 1} b {format 2} b {format 3} b {format 4} } 2 test switch-1.6 {simple patterns} { switch default a {format 1} default {format 2} c {format 3} default {format 4} } 2 test switch-1.7 {simple patterns} { switch x a {format 1} default {format 2} c {format 3} default {format 4} } 4 test switch-2.1 {single-argument form for pattern/command pairs} { switch b { a {format 1} b {format 2} default {format 6} } } {2} test switch-2.2 {single-argument form for pattern/command pairs} { list [catch {switch z {a 2 b}} msg] $msg } {1 {extra switch pattern with no body}} test switch-3.1 {-exact vs. -glob vs. -regexp} { switch -exact aaaab { ^a*b$ {concat regexp} *b {concat glob} aaaab {concat exact} default {concat none} } } exact test switch-3.2 {-exact vs. -glob vs. -regexp} { switch -exact -regexp aaaab { ^a*b$ {concat regexp} *b {concat glob} aaaab {concat exact} default {concat none} } } regexp test switch-3.3 {-exact vs. -glob vs. -regexp} { switch -glob aaaab { ^a*b$ {concat regexp} *b {concat glob} aaaab {concat exact} default {concat none} } } glob test switch-3.4 {-exact vs. -glob vs. -regexp} { switch aaaab {^a*b$} {concat regexp} *b {concat glob} \ aaaab {concat exact} default {concat none} } exact test switch-3.5 {-exact vs. -glob vs. -regexp} { switch -- -glob { ^g.*b$ {concat regexp} -* {concat glob} -glob {concat exact} default {concat none} } } exact test switch-3.6 {-exact vs. -glob vs. -regexp} { list [catch {switch -foo a b c} msg] $msg } {1 {bad option "-foo": should be -exact, -glob, -regexp, or --}} test switch-4.1 {error in executed command} { list [catch {switch a a {error "Just a test"} default {format 1}} msg] \ $msg $errorInfo } {1 {Just a test} {Just a test while executing "error "Just a test"" ("a" arm line 1) invoked from within "switch a a {error "Just a test"} default {format 1}"}} test switch-4.2 {error: not enough args} { list [catch {switch} msg] $msg } {1 {wrong # args: should be "switch ?switches? string pattern body ... ?default body?"}} test switch-4.3 {error: pattern with no body} { list [catch {switch a b} msg] $msg } {1 {extra switch pattern with no body}} test switch-4.4 {error: pattern with no body} { list [catch {switch a b {format 1} c} msg] $msg } {1 {extra switch pattern with no body}} test switch-4.5 {error in default command} { list [catch {switch foo a {error switch1} b {error switch 3} \ default {error switch2}} msg] $msg $errorInfo } {1 switch2 {switch2 while executing "error switch2" ("default" arm line 1) invoked from within "switch foo a {error switch1} b {error switch 3} default {error switch2}"}} test switch-5.1 {errors in -regexp matching} { list [catch {switch -regexp aaaab { *b {concat glob} aaaab {concat exact} default {concat none} }} msg] $msg } {1 {couldn't compile regular expression pattern: ?+* follows nothing}} test switch-6.1 {backslashes in patterns} { switch -exact {\a\$\.\[} { \a\$\.\[ {concat first} \a\\$\.\\[ {concat second} \\a\\$\\.\\[ {concat third} {\a\\$\.\\[} {concat fourth} {\\a\\$\\.\\[} {concat fifth} default {concat none} } } third test switch-6.2 {backslashes in patterns} { switch -exact {\a\$\.\[} { \a\$\.\[ {concat first} {\a\$\.\[} {concat second} {{\a\$\.\[}} {concat third} default {concat none} } } second test switch-7.1 {"-" bodies} { switch a { a - b - c {concat 1} default {concat 2} } } 1 test switch-7.2 {"-" bodies} { list [catch { switch a { a - b - c - } } msg] $msg } {1 {no body specified for pattern "a"}} test switch-7.3 {"-" bodies} { list [catch { switch a { a - b -foo c - } } msg] $msg } {1 {invalid command name "-foo"}} tcl7.4b4/tests/trace.test010044400630510000012000000663520567470012500162050ustar00ousterstaff00002300000001# Commands covered: trace # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # @(#) trace.test 1.23 94/12/17 16:20:29 if {[string compare test [info procs test]] == 1} then {source defs} proc traceScalar {name1 name2 op} { global info set info [list $name1 $name2 $op [catch {uplevel set $name1} msg] $msg] } proc traceScalarAppend {name1 name2 op} { global info lappend info $name1 $name2 $op [catch {uplevel set $name1} msg] $msg } proc traceArray {name1 name2 op} { global info set info [list $name1 $name2 $op [catch {uplevel set [set name1]($name2)} msg] $msg] } proc traceProc {name1 name2 op} { global info set info [concat $info [list $name1 $name2 $op]] } proc traceTag {tag args} { global info set info [concat $info $tag] } proc traceError {args} { error "trace returned error" } proc traceCheck {cmd args} { global info set info [list [catch $cmd msg] $msg] } proc traceCrtElement {value name1 name2 op} { uplevel set ${name1}($name2) $value } # Read-tracing on variables test trace-1.1 {trace variable reads} { catch {unset x} set info {} trace var x r traceScalar list [catch {set x} msg] $msg $info } {1 {can't read "x": no such variable} {x {} r 1 {can't read "x": no such variable}}} test trace-1.2 {trace variable reads} { catch {unset x} set x 123 set info {} trace var x r traceScalar list [catch {set x} msg] $msg $info } {0 123 {x {} r 0 123}} test trace-1.3 {trace variable reads} { catch {unset x} set info {} trace var x r traceScalar set x 123 set info } {} test trace-1.4 {trace array element reads} { catch {unset x} set info {} trace var x(2) r traceArray list [catch {set x(2)} msg] $msg $info } {1 {can't read "x(2)": no such element in array} {x 2 r 1 {can't read "x(2)": no such element in array}}} test trace-1.5 {trace array element reads} { catch {unset x} set x(2) zzz set info {} trace var x(2) r traceArray list [catch {set x(2)} msg] $msg $info } {0 zzz {x 2 r 0 zzz}} test trace-1.6 {trace reads on whole arrays} { catch {unset x} set info {} trace var x r traceArray list [catch {set x(2)} msg] $msg $info } {1 {can't read "x(2)": no such variable} {}} test trace-1.7 {trace reads on whole arrays} { catch {unset x} set x(2) zzz set info {} trace var x r traceArray list [catch {set x(2)} msg] $msg $info } {0 zzz {x 2 r 0 zzz}} test trace-1.8 {trace variable reads} { catch {unset x} set x 444 set info {} trace var x r traceScalar unset x set info } {} # Basic write-tracing on variables test trace-2.1 {trace variable writes} { catch {unset x} set info {} trace var x w traceScalar set x 123 set info } {x {} w 0 123} test trace-2.2 {trace writes to array elements} { catch {unset x} set info {} trace var x(33) w traceArray set x(33) 444 set info } {x 33 w 0 444} test trace-2.3 {trace writes on whole arrays} { catch {unset x} set info {} trace var x w traceArray set x(abc) qq set info } {x abc w 0 qq} test trace-2.4 {trace variable writes} { catch {unset x} set x 1234 set info {} trace var x w traceScalar set x set info } {} test trace-2.5 {trace variable writes} { catch {unset x} set x 1234 set info {} trace var x w traceScalar unset x set info } {} test trace-3.1 {trace variable read-modify-writes} { catch {unset x} set info {} trace var x r traceScalarAppend append x 123 append x 456 lappend x 789 set info } {x {} r 1 {can't read "x": no such variable} x {} r 0 123 x {} r 0 123456} test trace-3.2 {trace variable read-modify-writes} { catch {unset x} set info {} trace var x rw traceScalarAppend append x 123 lappend x 456 set info } {x {} r 1 {can't read "x": no such variable} x {} w 0 123 x {} r 0 123 x {} w 0 {123 456}} # Basic unset-tracing on variables test trace-4.1 {trace variable unsets} { catch {unset x} set info {} trace var x u traceScalar catch {unset x} set info } {x {} u 1 {can't read "x": no such variable}} test trace-4.2 {variable mustn't exist during unset trace} { catch {unset x} set x 1234 set info {} trace var x u traceScalar unset x set info } {x {} u 1 {can't read "x": no such variable}} test trace-4.3 {unset traces mustn't be called during reads and writes} { catch {unset x} set info {} trace var x u traceScalar set x 44 set x set info } {} test trace-4.4 {trace unsets on array elements} { catch {unset x} set x(0) 18 set info {} trace var x(1) u traceArray catch {unset x(1)} set info } {x 1 u 1 {can't read "x(1)": no such element in array}} test trace-4.5 {trace unsets on array elements} { catch {unset x} set x(1) 18 set info {} trace var x(1) u traceArray unset x(1) set info } {x 1 u 1 {can't read "x(1)": no such element in array}} test trace-4.6 {trace unsets on array elements} { catch {unset x} set x(1) 18 set info {} trace var x(1) u traceArray unset x set info } {x 1 u 1 {can't read "x(1)": no such variable}} test trace-4.7 {trace unsets on whole arrays} { catch {unset x} set x(1) 18 set info {} trace var x u traceProc catch {unset x(0)} set info } {} test trace-4.8 {trace unsets on whole arrays} { catch {unset x} set x(1) 18 set x(2) 144 set x(3) 14 set info {} trace var x u traceProc unset x(1) set info } {x 1 u} test trace-4.9 {trace unsets on whole arrays} { catch {unset x} set x(1) 18 set x(2) 144 set x(3) 14 set info {} trace var x u traceProc unset x set info } {x {} u} # Trace multiple trace types at once. test trace-5.1 {multiple ops traced at once} { catch {unset x} set info {} trace var x rwu traceProc catch {set x} set x 22 set x set x 33 unset x set info } {x {} r x {} w x {} r x {} w x {} u} test trace-5.2 {multiple ops traced on array element} { catch {unset x} set info {} trace var x(0) rwu traceProc catch {set x(0)} set x(0) 22 set x(0) set x(0) 33 unset x(0) unset x set info } {x 0 r x 0 w x 0 r x 0 w x 0 u} test trace-5.3 {multiple ops traced on whole array} { catch {unset x} set info {} trace var x rwu traceProc catch {set x(0)} set x(0) 22 set x(0) set x(0) 33 unset x(0) unset x set info } {x 0 w x 0 r x 0 w x 0 u x {} u} # Check order of invocation of traces test trace-6.1 {order of invocation of traces} { catch {unset x} set info {} trace var x r "traceTag 1" trace var x r "traceTag 2" trace var x r "traceTag 3" catch {set x} set x 22 set x set info } {3 2 1 3 2 1} test trace-6.2 {order of invocation of traces} { catch {unset x} set x(0) 44 set info {} trace var x(0) r "traceTag 1" trace var x(0) r "traceTag 2" trace var x(0) r "traceTag 3" set x(0) set info } {3 2 1} test trace-6.3 {order of invocation of traces} { catch {unset x} set x(0) 44 set info {} trace var x(0) r "traceTag 1" trace var x r "traceTag A1" trace var x(0) r "traceTag 2" trace var x r "traceTag A2" trace var x(0) r "traceTag 3" trace var x r "traceTag A3" set x(0) set info } {A3 A2 A1 3 2 1} # Check effects of errors in trace procedures test trace-7.1 {error returns from traces} { catch {unset x} set x 123 set info {} trace var x r "traceTag 1" trace var x r traceError list [catch {set x} msg] $msg $info } {1 {can't read "x": trace returned error} {}} test trace-7.2 {error returns from traces} { catch {unset x} set x 123 set info {} trace var x w "traceTag 1" trace var x w traceError list [catch {set x 44} msg] $msg $info } {1 {can't set "x": trace returned error} {}} test trace-7.3 {error returns from traces} { catch {unset x} set x 123 set info {} trace var x r traceError trace var x w traceScalar list [catch {append x 44} msg] $msg $info } {1 {can't read "x": trace returned error} {}} test trace-7.4 {error returns from traces} { catch {unset x} set x 123 set info {} trace var x u "traceTag 1" trace var x u traceError list [catch {unset x} msg] $msg $info } {0 {} 1} test trace-7.5 {error returns from traces} { catch {unset x} set x(0) 123 set info {} trace var x(0) r "traceTag 1" trace var x r "traceTag 2" trace var x r traceError trace var x r "traceTag 3" list [catch {set x(0)} msg] $msg $info } {1 {can't read "x(0)": trace returned error} 3} test trace-7.6 {error returns from traces} { catch {unset x} set x 123 trace var x u traceError list [catch {unset x} msg] $msg } {0 {}} test trace-7.7 {error returns from traces} { # This test just makes sure that the memory for the error message # gets deallocated correctly when the trace is invoked again or # when the trace is deleted. catch {unset x} set x 123 trace var x r traceError catch {set x} catch {set x} trace vdelete x r traceError } {} # Check to see that variables are expunged before trace # procedures are invoked, so trace procedure can even manipulate # a new copy of the variables. test trace-8.1 {be sure variable is unset before trace is called} { catch {unset x} set x 33 set info {} trace var x u {traceCheck {uplevel set x}} unset x set info } {1 {can't read "x": no such variable}} test trace-8.2 {be sure variable is unset before trace is called} { catch {unset x} set x 33 set info {} trace var x u {traceCheck {uplevel set x 22}} unset x concat $info [list [catch {set x} msg] $msg] } {0 22 0 22} test trace-8.3 {be sure traces are cleared before unset trace called} { catch {unset x} set x 33 set info {} trace var x u {traceCheck {uplevel trace vinfo x}} unset x set info } {0 {}} test trace-8.4 {set new trace during unset trace} { catch {unset x} set x 33 set info {} trace var x u {traceCheck {global x; trace var x u traceProc}} unset x concat $info [trace vinfo x] } {0 {} {u traceProc}} test trace-9.1 {make sure array elements are unset before traces are called} { catch {unset x} set x(0) 33 set info {} trace var x(0) u {traceCheck {uplevel set x(0)}} unset x(0) set info } {1 {can't read "x(0)": no such element in array}} test trace-9.2 {make sure array elements are unset before traces are called} { catch {unset x} set x(0) 33 set info {} trace var x(0) u {traceCheck {uplevel set x(0) zzz}} unset x(0) concat $info [list [catch {set x(0)} msg] $msg] } {0 zzz 0 zzz} test trace-9.3 {array elements are unset before traces are called} { catch {unset x} set x(0) 33 set info {} trace var x(0) u {traceCheck {global x; trace vinfo x(0)}} unset x(0) set info } {0 {}} test trace-9.4 {set new array element trace during unset trace} { catch {unset x} set x(0) 33 set info {} trace var x(0) u {traceCheck {uplevel {trace variable x(0) r {}}}} catch {unset x(0)} concat $info [trace vinfo x(0)] } {0 {} {r {}}} test trace-10.1 {make sure arrays are unset before traces are called} { catch {unset x} set x(0) 33 set info {} trace var x u {traceCheck {uplevel set x(0)}} unset x set info } {1 {can't read "x(0)": no such variable}} test trace-10.2 {make sure arrays are unset before traces are called} { catch {unset x} set x(y) 33 set info {} trace var x u {traceCheck {uplevel set x(y) 22}} unset x concat $info [list [catch {set x(y)} msg] $msg] } {0 22 0 22} test trace-10.3 {make sure arrays are unset before traces are called} { catch {unset x} set x(y) 33 set info {} trace var x u {traceCheck {uplevel array exists x}} unset x set info } {0 0} test trace-10.4 {make sure arrays are unset before traces are called} { catch {unset x} set x(y) 33 set info {} set cmd {traceCheck {uplevel {trace vinfo x}}} trace var x u $cmd unset x set info } {0 {}} test trace-10.5 {set new array trace during unset trace} { catch {unset x} set x(y) 33 set info {} trace var x u {traceCheck {global x; trace var x r {}}} unset x concat $info [trace vinfo x] } {0 {} {r {}}} test trace-10.6 {create scalar during array unset trace} { catch {unset x} set x(y) 33 set info {} trace var x u {traceCheck {global x; set x 44}} unset x concat $info [list [catch {set x} msg] $msg] } {0 44 0 44} # Check special conditions (e.g. errors) in Tcl_TraceVar2. test trace-11.1 {creating array when setting variable traces} { catch {unset x} set info {} trace var x(0) w traceProc list [catch {set x 22} msg] $msg } {1 {can't set "x": variable is array}} test trace-11.2 {creating array when setting variable traces} { catch {unset x} set info {} trace var x(0) w traceProc list [catch {set x(0)} msg] $msg } {1 {can't read "x(0)": no such element in array}} test trace-11.3 {creating array when setting variable traces} { catch {unset x} set info {} trace var x(0) w traceProc set x(0) 22 set info } {x 0 w} test trace-11.4 {creating variable when setting variable traces} { catch {unset x} set info {} trace var x w traceProc list [catch {set x} msg] $msg } {1 {can't read "x": no such variable}} test trace-11.5 {creating variable when setting variable traces} { catch {unset x} set info {} trace var x w traceProc set x 22 set info } {x {} w} test trace-11.6 {creating variable when setting variable traces} { catch {unset x} set info {} trace var x w traceProc set x(0) 22 set info } {x 0 w} test trace-11.7 {create array element during read trace} { catch {unset x} set x(2) zzz trace var x r {traceCrtElement xyzzy} list [catch {set x(3)} msg] $msg } {0 xyzzy} test trace-11.8 {errors when setting variable traces} { catch {unset x} set x 44 list [catch {trace var x(0) w traceProc} msg] $msg } {1 {can't trace "x(0)": variable isn't array}} # Check deleting one trace from another. test trace-12.1 {delete one trace from another} { proc delTraces {args} { global x trace vdel x r {traceTag 2} trace vdel x r {traceTag 3} trace vdel x r {traceTag 4} } catch {unset x} set x 44 set info {} trace var x r {traceTag 1} trace var x r {traceTag 2} trace var x r {traceTag 3} trace var x r {traceTag 4} trace var x r delTraces trace var x r {traceTag 5} set x set info } {5 1} # Check operation and syntax of "trace" command. test trace-13.1 {trace command (overall)} { list [catch {trace} msg] $msg } {1 {too few args: should be "trace option [arg arg ...]"}} test trace-13.2 {trace command (overall)} { list [catch {trace gorp} msg] $msg } {1 {bad option "gorp": should be variable, vdelete, or vinfo}} test trace-13.3 {trace command ("variable" option)} { list [catch {trace variable x y} msg] $msg } {1 {wrong # args: should be "trace variable name ops command"}} test trace-13.4 {trace command ("variable" option)} { list [catch {trace var x y z z2} msg] $msg } {1 {wrong # args: should be "trace variable name ops command"}} test trace-13.5 {trace command ("variable" option)} { list [catch {trace var x y z} msg] $msg } {1 {bad operations "y": should be one or more of rwu}} test trace-13.6 {trace command ("vdelete" option)} { list [catch {trace vdelete x y} msg] $msg } {1 {wrong # args: should be "trace vdelete name ops command"}} test trace-13.7 {trace command ("vdelete" option)} { list [catch {trace vdelete x y z foo} msg] $msg } {1 {wrong # args: should be "trace vdelete name ops command"}} test trace-13.8 {trace command ("vdelete" option)} { list [catch {trace vdelete x y z} msg] $msg } {1 {bad operations "y": should be one or more of rwu}} test trace-13.9 {trace command ("vdelete" option)} { catch {unset x} set info {} trace var x w traceProc trace vdelete x w traceProc } {} test trace-13.10 {trace command ("vdelete" option)} { catch {unset x} set info {} trace var x w traceProc trace vdelete x w traceProc set x 12345 set info } {} test trace-13.11 {trace command ("vdelete" option)} { catch {unset x} set info {} trace var x w {traceTag 1} trace var x w traceProc trace var x w {traceTag 2} set x yy trace vdelete x w traceProc set x 12345 trace vdelete x w {traceTag 1} set x foo trace vdelete x w {traceTag 2} set x gorp set info } {2 x {} w 1 2 1 2} test trace-13.12 {trace command ("vdelete" option)} { catch {unset x} set info {} trace var x w {traceTag 1} trace vdelete x w non_existent set x 12345 set info } {1} test trace-13.13 {trace command ("vinfo" option)} { list [catch {trace vinfo} msg] $msg] } {1 {wrong # args: should be "trace vinfo name"]}} test trace-13.14 {trace command ("vinfo" option)} { list [catch {trace vinfo x y} msg] $msg] } {1 {wrong # args: should be "trace vinfo name"]}} test trace-13.15 {trace command ("vinfo" option)} { catch {unset x} trace var x w {traceTag 1} trace var x w traceProc trace var x w {traceTag 2} trace vinfo x } {{w {traceTag 2}} {w traceProc} {w {traceTag 1}}} test trace-13.16 {trace command ("vinfo" option)} { catch {unset x} trace vinfo x } {} test trace-13.17 {trace command ("vinfo" option)} { catch {unset x} trace vinfo x(0) } {} test trace-13.18 {trace command ("vinfo" option)} { catch {unset x} set x 44 trace vinfo x(0) } {} test trace-13.19 {trace command ("vinfo" option)} { catch {unset x} set x 44 trace var x w {traceTag 1} proc check {} {global x; trace vinfo x} check } {{w {traceTag 1}}} # Check fancy trace commands (long ones, weird arguments, etc.) test trace-14.1 {long trace command} { catch {unset x} set info {} trace var x w {traceTag {This is a very very long argument. It's \ designed to test out the facilities of TraceVarProc for dealing \ with such long arguments by malloc-ing space. One possibility \ is that space doesn't get freed properly. If this happens, then \ invoking this test over and over again will eventually leak memory.}} set x 44 set info } {This is a very very long argument. It's \ designed to test out the facilities of TraceVarProc for dealing \ with such long arguments by malloc-ing space. One possibility \ is that space doesn't get freed properly. If this happens, then \ invoking this test over and over again will eventually leak memory.} test trace-14.2 {long trace command result to ignore} { proc longResult {args} {return "quite a bit of text, designed to generate a core leak if this command file is invoked over and over again and memory isn't being recycled correctly"} catch {unset x} trace var x w longResult set x 44 set x 5 set x abcde } abcde test trace-14.3 {special list-handling in trace commands} { catch {unset "x y z"} set "x y z(a\n\{)" 44 set info {} trace var "x y z(a\n\{)" w traceProc set "x y z(a\n\{)" 33 set info } "{x y z} a\\n\\{ w" # Check for proper handling of unsets during traces. proc traceUnset {unsetName args} { global info upvar $unsetName x lappend info [catch {unset x} msg] $msg [catch {set x} msg] $msg } proc traceReset {unsetName resetName args} { global info upvar $unsetName x $resetName y lappend info [catch {unset x} msg] $msg [catch {set y xyzzy} msg] $msg } proc traceReset2 {unsetName resetName args} { global info lappend info [catch {uplevel unset $unsetName} msg] $msg \ [catch {uplevel set $resetName xyzzy} msg] $msg } proc traceAppend {string name1 name2 op} { global info lappend info $string } test trace-15.1 {unsets during read traces} { catch {unset y} set y 1234 set info {} trace var y r {traceUnset y} trace var y u {traceAppend unset} lappend info [catch {set y} msg] $msg } {unset 0 {} 1 {can't read "x": no such variable} 1 {can't read "y": no such variable}} test trace-15.2 {unsets during read traces} { catch {unset y} set y(0) 1234 set info {} trace var y(0) r {traceUnset y(0)} lappend info [catch {set y(0)} msg] $msg } {0 {} 1 {can't read "x": no such variable} 1 {can't read "y(0)": no such element in array}} test trace-15.3 {unsets during read traces} { catch {unset y} set y(0) 1234 set info {} trace var y(0) r {traceUnset y} lappend info [catch {set y(0)} msg] $msg } {0 {} 1 {can't read "x": no such variable} 1 {can't read "y(0)": no such variable}} test trace-15.4 {unsets during read traces} { catch {unset y} set y 1234 set info {} trace var y r {traceReset y y} lappend info [catch {set y} msg] $msg } {0 {} 0 xyzzy 0 xyzzy} test trace-15.5 {unsets during read traces} { catch {unset y} set y(0) 1234 set info {} trace var y(0) r {traceReset y(0) y(0)} lappend info [catch {set y(0)} msg] $msg } {0 {} 0 xyzzy 0 xyzzy} test trace-15.6 {unsets during read traces} { catch {unset y} set y(0) 1234 set info {} trace var y(0) r {traceReset y y(0)} lappend info [catch {set y(0)} msg] $msg [catch {set y(0)} msg] $msg } {0 {} 1 {can't set "y": upvar refers to element in deleted array} 1 {can't read "y(0)": no such variable} 1 {can't read "y(0)": no such variable}} test trace-15.7 {unsets during read traces} { catch {unset y} set y(0) 1234 set info {} trace var y(0) r {traceReset2 y y(0)} lappend info [catch {set y(0)} msg] $msg [catch {set y(0)} msg] $msg } {0 {} 0 xyzzy 1 {can't read "y(0)": no such element in array} 0 xyzzy} test trace-15.8 {unsets during write traces} { catch {unset y} set y 1234 set info {} trace var y w {traceUnset y} trace var y u {traceAppend unset} lappend info [catch {set y xxx} msg] $msg } {unset 0 {} 1 {can't read "x": no such variable} 0 {}} test trace-15.9 {unsets during write traces} { catch {unset y} set y(0) 1234 set info {} trace var y(0) w {traceUnset y(0)} lappend info [catch {set y(0) xxx} msg] $msg } {0 {} 1 {can't read "x": no such variable} 0 {}} test trace-15.10 {unsets during write traces} { catch {unset y} set y(0) 1234 set info {} trace var y(0) w {traceUnset y} lappend info [catch {set y(0) xxx} msg] $msg } {0 {} 1 {can't read "x": no such variable} 0 {}} test trace-15.11 {unsets during write traces} { catch {unset y} set y 1234 set info {} trace var y w {traceReset y y} lappend info [catch {set y xxx} msg] $msg } {0 {} 0 xyzzy 0 xyzzy} test trace-15.12 {unsets during write traces} { catch {unset y} set y(0) 1234 set info {} trace var y(0) w {traceReset y(0) y(0)} lappend info [catch {set y(0) xxx} msg] $msg } {0 {} 0 xyzzy 0 xyzzy} test trace-15.13 {unsets during write traces} { catch {unset y} set y(0) 1234 set info {} trace var y(0) w {traceReset y y(0)} lappend info [catch {set y(0) xxx} msg] $msg [catch {set y(0)} msg] $msg } {0 {} 1 {can't set "y": upvar refers to element in deleted array} 0 {} 1 {can't read "y(0)": no such variable}} test trace-15.14 {unsets during write traces} { catch {unset y} set y(0) 1234 set info {} trace var y(0) w {traceReset2 y y(0)} lappend info [catch {set y(0) xxx} msg] $msg [catch {set y(0)} msg] $msg } {0 {} 0 xyzzy 0 {} 0 xyzzy} test trace-15.15 {unsets during unset traces} { catch {unset y} set y 1234 set info {} trace var y u {traceUnset y} lappend info [catch {unset y} msg] $msg [catch {set y} msg] $msg } {1 {can't unset "x": no such variable} 1 {can't read "x": no such variable} 0 {} 1 {can't read "y": no such variable}} test trace-15.16 {unsets during unset traces} { catch {unset y} set y(0) 1234 set info {} trace var y(0) u {traceUnset y(0)} lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg } {1 {can't unset "x": no such variable} 1 {can't read "x": no such variable} 0 {} 1 {can't read "y(0)": no such element in array}} test trace-15.17 {unsets during unset traces} { catch {unset y} set y(0) 1234 set info {} trace var y(0) u {traceUnset y} lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg } {0 {} 1 {can't read "x": no such variable} 0 {} 1 {can't read "y(0)": no such variable}} test trace-15.18 {unsets during unset traces} { catch {unset y} set y 1234 set info {} trace var y u {traceReset2 y y} lappend info [catch {unset y} msg] $msg [catch {set y} msg] $msg } {1 {can't unset "y": no such variable} 0 xyzzy 0 {} 0 xyzzy} test trace-15.19 {unsets during unset traces} { catch {unset y} set y(0) 1234 set info {} trace var y(0) u {traceReset2 y(0) y(0)} lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg } {1 {can't unset "y(0)": no such element in array} 0 xyzzy 0 {} 0 xyzzy} test trace-15.20 {unsets during unset traces} { catch {unset y} set y(0) 1234 set info {} trace var y(0) u {traceReset2 y y(0)} lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg } {0 {} 0 xyzzy 0 {} 0 xyzzy} test trace-15.21 {unsets cancelling traces} { catch {unset y} set y 1234 set info {} trace var y r {traceAppend first} trace var y r {traceUnset y} trace var y r {traceAppend third} trace var y u {traceAppend unset} lappend info [catch {set y} msg] $msg } {third unset 0 {} 1 {can't read "x": no such variable} 1 {can't read "y": no such variable}} test trace-15.22 {unsets cancelling traces} { catch {unset y} set y(0) 1234 set info {} trace var y(0) r {traceAppend first} trace var y(0) r {traceUnset y} trace var y(0) r {traceAppend third} trace var y(0) u {traceAppend unset} lappend info [catch {set y(0)} msg] $msg } {third unset 0 {} 1 {can't read "x": no such variable} 1 {can't read "y(0)": no such variable}} # Check various non-interference between traces and other things. test trace-16.1 {trace doesn't prevent unset errors} { catch {unset x} set info {} trace var x u {traceProc} list [catch {unset x} msg] $msg $info } {1 {can't unset "x": no such variable} {x {} u}} test trace-16.2 {traced variables must survive procedure exits} { catch {unset x} proc p1 {} {global x; trace var x w traceProc} p1 trace vinfo x } {{w traceProc}} test trace-16.3 {traced variables must survive procedure exits} { catch {unset x} set info {} proc p1 {} {global x; trace var x w traceProc} p1 set x 44 set info } {x {} w} # Be sure that procedure frames are released before unset traces # are invoked. test trace-17.1 {unset traces on procedure returns} { proc p1 {x y} {set a 44; p2 14} proc p2 {z} {trace var z u {traceCheck {lsort [uplevel {info vars}]}}} set info {} p1 foo bar set info } {0 {a x y}} # Delete arrays when done, so they can be re-used as scalars # elsewhere. catch {unset x} catch {unset y} concat {} ]}} test trace-13.14 {trace command ("vinfo" option)} { list [catch {trace vinfo x y} msg] $msg] } {1 {wrong # args: should be "trace vinfo name"]}} test trace-13.15 {trace command ("vinfo" option)} { catch {unset x} trace var x w {traceTag 1} trace var x w tractcl7.4b4/tests/all010044400630510000012000000005350564727514100146750ustar00ousterstaff00002300000001# This file contains a top-level script to run all of the Tcl # tests. Execute it by invoking "source all" when running tclTest # in this directory. # # @(#) all 1.5 94/08/10 10:26:33 foreach i [lsort [glob *.test]] { if [string match l.*.test $i] { # This is an SCCS lock file; ignore it. continue } puts stdout $i source $i } tcl7.4b4/tests/unknown.test010044400630510000012000000033220567470012500165720ustar00ousterstaff00002300000001# Commands covered: unknown # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # @(#) unknown.test 1.10 94/12/17 16:20:30 if {[string compare test [info procs test]] == 1} then {source defs} catch {rename unknown unknown.old} test unknown-1.1 {non-existent "unknown" command} { list [catch {_non-existent_ foo bar} msg] $msg } {1 {invalid command name "_non-existent_"}} proc unknown {args} { global x set x $args } test unknown-2.1 {calling "unknown" command} { foobar x y z set x } {foobar x y z} test unknown-2.2 {calling "unknown" command with lots of args} { foobar 1 2 3 4 5 6 7 set x } {foobar 1 2 3 4 5 6 7} test unknown-2.3 {calling "unknown" command with lots of args} { foobar 1 2 3 4 5 6 7 8 set x } {foobar 1 2 3 4 5 6 7 8} test unknown-2.4 {calling "unknown" command with lots of args} { foobar 1 2 3 4 5 6 7 8 9 set x } {foobar 1 2 3 4 5 6 7 8 9} test unknown-3.1 {argument quoting in calls to "unknown"} { foobar \{ \} a\{b \; "\\" \$a a\[b \] set x } "foobar \\{ \\} a\\{b {;} \\\\ {\$a} {a\[b} \\]" proc unknown args { error "unknown failed" } test unknown-4.1 {errors in "unknown" procedure} { list [catch {non-existent a b} msg] $msg $errorCode } {1 {unknown failed} NONE} catch {rename unknown {}} catch {rename unknown.old unknown} return {} tcl7.4b4/tests/uplevel.test010044400630510000012000000053050567470012500165520ustar00ousterstaff00002300000001# Commands covered: uplevel # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # @(#) uplevel.test 1.12 94/12/17 16:20:31 if {[string compare test [info procs test]] == 1} then {source defs} proc a {x y} { newset z [expr $x+$y] return $z } proc newset {name value} { uplevel set $name $value uplevel 1 {uplevel 1 {set xyz 22}} } test uplevel-1.1 {simple operation} { set xyz 0 a 22 33 } 55 test uplevel-1.2 {command is another uplevel command} { set xyz 0 a 22 33 set xyz } 22 proc a1 {} { b1 global a a1 set a $x set a1 $y } proc b1 {} { c1 global b b1 set b $x set b1 $y } proc c1 {} { uplevel 1 set x 111 uplevel #2 set y 222 uplevel 2 set x 333 uplevel #1 set y 444 uplevel 3 set x 555 uplevel #0 set y 666 } a1 test uplevel-2.1 {relative and absolute uplevel} {set a} 333 test uplevel-2.2 {relative and absolute uplevel} {set a1} 444 test uplevel-2.3 {relative and absolute uplevel} {set b} 111 test uplevel-2.4 {relative and absolute uplevel} {set b1} 222 test uplevel-2.5 {relative and absolute uplevel} {set x} 555 test uplevel-2.6 {relative and absolute uplevel} {set y} 666 test uplevel-3.1 {uplevel to same level} { set x 33 uplevel #0 set x 44 set x } 44 test uplevel-3.2 {uplevel to same level} { set x 33 uplevel 0 set x } 33 test uplevel-3.3 {uplevel to same level} { set y xxx proc a1 {} {set y 55; uplevel 0 set y 66; return $y} a1 } 66 test uplevel-3.4 {uplevel to same level} { set y zzz proc a1 {} {set y 55; uplevel #1 set y} a1 } 55 test uplevel-4.1 {error: non-existent level} { list [catch c1 msg] $msg } {1 {bad level "#2"}} test uplevel-4.2 {error: non-existent level} { proc c2 {} {uplevel 3 {set a b}} list [catch c2 msg] $msg } {1 {bad level "3"}} test uplevel-4.3 {error: not enough args} { list [catch uplevel msg] $msg } {1 {wrong # args: should be "uplevel ?level? command ?arg ...?"}} test uplevel-4.4 {error: not enough args} { proc upBug {} {uplevel 1} list [catch upBug msg] $msg } {1 {wrong # args: should be "uplevel ?level? command ?arg ...?"}} proc a2 {} { uplevel a3 } proc a3 {} { global x y set x [info level] set y [info level 1] } a2 test uplevel-5.1 {info level} {set x} 1 test uplevel-5.2 {info level} {set y} a3 tcl7.4b4/tests/upvar.test010044400630510000012000000203000567470012500162230ustar00ousterstaff00002300000001# Commands covered: upvar # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # @(#) upvar.test 1.7 94/12/17 16:20:32 if {[string compare test [info procs test]] == 1} then {source defs} test upvar-1.1 {reading variables with upvar} { proc p1 {a b} {set c 22; set d 33; p2} proc p2 {} {upvar a x1 b x2 c x3 d x4; set a abc; list $x1 $x2 $x3 $x4 $a} p1 foo bar } {foo bar 22 33 abc} test upvar-1.2 {reading variables with upvar} { proc p1 {a b} {set c 22; set d 33; p2} proc p2 {} {p3} proc p3 {} {upvar 2 a x1 b x2 c x3 d x4; set a abc; list $x1 $x2 $x3 $x4 $a} p1 foo bar } {foo bar 22 33 abc} test upvar-1.3 {reading variables with upvar} { proc p1 {a b} {set c 22; set d 33; p2} proc p2 {} {p3} proc p3 {} { upvar #1 a x1 b x2 c x3 d x4 set a abc list $x1 $x2 $x3 $x4 $a } p1 foo bar } {foo bar 22 33 abc} test upvar-1.4 {reading variables with upvar} { set x1 44 set x2 55 proc p1 {} {p2} proc p2 {} { upvar 2 x1 x1 x2 a upvar #0 x1 b set c $b incr b 3 list $x1 $a $b } p1 } {47 55 47} test upvar-1.4 {reading array elements with upvar} { proc p1 {} {set a(0) zeroth; set a(1) first; p2} proc p2 {} {upvar a(0) x; set x} p1 } {zeroth} test upvar-2.1 {writing variables with upvar} { proc p1 {a b} {set c 22; set d 33; p2; list $a $b $c $d} proc p2 {} { upvar a x1 b x2 c x3 d x4 set x1 14 set x4 88 } p1 foo bar } {14 bar 22 88} test upvar-2.2 {writing variables with upvar} { set x1 44 set x2 55 proc p1 {x1 x2} { upvar #0 x1 a upvar x2 b set a $x1 set b $x2 } p1 newbits morebits list $x1 $x2 } {newbits morebits} test upvar-2.3 {writing variables with upvar} { catch {unset x1} catch {unset x2} proc p1 {x1 x2} { upvar #0 x1 a upvar x2 b set a $x1 set b $x2 } p1 newbits morebits list [catch {set x1} msg] $msg [catch {set x2} msg] $msg } {0 newbits 0 morebits} test upvar-2.4 {writing array elements with upvar} { proc p1 {} {set a(0) zeroth; set a(1) first; list [p2] $a(0)} proc p2 {} {upvar a(0) x; set x xyzzy} p1 } {xyzzy xyzzy} test upvar-3.1 {unsetting variables with upvar} { proc p1 {a b} {set c 22; set d 33; p2; lsort [info vars]} proc p2 {} { upvar 1 a x1 d x2 unset x1 x2 } p1 foo bar } {b c} test upvar-3.2 {unsetting variables with upvar} { proc p1 {a b} {set c 22; set d 33; p2; lsort [info vars]} proc p2 {} { upvar 1 a x1 d x2 unset x1 x2 set x2 28 } p1 foo bar } {b c d} test upvar-3.3 {unsetting variables with upvar} { set x1 44 set x2 55 proc p1 {} {p2} proc p2 {} { upvar 2 x1 a upvar #0 x2 b unset a b } p1 list [info exists x1] [info exists x2] } {0 0} test upvar-3.4 {unsetting variables with upvar} { set x1 44 set x2 55 proc p1 {} { upvar x1 a x2 b unset a b set b 118 } p1 list [info exists x1] [catch {set x2} msg] $msg } {0 0 118} test upvar-3.5 {unsetting array elements with upvar} { proc p1 {} { set a(0) zeroth set a(1) first set a(2) second p2 array names a } proc p2 {} {upvar a(0) x; unset x} p1 } {1 2} test upvar-3.6 {unsetting then resetting array elements with upvar} { proc p1 {} { set a(0) zeroth set a(1) first set a(2) second p2 list [array names a] [catch {set a(0)} msg] $msg } proc p2 {} {upvar a(0) x; unset x; set x 12345} p1 } {{0 1 2} 0 12345} test upvar-4.1 {nested upvars} { set x1 88 proc p1 {a b} {set c 22; set d 33; p2} proc p2 {} {global x1; upvar c x2; p3} proc p3 {} { upvar x1 a x2 b list $a $b } p1 14 15 } {88 22} test upvar-4.2 {nested upvars} { set x1 88 proc p1 {a b} {set c 22; set d 33; p2; list $a $b $c $d} proc p2 {} {global x1; upvar c x2; p3} proc p3 {} { upvar x1 a x2 b set a foo set b bar } list [p1 14 15] $x1 } {{14 15 bar 33} foo} proc tproc {args} {global x; set x [list $args [uplevel info vars]]} test upvar-5.1 {traces involving upvars} { proc p1 {a b} {set c 22; set d 33; trace var c rw tproc; p2} proc p2 {} {upvar c x1; set x1 22} set x --- p1 foo bar set x } {{x1 {} w} x1} test upvar-5.2 {traces involving upvars} { proc p1 {a b} {set c 22; set d 33; trace var c rw tproc; p2} proc p2 {} {upvar c x1; set x1} set x --- p1 foo bar set x } {{x1 {} r} x1} test upvar-5.3 {traces involving upvars} { proc p1 {a b} {set c 22; set d 33; trace var c rwu tproc; p2} proc p2 {} {upvar c x1; unset x1} set x --- p1 foo bar set x } {{x1 {} u} x1} test upvar-6.1 {retargeting an upvar} { proc p1 {} { set a(0) zeroth set a(1) first set a(2) second p2 } proc p2 {} { upvar a x set result {} foreach i [array names x] { upvar a($i) x lappend result $x } lsort $result } p1 } {first second zeroth} test upvar-6.2 {retargeting an upvar} { set x 44 set y abcde proc p1 {} { global x set result $x upvar y x lappend result $x } p1 } {44 abcde} test upvar-6.3 {retargeting an upvar} { set x 44 set y abcde proc p1 {} { upvar y x lappend result $x global x lappend result $x } p1 } {abcde 44} test upvar-7.1 {upvar to same level} { set x 44 set y 55 catch {unset uv} upvar #0 x uv set uv abc upvar 0 y uv set uv xyzzy list $x $y } {abc xyzzy} test upvar-7.2 {upvar to same level} { set x 1234 set y 4567 proc p1 {x y} { upvar 0 x uv set uv $y return "$x $y" } p1 44 89 } {89 89} test upvar-7.3 {upvar to same level} { set x 1234 set y 4567 proc p1 {x y} { upvar #1 x uv set uv $y return "$x $y" } p1 xyz abc } {abc abc} test upvar-8.1 {errors in upvar command} { list [catch upvar msg] $msg } {1 {wrong # args: should be "upvar ?level? otherVar localVar ?otherVar localVar ...?"}} test upvar-8.2 {errors in upvar command} { list [catch {upvar 1} msg] $msg } {1 {wrong # args: should be "upvar ?level? otherVar localVar ?otherVar localVar ...?"}} test upvar-8.3 {errors in upvar command} { proc p1 {} {upvar a b c} list [catch p1 msg] $msg } {1 {wrong # args: should be "upvar ?level? otherVar localVar ?otherVar localVar ...?"}} test upvar-8.4 {errors in upvar command} { proc p1 {} {set a 33; upvar b a} list [catch p1 msg] $msg } {1 {variable "a" already exists}} test upvar-8.5 {errors in upvar command} { proc p1 {} {upvar 0 b b} list [catch p1 msg] $msg } {1 {can't upvar from variable to itself}} test upvar-8.6 {errors in upvar command} { proc p1 {} {upvar 0 a b; upvar 0 b a} list [catch p1 msg] $msg } {1 {can't upvar from variable to itself}} if {[info commands testupvar] != {}} { test upvar-9.1 {Tcl_UpVar2 procedure} { list [catch {testupvar xyz a {} x global} msg] $msg } {1 {bad level "xyz"}} test upvar-9.2 {Tcl_UpVar2 procedure} { catch {unset a} catch {unset x} set a 44 list [catch {testupvar #0 a 1 x global} msg] $msg } {1 {can't access "a(1)": variable isn't array}} test upvar-9.3 {Tcl_UpVar2 procedure} { proc foo {} { testupvar 1 a {} x local set x } catch {unset a} catch {unset x} set a 44 foo } {44} test upvar-9.4 {Tcl_UpVar2 procedure} { proc foo {} { testupvar 1 a {} _up_ global list [catch {set x} msg] $msg } catch {unset a} catch {unset _up_} set a 44 concat [foo] $_up_ } {1 {can't read "x": no such variable} 44} test upvar-9.5 {Tcl_UpVar2 procedure} { proc foo {} { testupvar 1 a b x local set x } catch {unset a} catch {unset x} set a(b) 1234 foo } {1234} test upvar-9.6 {Tcl_UpVar procedure} { proc foo {} { testupvar 1 a x local set x } catch {unset a} catch {unset x} set a xyzzy foo } {xyzzy} test upvar-9.7 {Tcl_UpVar procedure} { proc foo {} { testupvar #0 a(b) x local set x } catch {unset a} catch {unset x} set a(b) 1234 foo } {1234} } catch {unset a} concat 33; p2; list $a $b $c $d} proc p2 {} { upvar a x1 b x2 c x3 d x4 set x1 14 set x4 88 } p1 foo bar } {14 bar 22 88} test upvar-2.2 {writing variables with upvar} { set x1 44 set x2 55 proc p1 {x1 x2} { upvar #0 x1 a upvar x2 b set a $x1 set b $x2 } p1 newbits morebits list $x1tcl7.4b4/tests/while.test010044400630510000012000000053160567470012500162100ustar00ousterstaff00002300000001# Commands covered: while # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # @(#) while.test 1.8 94/12/17 16:20:33 if {[string compare test [info procs test]] == 1} then {source defs} test while-1.1 {basic while loops} { set count 0 while {$count < 10} {set count [expr $count+1]} set count } 10 test while-1.2 {basic while loops} { set value xxx while {2 > 3} {set value yyy} set value } xxx test while-1.3 {basic while loops} { set value 1 while {"true"} { incr value; if {$value > 5} { break; } } set value } 6 test while-2.1 {continue in while loop} { set list {1 2 3 4 5} set index 0 set result {} while {$index < 5} { if {$index == 2} {set index [expr $index+1]; continue} set result [concat $result [lindex $list $index]] set index [expr $index+1] } set result } {1 2 4 5} test while-3.1 {break in while loop} { set list {1 2 3 4 5} set index 0 set result {} while {$index < 5} { if {$index == 3} break set result [concat $result [lindex $list $index]] set index [expr $index+1] } set result } {1 2 3} test while-4.1 {errors in while loops} { set err [catch {while} msg] list $err $msg } {1 {wrong # args: should be "while test command"}} test while-4.2 {errors in while loops} { set err [catch {while 1} msg] list $err $msg } {1 {wrong # args: should be "while test command"}} test while-4.3 {errors in while loops} { set err [catch {while 1 2 3} msg] list $err $msg } {1 {wrong # args: should be "while test command"}} test while-4.4 {errors in while loops} { set err [catch {while {"a"+"b"} {error "loop aborted"}} msg] list $err $msg } {1 {can't use non-numeric string as operand of "+"}} test while-4.5 {errors in while loops} { set x 1 set err [catch {while {$x} {set x foo}} msg] list $err $msg } {1 {expected boolean value but got "foo"}} test while-4.6 {errors in while loops} { set err [catch {while {1} {error "loop aborted"}} msg] list $err $msg $errorInfo } {1 {loop aborted} {loop aborted while executing "error "loop aborted"" ("while" body line 1) invoked from within "while {1} {error "loop aborted"}"}} test while-5.1 {while return result} { while {0} {set a 400} } {} test while-5.2 {while return result} { set x 1 while {$x} {set x 0} } {} tcl7.4b4/tests/defs010044400630510000012000000066200575714741300150510ustar00ousterstaff00002300000001# This file contains support code for the Tcl test suite. It is # normally sourced by the individual files in the test suite before # they run their tests. This improved approach to testing was designed # and initially implemented by Mary Ann May-Pumphrey of Sun Microsystems. # # Copyright (c) 1990-1994 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # @(#) defs 1.4 95/05/19 10:02:04 if ![info exists VERBOSE] { set VERBOSE 0 } if ![info exists TESTS] { set TESTS {} } # If tests are being run as root, issue a warning message and set a # variable to prevent some tests from running at all. set user {} catch {set user [exec whoami]} if {$user == "root"} { puts stdout "Warning: you're executing as root. I'll have to" puts stdout "skip some of the tests, since they'll fail as root." } # Some of the tests don't work on some system configurations due to # differences in word length, file system configuration, etc. In order # to prevent false alarms, these tests are generally only run in the # master development directory for Tcl. The presence of a file # "doAllTests" in this directory is used to indicate that the non-portable # tests should be run. set doNonPortableTests [file exists doAllTests] # If there is no "memory" command (because memory debugging isn't # enabled), generate a dummy command that does nothing. if {[info commands memory] == ""} { proc memory args {} } proc print_verbose {test_name test_description contents_of_test code answer} { puts stdout "\n" puts stdout "==== $test_name $test_description" puts stdout "==== Contents of test case:" puts stdout "$contents_of_test" if {$code != 0} { if {$code == 1} { puts stdout "==== Test generated error:" puts stdout $answer } elseif {$code == 2} { puts stdout "==== Test generated return exception; result was:" puts stdout $answer } elseif {$code == 3} { puts stdout "==== Test generated break exception" } elseif {$code == 4} { puts stdout "==== Test generated continue exception" } else { puts stdout "==== Test generated exception $code; message was:" puts stdout $answer } } else { puts stdout "==== Result was:" puts stdout "$answer" } } proc test {test_name test_description contents_of_test passing_results} { global VERBOSE global TESTS if {[string compare $TESTS ""] != 0} then { set ok 0 foreach test $TESTS { if [string match $test $test_name] then { set ok 1 break } } if !$ok then return } memory tag $test_name set code [catch {uplevel $contents_of_test} answer] if {$code != 0} { print_verbose $test_name $test_description $contents_of_test \ $code $answer } elseif {[string compare $answer $passing_results] == 0} then { if $VERBOSE then { print_verbose $test_name $test_description $contents_of_test \ $code $answer puts stdout "++++ $test_name PASSED" } } else { print_verbose $test_name $test_description $contents_of_test $code \ $answer puts stdout "---- Result should have been:" puts stdout "$passing_results" puts stdout "---- $test_name FAILED" } } proc dotests {file args} { global TESTS set savedTests $TESTS set TESTS $args source $file set TESTS $savedTests }