aboutsummaryrefslogtreecommitdiffstats
path: root/contrib/tcl/generic
diff options
context:
space:
mode:
authorPoul-Henning Kamp <phk@FreeBSD.org>1996-06-26 06:06:43 +0000
committerPoul-Henning Kamp <phk@FreeBSD.org>1996-06-26 06:06:43 +0000
commit403acdc0da2969f284b74b720692585bfc676190 (patch)
tree4d70f77f44120e6541d1418223baf06562774975 /contrib/tcl/generic
downloadsrc-403acdc0da2969f284b74b720692585bfc676190.tar.gz
src-403acdc0da2969f284b74b720692585bfc676190.zip
Tcl 7.5, various makefiles will be updated to use these sources as soonvendor/tcl/7.5
as I get these back down to my machine.
Notes
Notes: svn path=/vendor/tcl/dist/; revision=16756 svn path=/vendor/tcl/7.5/; revision=16758; tag=vendor/tcl/7.5
Diffstat (limited to 'contrib/tcl/generic')
-rw-r--r--contrib/tcl/generic/README5
-rw-r--r--contrib/tcl/generic/panic.c92
-rw-r--r--contrib/tcl/generic/patchlevel.h23
-rw-r--r--contrib/tcl/generic/regexp.c1335
-rw-r--r--contrib/tcl/generic/tcl.h1047
-rw-r--r--contrib/tcl/generic/tclAsync.c265
-rw-r--r--contrib/tcl/generic/tclBasic.c1826
-rw-r--r--contrib/tcl/generic/tclCkalloc.c738
-rw-r--r--contrib/tcl/generic/tclClock.c353
-rw-r--r--contrib/tcl/generic/tclCmdAH.c1678
-rw-r--r--contrib/tcl/generic/tclCmdIL.c1487
-rw-r--r--contrib/tcl/generic/tclCmdMZ.c2107
-rw-r--r--contrib/tcl/generic/tclDate.c1619
-rw-r--r--contrib/tcl/generic/tclEnv.c604
-rw-r--r--contrib/tcl/generic/tclEvent.c2187
-rw-r--r--contrib/tcl/generic/tclExpr.c2055
-rw-r--r--contrib/tcl/generic/tclFHandle.c254
-rw-r--r--contrib/tcl/generic/tclFileName.c1591
-rw-r--r--contrib/tcl/generic/tclGet.c232
-rw-r--r--contrib/tcl/generic/tclGetDate.y937
-rw-r--r--contrib/tcl/generic/tclHash.c921
-rw-r--r--contrib/tcl/generic/tclHistory.c1096
-rw-r--r--contrib/tcl/generic/tclIO.c5055
-rw-r--r--contrib/tcl/generic/tclIOCmd.c1510
-rw-r--r--contrib/tcl/generic/tclIOSock.c96
-rw-r--r--contrib/tcl/generic/tclIOUtil.c1287
-rw-r--r--contrib/tcl/generic/tclInt.h1075
-rw-r--r--contrib/tcl/generic/tclInterp.c2385
-rw-r--r--contrib/tcl/generic/tclLink.c390
-rw-r--r--contrib/tcl/generic/tclLoad.c600
-rw-r--r--contrib/tcl/generic/tclLoadNone.c81
-rw-r--r--contrib/tcl/generic/tclMain.c347
-rw-r--r--contrib/tcl/generic/tclNotify.c578
-rw-r--r--contrib/tcl/generic/tclParse.c1386
-rw-r--r--contrib/tcl/generic/tclPkg.c732
-rw-r--r--contrib/tcl/generic/tclPort.h29
-rw-r--r--contrib/tcl/generic/tclPosixStr.c1174
-rw-r--r--contrib/tcl/generic/tclPreserve.c275
-rw-r--r--contrib/tcl/generic/tclProc.c658
-rw-r--r--contrib/tcl/generic/tclRegexp.h40
-rw-r--r--contrib/tcl/generic/tclTest.c1932
-rw-r--r--contrib/tcl/generic/tclUtil.c2133
-rw-r--r--contrib/tcl/generic/tclVar.c2575
43 files changed, 46790 insertions, 0 deletions
diff --git a/contrib/tcl/generic/README b/contrib/tcl/generic/README
new file mode 100644
index 000000000000..4b3aa4fcf4ca
--- /dev/null
+++ b/contrib/tcl/generic/README
@@ -0,0 +1,5 @@
+This directory contains Tcl source files that work on all the platforms
+where Tcl runs (e.g. UNIX, PCs, and Macintoshes). Platform-specific
+sources are in the directories ../unix, ../win, and ../mac.
+
+SCCS ID: @(#) README 1.1 95/09/11 14:02:13
diff --git a/contrib/tcl/generic/panic.c b/contrib/tcl/generic/panic.c
new file mode 100644
index 000000000000..4ad98fd06573
--- /dev/null
+++ b/contrib/tcl/generic/panic.c
@@ -0,0 +1,92 @@
+/*
+ * 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.
+ *
+ * SCCS: @(#) panic.c 1.11 96/02/15 11:50:29
+ */
+
+#include <stdio.h>
+#ifdef NO_STDLIB_H
+# include "../compat/stdlib.h"
+#else
+# include <stdlib.h>
+#endif
+
+#include "tcl.h"
+
+/*
+ * The panicProc variable contains a pointer to an application
+ * specific panic procedure.
+ */
+
+void (*panicProc) _ANSI_ARGS_(TCL_VARARGS(char *,format)) = NULL;
+
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_SetPanicProc --
+ *
+ * Replace the default panic behavior with the specified functiion.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Sets the panicProc variable.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_SetPanicProc(proc)
+ void (*proc) _ANSI_ARGS_(TCL_VARARGS(char *,format));
+{
+ panicProc = proc;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+{
+ if (panicProc != NULL) {
+ (void) (*panicProc)(format, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8);
+ } else {
+ (void) fprintf(stderr, format, arg1, arg2, arg3, arg4, arg5, arg6,
+ arg7, arg8);
+ (void) fprintf(stderr, "\n");
+ (void) fflush(stderr);
+ abort();
+ }
+}
diff --git a/contrib/tcl/generic/patchlevel.h b/contrib/tcl/generic/patchlevel.h
new file mode 100644
index 000000000000..2482cd3ed882
--- /dev/null
+++ b/contrib/tcl/generic/patchlevel.h
@@ -0,0 +1,23 @@
+/*
+ * 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 or "aZ for alpha
+ * 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-1996 Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * SCCS: @(#) patchlevel.h 1.17 96/04/08 14:15:07
+ */
+
+#define TCL_PATCH_LEVEL "7.5"
diff --git a/contrib/tcl/generic/regexp.c b/contrib/tcl/generic/regexp.c
new file mode 100644
index 000000000000..52e5a51e2d52
--- /dev/null
+++ b/contrib/tcl/generic/regexp.c
@@ -0,0 +1,1335 @@
+/*
+ * 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 errMsg 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. ***
+ *
+ * SCCS: @(#) regexp.c 1.12 96/04/02 13:54:57
+ */
+
+#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 *errMsg = 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 (OPEN+NSUBEXP) /* 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; &regdummy = 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.
+ */
+
+static char * reg _ANSI_ARGS_((int paren, int *flagp,
+ struct regcomp_state *rcstate));
+static char * regatom _ANSI_ARGS_((int *flagp,
+ struct regcomp_state *rcstate));
+static char * regbranch _ANSI_ARGS_((int *flagp,
+ struct regcomp_state *rcstate));
+static void regc _ANSI_ARGS_((int b,
+ struct regcomp_state *rcstate));
+static void reginsert _ANSI_ARGS_((int op, char *opnd,
+ struct regcomp_state *rcstate));
+static char * regnext _ANSI_ARGS_((char *p));
+static char * regnode _ANSI_ARGS_((int op,
+ struct regcomp_state *rcstate));
+static void regoptail _ANSI_ARGS_((char *p, char *val));
+static char * regpiece _ANSI_ARGS_((int *flagp,
+ struct regcomp_state *rcstate));
+static void regtail _ANSI_ARGS_((char *p, char *val));
+
+#ifdef STRCSPN
+static int strcspn _ANSI_ARGS_((char *s1, char *s2));
+#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 = &regdummy;
+ 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((char)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)
+int op;
+struct regcomp_state *rcstate;
+{
+ register char *ret;
+ register char *ptr;
+
+ ret = rcstate->regcode;
+ if (ret == &regdummy) {
+ rcstate->regsize += 3;
+ return(ret);
+ }
+
+ ptr = ret;
+ *ptr++ = (char)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)
+int b;
+struct regcomp_state *rcstate;
+{
+ if (rcstate->regcode != &regdummy)
+ *rcstate->regcode++ = (char)b;
+ else
+ rcstate->regsize++;
+}
+
+/*
+ - reginsert - insert an operator in front of already-emitted operand
+ *
+ * Means relocating the operand.
+ */
+static void
+reginsert(op, opnd, rcstate)
+int op;
+char *opnd;
+struct regcomp_state *rcstate;
+{
+ register char *src;
+ register char *dst;
+ register char *place;
+
+ if (rcstate->regcode == &regdummy) {
+ 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++ = (char)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 == &regdummy)
+ 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) = (char)((offset>>8)&0377);
+ *(scan+2) = (char)(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 == &regdummy || 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 _ANSI_ARGS_((regexp *prog, char *string,
+ struct regexec_state *restate));
+static int regmatch _ANSI_ARGS_((char *prog,
+ struct regexec_state *restate));
+static int regrepeat _ANSI_ARGS_((char *p,
+ struct regexec_state *restate));
+
+#ifdef DEBUG
+int regnarrate = 0;
+void regdump _ANSI_ARGS_((regexp *r));
+static char *regprop _ANSI_ARGS_((char *op));
+#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;
+
+ doOpen:
+ 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;
+ }
+ }
+ 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;
+
+ doClose:
+ 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;
+ }
+ }
+ 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;
+ }
+ 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);
+ }
+ case END:
+ return(1); /* Success! */
+ default:
+ if (OP(scan) > OPEN && OP(scan) < OPEN+NSUBEXP) {
+ goto doOpen;
+ } else if (OP(scan) > CLOSE && OP(scan) < CLOSE+NSUBEXP) {
+ goto doClose;
+ }
+ TclRegError("memory corruption");
+ return 0;
+ }
+
+ 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 == &regdummy)
+ 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:
+ if (OP(op) > OPEN && OP(op) < OPEN+NSUBEXP) {
+ sprintf(buf+strlen(buf), "OPEN%d", OP(op)-OPEN);
+ p = NULL;
+ break;
+ } else if (OP(op) > CLOSE && OP(op) < CLOSE+NSUBEXP) {
+ sprintf(buf+strlen(buf), "CLOSE%d", OP(op)-CLOSE);
+ p = NULL;
+ } else {
+ 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 "errMsg".
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclRegError(string)
+ char *string; /* Error message. */
+{
+ errMsg = string;
+}
+
+char *
+TclGetRegError()
+{
+ return errMsg;
+}
diff --git a/contrib/tcl/generic/tcl.h b/contrib/tcl/generic/tcl.h
new file mode 100644
index 000000000000..b37665f94688
--- /dev/null
+++ b/contrib/tcl/generic/tcl.h
@@ -0,0 +1,1047 @@
+/*
+ * 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-1996 Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * SCCS: @(#) tcl.h 1.266 96/04/10 11:25:19
+ */
+
+#ifndef _TCL
+#define _TCL
+
+/*
+ * The following definitions set up the proper options for Windows
+ * compilers. We use this method because there is no autoconf equivalent.
+ */
+
+#if defined(_WIN32) && !defined(__WIN32__)
+# define __WIN32__
+#endif
+
+#ifdef __WIN32__
+# undef USE_PROTOTYPE
+# undef HAS_STDARG
+# define USE_PROTOTYPE
+# define HAS_STDARG
+#endif
+
+#ifndef BUFSIZ
+#include <stdio.h>
+#endif
+
+#define TCL_VERSION "7.5"
+#define TCL_MAJOR_VERSION 7
+#define TCL_MINOR_VERSION 5
+
+/*
+ * Definitions that allow Tcl functions with variable numbers of
+ * arguments to be used with either varargs.h or stdarg.h. TCL_VARARGS
+ * is used in procedure prototypes. TCL_VARARGS_DEF is used to declare
+ * the arguments in a function definiton: it takes the type and name of
+ * the first argument and supplies the appropriate argument declaration
+ * string for use in the function definition. TCL_VARARGS_START
+ * initializes the va_list data structure and returns the first argument.
+ */
+
+#if defined(__STDC__) || defined(HAS_STDARG)
+# define TCL_VARARGS(type, name) (type name, ...)
+# define TCL_VARARGS_DEF(type, name) (type name, ...)
+# define TCL_VARARGS_START(type, name, list) (va_start(list, name), name)
+#else
+# ifdef __cplusplus
+# define TCL_VARARGS(type, name) (type name, ...)
+# define TCL_VARARGS_DEF(type, name) (type va_alist, ...)
+# else
+# define TCL_VARARGS(type, name) ()
+# define TCL_VARARGS_DEF(type, name) (va_alist)
+# endif
+# define TCL_VARARGS_START(type, name, list) \
+ (va_start(list), va_arg(list, type))
+#endif
+
+/*
+ * 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) || defined(USE_PROTOTYPE)
+# define _USING_PROTOTYPES_ 1
+# define _ANSI_ARGS_(x) x
+# define CONST const
+#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 __WIN32__
+#ifndef VOID
+# ifdef __STDC__
+# define VOID void
+# else
+# define VOID char
+# endif
+#endif
+#else /* __WIN32__ */
+/*
+ * The following code is copied from winnt.h
+ */
+#ifndef VOID
+#define VOID void
+typedef char CHAR;
+typedef short SHORT;
+typedef long LONG;
+#endif
+#endif /* __WIN32__ */
+
+/*
+ * Miscellaneous declarations.
+ */
+
+#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.
+ * TCL_DYNAMIC means result was allocated with
+ * ckalloc and should be freed with ckfree.
+ * Other values give 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 struct Tcl_AsyncHandler_ *Tcl_AsyncHandler;
+typedef struct Tcl_Command_ *Tcl_Command;
+typedef struct Tcl_Event Tcl_Event;
+typedef struct Tcl_File_ *Tcl_File;
+typedef struct Tcl_Channel_ *Tcl_Channel;
+typedef struct Tcl_RegExp_ *Tcl_RegExp;
+typedef struct Tcl_TimerToken_ *Tcl_TimerToken;
+typedef struct Tcl_Trace_ *Tcl_Trace;
+
+/*
+ * 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_ChannelProc) _ANSI_ARGS_((ClientData clientData, int mask));
+typedef void (Tcl_CloseProc) _ANSI_ARGS_((ClientData data));
+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 int (Tcl_EventProc) _ANSI_ARGS_((Tcl_Event *evPtr, int flags));
+typedef void (Tcl_EventCheckProc) _ANSI_ARGS_((ClientData clientData,
+ int flags));
+typedef int (Tcl_EventDeleteProc) _ANSI_ARGS_((Tcl_Event *evPtr,
+ ClientData clientData));
+typedef void (Tcl_EventSetupProc) _ANSI_ARGS_((ClientData clientData,
+ int flags));
+typedef void (Tcl_ExitProc) _ANSI_ARGS_((ClientData clientData));
+typedef void (Tcl_FileProc) _ANSI_ARGS_((ClientData clientData, int mask));
+typedef void (Tcl_FileFreeProc) _ANSI_ARGS_((ClientData clientData));
+typedef void (Tcl_FreeProc) _ANSI_ARGS_((char *blockPtr));
+typedef void (Tcl_IdleProc) _ANSI_ARGS_((ClientData clientData));
+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 int (Tcl_PackageInitProc) _ANSI_ARGS_((Tcl_Interp *interp));
+typedef void (Tcl_TcpAcceptProc) _ANSI_ARGS_((ClientData callbackData,
+ Tcl_Channel chan, char *address, int port));
+typedef void (Tcl_TimerProc) _ANSI_ARGS_((ClientData clientData));
+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 to implement 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
+
+/*
+ * 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
+
+# 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__)
+
+EXTERN int Tcl_DumpActiveMemory _ANSI_ARGS_((char *fileName));
+EXTERN void Tcl_ValidateAllMemory _ANSI_ARGS_((char *file,
+ int 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 result of interpreter.
+ */
+
+#define Tcl_FreeResult(interp) \
+ if ((interp)->freeProc != 0) { \
+ if (((interp)->freeProc == TCL_DYNAMIC) \
+ || ((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 that
+ * is the size of the key.
+ */
+ 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)
+
+/*
+ * Flag values to pass to Tcl_DoOneEvent to disable searches
+ * for some kinds of events:
+ */
+
+#define TCL_DONT_WAIT (1<<1)
+#define TCL_WINDOW_EVENTS (1<<2)
+#define TCL_FILE_EVENTS (1<<3)
+#define TCL_TIMER_EVENTS (1<<4)
+#define TCL_IDLE_EVENTS (1<<5) /* WAS 0x10 ???? */
+#define TCL_ALL_EVENTS (~TCL_DONT_WAIT)
+
+/*
+ * The following structure defines a generic event for the Tcl event
+ * system. These are the things that are queued in calls to Tcl_QueueEvent
+ * and serviced later by Tcl_DoOneEvent. There can be many different
+ * kinds of events with different fields, corresponding to window events,
+ * timer events, etc. The structure for a particular event consists of
+ * a Tcl_Event header followed by additional information specific to that
+ * event.
+ */
+
+struct Tcl_Event {
+ Tcl_EventProc *proc; /* Procedure to call to service this event. */
+ struct Tcl_Event *nextPtr; /* Next in list of pending events, or NULL. */
+};
+
+/*
+ * Positions to pass to Tk_QueueEvent:
+ */
+
+typedef enum {
+ TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, TCL_QUEUE_MARK
+} Tcl_QueuePosition;
+
+/*
+ * The following structure keeps is used to hold a time value, either as
+ * an absolute time (the number of seconds from the epoch) or as an
+ * elapsed time. On Unix systems the epoch is Midnight Jan 1, 1970 GMT.
+ * On Macintosh systems the epoch is Midnight Jan 1, 1904 GMT.
+ */
+
+typedef struct Tcl_Time {
+ long sec; /* Seconds. */
+ long usec; /* Microseconds. */
+} Tcl_Time;
+
+/*
+ * Bits to pass to Tcl_CreateFileHandler and Tcl_CreateChannelHandler
+ * to indicate what sorts of events are of interest:
+ */
+
+#define TCL_READABLE (1<<1)
+#define TCL_WRITABLE (1<<2)
+#define TCL_EXCEPTION (1<<3)
+
+/*
+ * Flag values to pass to Tcl_OpenCommandChannel to indicate the
+ * disposition of the stdio handles. TCL_STDIN, TCL_STDOUT, TCL_STDERR,
+ * are also used in Tcl_GetStdChannel.
+ */
+
+#define TCL_STDIN (1<<1)
+#define TCL_STDOUT (1<<2)
+#define TCL_STDERR (1<<3)
+#define TCL_ENFORCE_MODE (1<<4)
+
+/*
+ * Typedefs for the various operations in a channel type:
+ */
+
+typedef int (Tcl_DriverBlockModeProc) _ANSI_ARGS_((ClientData instanceData,
+ Tcl_File inFile, Tcl_File outFile, int mode));
+typedef int (Tcl_DriverCloseProc) _ANSI_ARGS_((ClientData instanceData,
+ Tcl_Interp *interp, Tcl_File inFile, Tcl_File outFile));
+typedef int (Tcl_DriverInputProc) _ANSI_ARGS_((ClientData instanceData,
+ Tcl_File inFile, char *buf, int toRead,
+ int *errorCodePtr));
+typedef int (Tcl_DriverOutputProc) _ANSI_ARGS_((ClientData instanceData,
+ Tcl_File outFile, char *buf, int toWrite,
+ int *errorCodePtr));
+typedef int (Tcl_DriverSeekProc) _ANSI_ARGS_((ClientData instanceData,
+ Tcl_File inFile, Tcl_File outFile, long offset, int mode,
+ int *errorCodePtr));
+typedef int (Tcl_DriverSetOptionProc) _ANSI_ARGS_((
+ ClientData instanceData, Tcl_Interp *interp,
+ char *optionName, char *value));
+typedef int (Tcl_DriverGetOptionProc) _ANSI_ARGS_((
+ ClientData instanceData, char *optionName,
+ Tcl_DString *dsPtr));
+
+/*
+ * Enum for different end of line translation and recognition modes.
+ */
+
+typedef enum Tcl_EolTranslation {
+ TCL_TRANSLATE_AUTO, /* Eol == \r, \n and \r\n. */
+ TCL_TRANSLATE_CR, /* Eol == \r. */
+ TCL_TRANSLATE_LF, /* Eol == \n. */
+ TCL_TRANSLATE_CRLF /* Eol == \r\n. */
+} Tcl_EolTranslation;
+
+/*
+ * struct Tcl_ChannelType:
+ *
+ * One such structure exists for each type (kind) of channel.
+ * It collects together in one place all the functions that are
+ * part of the specific channel type.
+ */
+
+typedef struct Tcl_ChannelType {
+ char *typeName; /* The name of the channel type in Tcl
+ * commands. This storage is owned by
+ * channel type. */
+ Tcl_DriverBlockModeProc *blockModeProc;
+ /* Set blocking mode for the
+ * raw channel. May be NULL. */
+ Tcl_DriverCloseProc *closeProc; /* Procedure to call to close
+ * the channel. */
+ Tcl_DriverInputProc *inputProc; /* Procedure to call for input
+ * on channel. */
+ Tcl_DriverOutputProc *outputProc; /* Procedure to call for output
+ * on channel. */
+ Tcl_DriverSeekProc *seekProc; /* Procedure to call to seek
+ * on the channel. May be NULL. */
+ Tcl_DriverSetOptionProc *setOptionProc;
+ /* Set an option on a channel. */
+ Tcl_DriverGetOptionProc *getOptionProc;
+ /* Get an option from a channel. */
+} Tcl_ChannelType;
+
+/*
+ * The following flags determine whether the blockModeProc above should
+ * set the channel into blocking or nonblocking mode. They are passed
+ * as arguments to the blockModeProc procedure in the above structure.
+ */
+
+#define TCL_MODE_BLOCKING 0 /* Put channel into blocking mode. */
+#define TCL_MODE_NONBLOCKING 1 /* Put channel into nonblocking
+ * mode. */
+
+/*
+ * Types for file handles:
+ */
+
+#define TCL_UNIX_FD 1
+#define TCL_MAC_FILE 2
+#define TCL_MAC_SOCKET 3
+#define TCL_WIN_PIPE 4
+#define TCL_WIN_FILE 5
+#define TCL_WIN_SOCKET 6
+#define TCL_WIN_CONSOLE 7
+
+/*
+ * Enum for different types of file paths.
+ */
+
+typedef enum Tcl_PathType {
+ TCL_PATH_ABSOLUTE,
+ TCL_PATH_RELATIVE,
+ TCL_PATH_VOLUME_RELATIVE
+} Tcl_PathType;
+
+/*
+ * The following interface is exported for backwards compatibility, but
+ * is only implemented on Unix. Portable applications should use
+ * Tcl_OpenCommandChannel, instead.
+ */
+
+EXTERN int Tcl_CreatePipeline _ANSI_ARGS_((Tcl_Interp *interp,
+ int argc, char **argv, int **pidArrayPtr,
+ int *inPipePtr, int *outPipePtr,
+ int *errFilePtr));
+
+/*
+ * 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_(
+ TCL_VARARGS(Tcl_Interp *,interp));
+EXTERN int Tcl_AppInit _ANSI_ARGS_((Tcl_Interp *interp));
+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 void Tcl_AsyncMark _ANSI_ARGS_((Tcl_AsyncHandler async));
+EXTERN int Tcl_AsyncReady _ANSI_ARGS_((void));
+EXTERN void Tcl_BackgroundError _ANSI_ARGS_((Tcl_Interp *interp));
+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 void Tcl_CancelIdleCall _ANSI_ARGS_((Tcl_IdleProc *idleProc,
+ ClientData clientData));
+EXTERN VOID * Tcl_Ckalloc _ANSI_ARGS_((unsigned int size));
+EXTERN void Tcl_Ckfree _ANSI_ARGS_((char *ptr));
+EXTERN int Tcl_Close _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Channel chan));
+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 int Tcl_CreateAlias _ANSI_ARGS_((Tcl_Interp *slave,
+ char *slaveCmd, Tcl_Interp *target,
+ char *targetCmd, int argc, char **argv));
+EXTERN Tcl_Channel Tcl_CreateChannel _ANSI_ARGS_((
+ Tcl_ChannelType *typePtr, char *chanName,
+ Tcl_File inFile, Tcl_File outFile,
+ ClientData instanceData));
+EXTERN void Tcl_CreateChannelHandler _ANSI_ARGS_((
+ Tcl_Channel chan, int mask,
+ Tcl_ChannelProc *proc, ClientData clientData));
+EXTERN void Tcl_CreateCloseHandler _ANSI_ARGS_((
+ Tcl_Channel chan, Tcl_CloseProc *proc,
+ ClientData clientData));
+EXTERN Tcl_Command Tcl_CreateCommand _ANSI_ARGS_((Tcl_Interp *interp,
+ char *cmdName, Tcl_CmdProc *proc,
+ ClientData clientData,
+ Tcl_CmdDeleteProc *deleteProc));
+EXTERN void Tcl_CreateEventSource _ANSI_ARGS_((
+ Tcl_EventSetupProc *setupProc, Tcl_EventCheckProc
+ *checkProc, ClientData clientData));
+EXTERN void Tcl_CreateExitHandler _ANSI_ARGS_((Tcl_ExitProc *proc,
+ ClientData clientData));
+EXTERN void Tcl_CreateFileHandler _ANSI_ARGS_((
+ Tcl_File file, int mask, Tcl_FileProc *proc,
+ ClientData clientData));
+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 void Tcl_CreateModalTimeout _ANSI_ARGS_((int milliseconds,
+ Tcl_TimerProc *proc, ClientData clientData));
+EXTERN Tcl_Interp *Tcl_CreateSlave _ANSI_ARGS_((Tcl_Interp *interp,
+ char *slaveName, int isSafe));
+EXTERN Tcl_TimerToken Tcl_CreateTimerHandler _ANSI_ARGS_((int milliseconds,
+ Tcl_TimerProc *proc, ClientData clientData));
+EXTERN Tcl_Trace Tcl_CreateTrace _ANSI_ARGS_((Tcl_Interp *interp,
+ int level, Tcl_CmdTraceProc *proc,
+ ClientData clientData));
+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 void Tcl_DeleteAssocData _ANSI_ARGS_((Tcl_Interp *interp,
+ char *name));
+EXTERN int Tcl_DeleteCommand _ANSI_ARGS_((Tcl_Interp *interp,
+ char *cmdName));
+EXTERN void Tcl_DeleteChannelHandler _ANSI_ARGS_((
+ Tcl_Channel chan, Tcl_ChannelProc *proc,
+ ClientData clientData));
+EXTERN void Tcl_DeleteCloseHandler _ANSI_ARGS_((
+ Tcl_Channel chan, Tcl_CloseProc *proc,
+ ClientData clientData));
+EXTERN void Tcl_DeleteEventSource _ANSI_ARGS_((
+ Tcl_EventSetupProc *setupProc,
+ Tcl_EventCheckProc *checkProc,
+ ClientData clientData));
+EXTERN void Tcl_DeleteEvents _ANSI_ARGS_((
+ Tcl_EventDeleteProc *proc,
+ ClientData clientData));
+EXTERN void Tcl_DeleteExitHandler _ANSI_ARGS_((Tcl_ExitProc *proc,
+ ClientData clientData));
+EXTERN void Tcl_DeleteFileHandler _ANSI_ARGS_((
+ Tcl_File file));
+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_DeleteModalTimeout _ANSI_ARGS_((
+ Tcl_TimerProc *proc, ClientData clientData));
+EXTERN void Tcl_DeleteTimerHandler _ANSI_ARGS_((
+ Tcl_TimerToken token));
+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 int Tcl_DoOneEvent _ANSI_ARGS_((int flags));
+EXTERN void Tcl_DoWhenIdle _ANSI_ARGS_((Tcl_IdleProc *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 int Tcl_Eof _ANSI_ARGS_((Tcl_Channel chan));
+EXTERN char * Tcl_ErrnoId _ANSI_ARGS_((void));
+EXTERN char * Tcl_ErrnoMsg _ANSI_ARGS_((int err));
+EXTERN int Tcl_Eval _ANSI_ARGS_((Tcl_Interp *interp, char *cmd));
+EXTERN int Tcl_EvalFile _ANSI_ARGS_((Tcl_Interp *interp,
+ char *fileName));
+EXTERN void Tcl_EventuallyFree _ANSI_ARGS_((ClientData clientData,
+ Tcl_FreeProc *freeProc));
+EXTERN void Tcl_Exit _ANSI_ARGS_((int status));
+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_FileReady _ANSI_ARGS_((Tcl_File file,
+ int mask));
+EXTERN void Tcl_FindExecutable _ANSI_ARGS_((char *argv0));
+EXTERN Tcl_HashEntry * Tcl_FirstHashEntry _ANSI_ARGS_((
+ Tcl_HashTable *tablePtr,
+ Tcl_HashSearch *searchPtr));
+EXTERN int Tcl_Flush _ANSI_ARGS_((Tcl_Channel chan));
+EXTERN void Tcl_FreeFile _ANSI_ARGS_((
+ Tcl_File file));
+EXTERN int Tcl_GetAlias _ANSI_ARGS_((Tcl_Interp *interp,
+ char *slaveCmd, Tcl_Interp **targetInterpPtr,
+ char **targetCmdPtr, int *argcPtr,
+ char ***argvPtr));
+EXTERN ClientData Tcl_GetAssocData _ANSI_ARGS_((Tcl_Interp *interp,
+ char *name, Tcl_InterpDeleteProc **procPtr));
+EXTERN int Tcl_GetBoolean _ANSI_ARGS_((Tcl_Interp *interp,
+ char *string, int *boolPtr));
+EXTERN Tcl_Channel Tcl_GetChannel _ANSI_ARGS_((Tcl_Interp *interp,
+ char *chanName, int *modePtr));
+EXTERN int Tcl_GetChannelBufferSize _ANSI_ARGS_((
+ Tcl_Channel chan));
+EXTERN Tcl_File Tcl_GetChannelFile _ANSI_ARGS_((Tcl_Channel chan,
+ int direction));
+EXTERN ClientData Tcl_GetChannelInstanceData _ANSI_ARGS_((
+ Tcl_Channel chan));
+EXTERN int Tcl_GetChannelOption _ANSI_ARGS_((Tcl_Channel chan,
+ char *optionName, Tcl_DString *dsPtr));
+EXTERN char * Tcl_GetChannelName _ANSI_ARGS_((Tcl_Channel chan));
+EXTERN Tcl_ChannelType * Tcl_GetChannelType _ANSI_ARGS_((Tcl_Channel chan));
+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 char * Tcl_GetCwd _ANSI_ARGS_((char *buf, int len));
+EXTERN int Tcl_GetDouble _ANSI_ARGS_((Tcl_Interp *interp,
+ char *string, double *doublePtr));
+EXTERN int Tcl_GetErrno _ANSI_ARGS_((void));
+EXTERN Tcl_File Tcl_GetFile _ANSI_ARGS_((ClientData fileData,
+ int type));
+EXTERN ClientData Tcl_GetFileInfo _ANSI_ARGS_((Tcl_File file,
+ int *typePtr));
+EXTERN char * Tcl_GetHostName _ANSI_ARGS_((void));
+EXTERN int Tcl_GetInt _ANSI_ARGS_((Tcl_Interp *interp,
+ char *string, int *intPtr));
+EXTERN int Tcl_GetInterpPath _ANSI_ARGS_((Tcl_Interp *askInterp,
+ Tcl_Interp *slaveInterp));
+EXTERN Tcl_Interp *Tcl_GetMaster _ANSI_ARGS_((Tcl_Interp *interp));
+EXTERN ClientData Tcl_GetNotifierData _ANSI_ARGS_((Tcl_File file,
+ Tcl_FileFreeProc **freeProcPtr));
+EXTERN int Tcl_GetOpenFile _ANSI_ARGS_((Tcl_Interp *interp,
+ char *string, int write, int checkUsage,
+ ClientData *filePtr));
+EXTERN Tcl_PathType Tcl_GetPathType _ANSI_ARGS_((char *path));
+EXTERN int Tcl_Gets _ANSI_ARGS_((Tcl_Channel chan,
+ Tcl_DString *dsPtr));
+EXTERN Tcl_Interp *Tcl_GetSlave _ANSI_ARGS_((Tcl_Interp *interp,
+ char *slaveName));
+EXTERN Tcl_Channel Tcl_GetStdChannel _ANSI_ARGS_((int type));
+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_InputBlocked _ANSI_ARGS_((Tcl_Channel chan));
+EXTERN int Tcl_InputBuffered _ANSI_ARGS_((Tcl_Channel chan));
+EXTERN int Tcl_InterpDeleted _ANSI_ARGS_((Tcl_Interp *interp));
+EXTERN int Tcl_IsSafe _ANSI_ARGS_((Tcl_Interp *interp));
+EXTERN char * Tcl_JoinPath _ANSI_ARGS_((int argc, char **argv,
+ Tcl_DString *resultPtr));
+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 Tcl_Channel Tcl_MakeFileChannel _ANSI_ARGS_((ClientData inFile,
+ ClientData outFile, int mode));
+EXTERN int Tcl_MakeSafe _ANSI_ARGS_((Tcl_Interp *interp));
+EXTERN Tcl_Channel Tcl_MakeTcpClientChannel _ANSI_ARGS_((
+ ClientData tcpSocket));
+EXTERN char * Tcl_Merge _ANSI_ARGS_((int argc, char **argv));
+EXTERN Tcl_HashEntry * Tcl_NextHashEntry _ANSI_ARGS_((
+ Tcl_HashSearch *searchPtr));
+EXTERN Tcl_Channel Tcl_OpenCommandChannel _ANSI_ARGS_((
+ Tcl_Interp *interp, int argc, char **argv,
+ int flags));
+EXTERN Tcl_Channel Tcl_OpenFileChannel _ANSI_ARGS_((Tcl_Interp *interp,
+ char *fileName, char *modeString,
+ int permissions));
+EXTERN Tcl_Channel Tcl_OpenTcpClient _ANSI_ARGS_((Tcl_Interp *interp,
+ int port, char *address, char *myaddr,
+ int myport, int async));
+EXTERN Tcl_Channel Tcl_OpenTcpServer _ANSI_ARGS_((Tcl_Interp *interp,
+ int port, char *host,
+ Tcl_TcpAcceptProc *acceptProc,
+ ClientData callbackData));
+EXTERN char * Tcl_ParseVar _ANSI_ARGS_((Tcl_Interp *interp,
+ char *string, char **termPtr));
+EXTERN int Tcl_PkgProvide _ANSI_ARGS_((Tcl_Interp *interp,
+ char *name, char *version));
+EXTERN char * Tcl_PkgRequire _ANSI_ARGS_((Tcl_Interp *interp,
+ char *name, char *version, int exact));
+EXTERN char * Tcl_PosixError _ANSI_ARGS_((Tcl_Interp *interp));
+EXTERN void Tcl_Preserve _ANSI_ARGS_((ClientData data));
+EXTERN void Tcl_PrintDouble _ANSI_ARGS_((Tcl_Interp *interp,
+ double value, char *dst));
+EXTERN int Tcl_PutEnv _ANSI_ARGS_((CONST char *string));
+EXTERN void Tcl_QueueEvent _ANSI_ARGS_((Tcl_Event *evPtr,
+ Tcl_QueuePosition position));
+EXTERN int Tcl_Read _ANSI_ARGS_((Tcl_Channel chan,
+ char *bufPtr, int toRead));
+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_RegisterChannel _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Channel chan));
+EXTERN void Tcl_Release _ANSI_ARGS_((ClientData clientData));
+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_Seek _ANSI_ARGS_((Tcl_Channel chan,
+ int offset, int mode));
+EXTERN void Tcl_SetAssocData _ANSI_ARGS_((Tcl_Interp *interp,
+ char *name, Tcl_InterpDeleteProc *proc,
+ ClientData clientData));
+EXTERN void Tcl_SetChannelBufferSize _ANSI_ARGS_((
+ Tcl_Channel chan, int sz));
+EXTERN int Tcl_SetChannelOption _ANSI_ARGS_((
+ Tcl_Interp *interp, Tcl_Channel chan,
+ char *optionName, char *newValue));
+EXTERN int Tcl_SetCommandInfo _ANSI_ARGS_((Tcl_Interp *interp,
+ char *cmdName, Tcl_CmdInfo *infoPtr));
+EXTERN void Tcl_SetErrno _ANSI_ARGS_((int errno));
+EXTERN void Tcl_SetErrorCode _ANSI_ARGS_(
+ TCL_VARARGS(Tcl_Interp *,interp));
+EXTERN void Tcl_SetMaxBlockTime _ANSI_ARGS_((Tcl_Time *timePtr));
+EXTERN void Tcl_SetNotifierData _ANSI_ARGS_((Tcl_File file,
+ Tcl_FileFreeProc *freeProcPtr, ClientData data));
+EXTERN void Tcl_SetPanicProc _ANSI_ARGS_((void (*proc)
+ _ANSI_ARGS_(TCL_VARARGS(char *, format))));
+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 void Tcl_SetStdChannel _ANSI_ARGS_((Tcl_Channel channel,
+ int type));
+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 void Tcl_Sleep _ANSI_ARGS_((int ms));
+EXTERN int Tcl_SplitList _ANSI_ARGS_((Tcl_Interp *interp,
+ char *list, int *argcPtr, char ***argvPtr));
+EXTERN void Tcl_SplitPath _ANSI_ARGS_((char *path,
+ int *argcPtr, char ***argvPtr));
+EXTERN void Tcl_StaticPackage _ANSI_ARGS_((Tcl_Interp *interp,
+ char *pkgName, Tcl_PackageInitProc *initProc,
+ Tcl_PackageInitProc *safeInitProc));
+EXTERN int Tcl_StringMatch _ANSI_ARGS_((char *string,
+ char *pattern));
+EXTERN int Tcl_Tell _ANSI_ARGS_((Tcl_Channel chan));
+#define Tcl_TildeSubst Tcl_TranslateFileName
+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 char * Tcl_TranslateFileName _ANSI_ARGS_((Tcl_Interp *interp,
+ char *name, Tcl_DString *bufferPtr));
+EXTERN void Tcl_UnlinkVar _ANSI_ARGS_((Tcl_Interp *interp,
+ char *varName));
+EXTERN int Tcl_UnregisterChannel _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Channel chan));
+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 void Tcl_UpdateLinkedVar _ANSI_ARGS_((Tcl_Interp *interp,
+ char *varName));
+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_(
+ TCL_VARARGS(Tcl_Interp *,interp));
+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));
+EXTERN int Tcl_WaitForEvent _ANSI_ARGS_((Tcl_Time *timePtr));
+EXTERN int Tcl_WaitPid _ANSI_ARGS_((int pid, int *statPtr,
+ int options));
+EXTERN void Tcl_WatchFile _ANSI_ARGS_((Tcl_File file,
+ int mask));
+EXTERN int Tcl_Write _ANSI_ARGS_((Tcl_Channel chan,
+ char *s, int slen));
+
+#endif /* _TCL */
diff --git a/contrib/tcl/generic/tclAsync.c b/contrib/tcl/generic/tclAsync.c
new file mode 100644
index 000000000000..905b664a1587
--- /dev/null
+++ b/contrib/tcl/generic/tclAsync.c
@@ -0,0 +1,265 @@
+/*
+ * 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.
+ *
+ * SCCS: @(#) tclAsync.c 1.6 96/02/15 11:46:15
+ */
+
+#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 by calling Tcl_AsyncReady to see
+ * if Tcl_AsyncInvoke should be invoked.
+ */
+
+static int asyncReady = 0;
+
+/*
+ * The variable below indicates whether Tcl_AsyncInvoke is currently
+ * working. If so then we won't set 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) {
+ 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 (asyncReady == 0) {
+ return code;
+ }
+ 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);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_AsyncReady --
+ *
+ * This procedure can be used to tell whether Tcl_AsyncInvoke
+ * needs to be called. This procedure is the external interface
+ * for checking the internal asyncReady variable.
+ *
+ * Results:
+ * The return value is 1 whenever a handler is ready and is 0
+ * when no handlers are ready.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_AsyncReady()
+{
+ return asyncReady;
+}
diff --git a/contrib/tcl/generic/tclBasic.c b/contrib/tcl/generic/tclBasic.c
new file mode 100644
index 000000000000..e081402186c9
--- /dev/null
+++ b/contrib/tcl/generic/tclBasic.c
@@ -0,0 +1,1826 @@
+/*
+ * 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-1996 Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * SCCS: @(#) tclBasic.c 1.210 96/03/25 17:17:54
+ */
+
+#include "tclInt.h"
+#ifndef TCL_GENERIC_ONLY
+# include "tclPort.h"
+#endif
+#include "patchlevel.h"
+
+/*
+ * Static procedures in this file:
+ */
+
+static void DeleteInterpProc _ANSI_ARGS_((Tcl_Interp *interp));
+
+/*
+ * 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},
+ {"clock", Tcl_ClockCmd},
+ {"concat", Tcl_ConcatCmd},
+ {"continue", Tcl_ContinueCmd},
+ {"error", Tcl_ErrorCmd},
+ {"eval", Tcl_EvalCmd},
+ {"exit", Tcl_ExitCmd},
+ {"expr", Tcl_ExprCmd},
+ {"fileevent", Tcl_FileEventCmd},
+ {"for", Tcl_ForCmd},
+ {"foreach", Tcl_ForeachCmd},
+ {"format", Tcl_FormatCmd},
+ {"global", Tcl_GlobalCmd},
+ {"history", Tcl_HistoryCmd},
+ {"if", Tcl_IfCmd},
+ {"incr", Tcl_IncrCmd},
+ {"info", Tcl_InfoCmd},
+ {"interp", Tcl_InterpCmd},
+ {"join", Tcl_JoinCmd},
+ {"lappend", Tcl_LappendCmd},
+ {"lindex", Tcl_LindexCmd},
+ {"linsert", Tcl_LinsertCmd},
+ {"list", Tcl_ListCmd},
+ {"llength", Tcl_LlengthCmd},
+ {"load", Tcl_LoadCmd},
+ {"lrange", Tcl_LrangeCmd},
+ {"lreplace", Tcl_LreplaceCmd},
+ {"lsearch", Tcl_LsearchCmd},
+ {"lsort", Tcl_LsortCmd},
+ {"package", Tcl_PackageCmd},
+ {"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
+ {"after", Tcl_AfterCmd},
+ {"cd", Tcl_CdCmd},
+ {"close", Tcl_CloseCmd},
+ {"eof", Tcl_EofCmd},
+ {"fblocked", Tcl_FblockedCmd},
+ {"fconfigure", Tcl_FconfigureCmd},
+ {"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},
+ {"socket", Tcl_SocketCmd},
+ {"tell", Tcl_TellCmd},
+ {"time", Tcl_TimeCmd},
+ {"update", Tcl_UpdateCmd},
+ {"vwait", Tcl_VwaitCmd},
+ {"unsupported0", TclUnsupported0Cmd},
+
+#ifndef MAC_TCL
+ {"exec", Tcl_ExecCmd},
+ {"source", Tcl_SourceCmd},
+#endif
+
+#ifdef MAC_TCL
+ {"beep", Tcl_MacBeepCmd},
+ {"cp", Tcl_CpCmd},
+ {"echo", Tcl_EchoCmd},
+ {"ls", Tcl_LsCmd},
+ {"mkdir", Tcl_MkdirCmd},
+ {"mv", Tcl_MvCmd},
+ {"rm", Tcl_RmCmd},
+ {"rmdir", Tcl_RmdirCmd},
+ {"source", Tcl_MacSourceCmd},
+#endif /* MAC_TCL */
+
+#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.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Interp *
+Tcl_CreateInterp()
+{
+ register Interp *iPtr;
+ register Command *cmdPtr;
+ register CmdInfo *cmdInfoPtr;
+ Tcl_Channel chan;
+ int i;
+
+ 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;
+ }
+ Tcl_InitHashTable(&iPtr->packageTable, TCL_STRING_KEYS);
+ iPtr->packageUnknown = 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->assocData = (Tcl_HashTable *) 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;
+ cmdPtr->deleted = 0;
+ Tcl_SetHashValue(hPtr, cmdPtr);
+ }
+ }
+
+#ifndef TCL_GENERIC_ONLY
+ TclSetupEnv((Tcl_Interp *) iPtr);
+#endif
+
+ /*
+ * Do Safe-Tcl init stuff
+ */
+
+ (void) TclInterpInit((Tcl_Interp *)iPtr);
+
+ /*
+ * Set up variables such as tcl_library and tcl_precision.
+ */
+
+ TclPlatformInit((Tcl_Interp *)iPtr);
+ Tcl_SetVar((Tcl_Interp *) iPtr, "tcl_patchLevel", TCL_PATCH_LEVEL,
+ TCL_GLOBAL_ONLY);
+ Tcl_SetVar((Tcl_Interp *) iPtr, "tcl_version", TCL_VERSION,
+ TCL_GLOBAL_ONLY);
+ Tcl_TraceVar2((Tcl_Interp *) iPtr, "tcl_precision", (char *) NULL,
+ TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
+ TclPrecTraceProc, (ClientData) NULL);
+
+ /*
+ * Register Tcl's version number.
+ */
+
+ Tcl_PkgProvide((Tcl_Interp *) iPtr, "Tcl", TCL_VERSION);
+
+ /*
+ * Add the standard channels.
+ */
+
+ chan = Tcl_GetStdChannel(TCL_STDIN);
+ if (chan != (Tcl_Channel) NULL) {
+ Tcl_RegisterChannel((Tcl_Interp *) iPtr, chan);
+ }
+ chan = Tcl_GetStdChannel(TCL_STDOUT);
+ if (chan != (Tcl_Channel) NULL) {
+ Tcl_RegisterChannel((Tcl_Interp *) iPtr, chan);
+ }
+ chan = Tcl_GetStdChannel(TCL_STDERR);
+ if (chan != (Tcl_Channel) NULL) {
+ Tcl_RegisterChannel((Tcl_Interp *) iPtr, chan);
+ }
+
+ return (Tcl_Interp *) iPtr;
+}
+
+/*
+ *--------------------------------------------------------------
+ *
+ * Tcl_CallWhenDeleted --
+ *
+ * Arrange for a procedure to be called before a given
+ * interpreter is deleted. The procedure is called as soon
+ * as Tcl_DeleteInterp is called; if Tcl_CallWhenDeleted is
+ * called on an interpreter that has already been deleted,
+ * the procedure will be called when the last Tcl_Release is
+ * done on the interpreter.
+ *
+ * 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. */
+{
+ Interp *iPtr = (Interp *) interp;
+ static int assocDataCounter = 0;
+ int new;
+ char buffer[128];
+ AssocData *dPtr = (AssocData *) ckalloc(sizeof(AssocData));
+ Tcl_HashEntry *hPtr;
+
+ sprintf(buffer, "Assoc Data Key #%d", assocDataCounter);
+ assocDataCounter++;
+
+ if (iPtr->assocData == (Tcl_HashTable *) NULL) {
+ iPtr->assocData = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
+ Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS);
+ }
+ hPtr = Tcl_CreateHashEntry(iPtr->assocData, buffer, &new);
+ dPtr->proc = proc;
+ dPtr->clientData = clientData;
+ Tcl_SetHashValue(hPtr, dPtr);
+}
+
+/*
+ *--------------------------------------------------------------
+ *
+ * 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. */
+{
+ Interp *iPtr = (Interp *) interp;
+ Tcl_HashTable *hTablePtr;
+ Tcl_HashSearch hSearch;
+ Tcl_HashEntry *hPtr;
+ AssocData *dPtr;
+
+ hTablePtr = iPtr->assocData;
+ if (hTablePtr == (Tcl_HashTable *) NULL) {
+ return;
+ }
+ for (hPtr = Tcl_FirstHashEntry(hTablePtr, &hSearch); hPtr != NULL;
+ hPtr = Tcl_NextHashEntry(&hSearch)) {
+ dPtr = (AssocData *) Tcl_GetHashValue(hPtr);
+ if ((dPtr->proc == proc) && (dPtr->clientData == clientData)) {
+ ckfree((char *) dPtr);
+ Tcl_DeleteHashEntry(hPtr);
+ return;
+ }
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_SetAssocData --
+ *
+ * Creates a named association between user-specified data, a delete
+ * function and this interpreter. If the association already exists
+ * the data is overwritten with the new data. The delete function will
+ * be invoked when the interpreter is deleted.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Sets the associated data, creates the association if needed.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_SetAssocData(interp, name, proc, clientData)
+ Tcl_Interp *interp; /* Interpreter to associate with. */
+ char *name; /* Name for association. */
+ Tcl_InterpDeleteProc *proc; /* Proc to call when interpreter is
+ * about to be deleted. */
+ ClientData clientData; /* One-word value to pass to proc. */
+{
+ Interp *iPtr = (Interp *) interp;
+ AssocData *dPtr;
+ Tcl_HashEntry *hPtr;
+ int new;
+
+ if (iPtr->assocData == (Tcl_HashTable *) NULL) {
+ iPtr->assocData = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
+ Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS);
+ }
+ hPtr = Tcl_CreateHashEntry(iPtr->assocData, name, &new);
+ if (new == 0) {
+ dPtr = (AssocData *) Tcl_GetHashValue(hPtr);
+ } else {
+ dPtr = (AssocData *) ckalloc(sizeof(AssocData));
+ }
+ dPtr->proc = proc;
+ dPtr->clientData = clientData;
+
+ Tcl_SetHashValue(hPtr, dPtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_DeleteAssocData --
+ *
+ * Deletes a named association of user-specified data with
+ * the specified interpreter.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Deletes the association.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_DeleteAssocData(interp, name)
+ Tcl_Interp *interp; /* Interpreter to associate with. */
+ char *name; /* Name of association. */
+{
+ Interp *iPtr = (Interp *) interp;
+ AssocData *dPtr;
+ Tcl_HashEntry *hPtr;
+
+ if (iPtr->assocData == (Tcl_HashTable *) NULL) {
+ return;
+ }
+ hPtr = Tcl_FindHashEntry(iPtr->assocData, name);
+ if (hPtr == (Tcl_HashEntry *) NULL) {
+ return;
+ }
+ dPtr = (AssocData *) Tcl_GetHashValue(hPtr);
+ if (dPtr->proc != NULL) {
+ (dPtr->proc) (dPtr->clientData, interp);
+ }
+ ckfree((char *) dPtr);
+ Tcl_DeleteHashEntry(hPtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_GetAssocData --
+ *
+ * Returns the client data associated with this name in the
+ * specified interpreter.
+ *
+ * Results:
+ * The client data in the AssocData record denoted by the named
+ * association, or NULL.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+ClientData
+Tcl_GetAssocData(interp, name, procPtr)
+ Tcl_Interp *interp; /* Interpreter associated with. */
+ char *name; /* Name of association. */
+ Tcl_InterpDeleteProc **procPtr; /* Pointer to place to store address
+ * of current deletion callback. */
+{
+ Interp *iPtr = (Interp *) interp;
+ AssocData *dPtr;
+ Tcl_HashEntry *hPtr;
+
+ if (iPtr->assocData == (Tcl_HashTable *) NULL) {
+ return (ClientData) NULL;
+ }
+ hPtr = Tcl_FindHashEntry(iPtr->assocData, name);
+ if (hPtr == (Tcl_HashEntry *) NULL) {
+ return (ClientData) NULL;
+ }
+ dPtr = (AssocData *) Tcl_GetHashValue(hPtr);
+ if (procPtr != (Tcl_InterpDeleteProc **) NULL) {
+ *procPtr = dPtr->proc;
+ }
+ return dPtr->clientData;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * DeleteInterpProc --
+ *
+ * Helper procedure to delete an interpreter. This procedure is
+ * called when the last call to Tcl_Preserve on this interpreter
+ * is matched by a call to Tcl_Release. The procedure cleans up
+ * all resources used in the interpreter and calls all currently
+ * registered interpreter deletion callbacks.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Whatever the interpreter deletion callbacks do. Frees resources
+ * used by the interpreter.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+DeleteInterpProc(interp)
+ Tcl_Interp *interp; /* Interpreter to delete. */
+{
+ Interp *iPtr = (Interp *) interp;
+ Tcl_HashEntry *hPtr;
+ Tcl_HashSearch search;
+ int i;
+ Tcl_HashTable *hTablePtr;
+ AssocData *dPtr;
+
+ /*
+ * Punt if there is an error in the Tcl_Release/Tcl_Preserve matchup.
+ */
+
+ if (iPtr->numLevels > 0) {
+ panic("DeleteInterpProc called with active evals");
+ }
+
+ /*
+ * The interpreter should already be marked deleted; otherwise how
+ * did we get here?
+ */
+
+ if (!(iPtr->flags & DELETED)) {
+ panic("DeleteInterpProc called on interpreter not marked deleted");
+ }
+
+ /*
+ * First delete all the commands. There's a special hack here
+ * because "tkerror" is just a synonym for "bgerror" (they share
+ * a Command structure). Just delete the hash table entry for
+ * "tkerror" without invoking its callback or cleaning up its
+ * Command structure.
+ */
+
+ hPtr = Tcl_FindHashEntry(&iPtr->commandTable, "tkerror");
+ if (hPtr != NULL) {
+ Tcl_DeleteHashEntry(hPtr);
+ }
+ for (hPtr = Tcl_FirstHashEntry(&iPtr->commandTable, &search);
+ hPtr != NULL;
+ hPtr = Tcl_FirstHashEntry(&iPtr->commandTable, &search)) {
+ Tcl_DeleteCommand(interp,
+ Tcl_GetHashKey(&iPtr->commandTable, hPtr));
+ }
+ 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);
+
+ /*
+ * Invoke deletion callbacks; note that a callback can create new
+ * callbacks, so we iterate.
+ */
+
+ while (iPtr->assocData != (Tcl_HashTable *) NULL) {
+ hTablePtr = iPtr->assocData;
+ iPtr->assocData = (Tcl_HashTable *) NULL;
+ for (hPtr = Tcl_FirstHashEntry(hTablePtr, &search);
+ hPtr != NULL;
+ hPtr = Tcl_FirstHashEntry(hTablePtr, &search)) {
+ dPtr = (AssocData *) Tcl_GetHashValue(hPtr);
+ Tcl_DeleteHashEntry(hPtr);
+ if (dPtr->proc != NULL) {
+ (*dPtr->proc)(dPtr->clientData, interp);
+ }
+ ckfree((char *) dPtr);
+ }
+ Tcl_DeleteHashTable(hTablePtr);
+ ckfree((char *) hTablePtr);
+ }
+
+ /*
+ * Delete all global variables:
+ */
+
+ 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);
+ interp->result = NULL;
+
+ if (iPtr->errorInfo != NULL) {
+ ckfree(iPtr->errorInfo);
+ iPtr->errorInfo = NULL;
+ }
+ if (iPtr->errorCode != NULL) {
+ ckfree(iPtr->errorCode);
+ iPtr->errorCode = NULL;
+ }
+ if (iPtr->events != NULL) {
+ int i;
+
+ for (i = 0; i < iPtr->numEvents; i++) {
+ ckfree(iPtr->events[i].command);
+ }
+ ckfree((char *) iPtr->events);
+ iPtr->events = NULL;
+ }
+ while (iPtr->revPtr != NULL) {
+ HistoryRev *nextPtr = iPtr->revPtr->nextPtr;
+
+ ckfree(iPtr->revPtr->newBytes);
+ ckfree((char *) iPtr->revPtr);
+ iPtr->revPtr = nextPtr;
+ }
+ if (iPtr->appendResult != NULL) {
+ ckfree(iPtr->appendResult);
+ iPtr->appendResult = NULL;
+ }
+ for (i = 0; i < NUM_REGEXPS; i++) {
+ if (iPtr->patterns[i] == NULL) {
+ break;
+ }
+ ckfree(iPtr->patterns[i]);
+ ckfree((char *) iPtr->regexps[i]);
+ iPtr->regexps[i] = NULL;
+ }
+ TclFreePackageInfo(iPtr);
+ while (iPtr->tracePtr != NULL) {
+ Trace *nextPtr = iPtr->tracePtr->nextPtr;
+
+ ckfree((char *) iPtr->tracePtr);
+ iPtr->tracePtr = nextPtr;
+ }
+
+ ckfree((char *) iPtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_InterpDeleted --
+ *
+ * Returns nonzero if the interpreter has been deleted with a call
+ * to Tcl_DeleteInterp.
+ *
+ * Results:
+ * Nonzero if the interpreter is deleted, zero otherwise.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_InterpDeleted(interp)
+ Tcl_Interp *interp;
+{
+ return (((Interp *) interp)->flags & DELETED) ? 1 : 0;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_DeleteInterp --
+ *
+ * Ensures that the interpreter will be deleted eventually. If there
+ * are no Tcl_Preserve calls in effect for this interpreter, it is
+ * deleted immediately, otherwise the interpreter is deleted when
+ * the last Tcl_Preserve is matched by a call to Tcl_Release. In either
+ * case, the procedure runs the currently registered deletion callbacks.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The interpreter is marked as deleted. The caller may still use it
+ * safely if there are calls to Tcl_Preserve in effect for the
+ * interpreter, but further calls to Tcl_Eval etc in this interpreter
+ * will fail.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_DeleteInterp(interp)
+ Tcl_Interp *interp; /* Token for command interpreter (returned
+ * by a previous call to Tcl_CreateInterp). */
+{
+ Interp *iPtr = (Interp *) interp;
+
+ /*
+ * If the interpreter has already been marked deleted, just punt.
+ */
+
+ if (iPtr->flags & DELETED) {
+ return;
+ }
+
+ /*
+ * Mark the interpreter as deleted. No further evals will be allowed.
+ */
+
+ iPtr->flags |= DELETED;
+
+ /*
+ * Ensure that the interpreter is eventually deleted.
+ */
+
+ Tcl_EventuallyFree((ClientData) interp,
+ (Tcl_FreeProc *) DeleteInterpProc);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+ Command *cmdPtr;
+ Tcl_HashEntry *hPtr;
+ int new;
+
+ /*
+ * The code below was added in 11/95 to preserve backwards compatibility
+ * when "tkerror" was renamed "bgerror": if anyone attempts to define
+ * "tkerror" as a command, it is actually created as "bgerror". This
+ * code should eventually be removed.
+ */
+
+ if ((cmdName[0] == 't') && (strcmp(cmdName, "tkerror") == 0)) {
+ cmdName = "bgerror";
+ }
+
+ if (iPtr->flags & DELETED) {
+
+ /*
+ * The interpreter is being deleted. Don't create any new
+ * commands; it's not safe to muck with the interpreter anymore.
+ */
+
+ return (Tcl_Command) NULL;
+ }
+ hPtr = Tcl_CreateHashEntry(&iPtr->commandTable, cmdName, &new);
+ if (!new) {
+ /*
+ * Command already exists: delete the old one.
+ */
+
+ Tcl_DeleteCommand(interp, Tcl_GetHashKey(&iPtr->commandTable, hPtr));
+ hPtr = Tcl_CreateHashEntry(&iPtr->commandTable, cmdName, &new);
+ if (!new) {
+ /*
+ * Drat. The stupid deletion callback recreated the command.
+ * Just throw away the new command (if we try to delete it again,
+ * we could get stuck in an infinite loop).
+ */
+
+ ckfree((char *) Tcl_GetHashValue(hPtr));
+ }
+ }
+ cmdPtr = (Command *) ckalloc(sizeof(Command));
+ Tcl_SetHashValue(hPtr, cmdPtr);
+ cmdPtr->hPtr = hPtr;
+ cmdPtr->proc = proc;
+ cmdPtr->clientData = clientData;
+ cmdPtr->deleteProc = deleteProc;
+ cmdPtr->deleteData = clientData;
+ cmdPtr->deleted = 0;
+
+ /*
+ * The code below provides more backwards compatibility for the
+ * renaming of "tkerror" to "bgerror". Like the code above, this
+ * code should eventually become unnecessary.
+ */
+
+ if ((cmdName[0] == 'b') && (strcmp(cmdName, "bgerror") == 0)) {
+ /*
+ * We're currently creating the "bgerror" command; create
+ * a "tkerror" command that shares the same Command structure.
+ */
+
+ hPtr = Tcl_CreateHashEntry(&iPtr->commandTable, "tkerror", &new);
+ Tcl_SetHashValue(hPtr, cmdPtr);
+ }
+ 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;
+
+ if ((cmdPtr == NULL) || (cmdPtr->hPtr == NULL)) {
+
+ /*
+ * This should only happen if command was "created" after the
+ * interpreter began to be deleted, so there isn't really any
+ * command. Just return an empty string.
+ */
+
+ return "";
+ }
+ 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, *tkErrorHPtr;
+ Command *cmdPtr;
+
+ /*
+ * The code below was added in 11/95 to preserve backwards compatibility
+ * when "tkerror" was renamed "bgerror": if anyone attempts to delete
+ * "tkerror", delete both it and "bgerror". This code should
+ * eventually be removed.
+ */
+
+ if ((cmdName[0] == 't') && (strcmp(cmdName, "tkerror") == 0)) {
+ cmdName = "bgerror";
+ }
+ hPtr = Tcl_FindHashEntry(&iPtr->commandTable, cmdName);
+ if (hPtr == NULL) {
+ return -1;
+ }
+ cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
+
+ /*
+ * The code here is tricky. We can't delete the hash table entry
+ * before invoking the deletion callback because there are cases
+ * where the deletion callback needs to invoke the command (e.g.
+ * object systems such as OTcl). However, this means that the
+ * callback could try to delete or rename the command. The deleted
+ * flag allows us to detect these cases and skip nested deletes.
+ */
+
+ if (cmdPtr->deleted) {
+
+ /*
+ * Another deletion is already in progress. Remove the hash
+ * table entry now, but don't invoke a callback or free the
+ * command structure.
+ */
+
+ Tcl_DeleteHashEntry(cmdPtr->hPtr);
+ cmdPtr->hPtr = NULL;
+ return 0;
+ }
+ cmdPtr->deleted = 1;
+ if (cmdPtr->deleteProc != NULL) {
+ (*cmdPtr->deleteProc)(cmdPtr->deleteData);
+ }
+
+ /*
+ * The code below provides more backwards compatibility for the
+ * renaming of "tkerror" to "bgerror". Like the code above, this
+ * code should eventually become unnecessary.
+ */
+
+ if ((cmdName[0] == 'b') && (strcmp(cmdName, "bgerror") == 0)) {
+
+ /*
+ * When the "bgerror" command is deleted, delete "tkerror"
+ * as well. It shared the same Command structure as "bgerror",
+ * so all we have to do is throw away the hash table entry.
+ * NOTE: we have to be careful since tkerror may already have
+ * been deleted before bgerror.
+ */
+
+ tkErrorHPtr = Tcl_FindHashEntry(&iPtr->commandTable, "tkerror");
+ if (tkErrorHPtr != (Tcl_HashEntry *) NULL) {
+ Tcl_DeleteHashEntry(tkErrorHPtr);
+ }
+ }
+
+ /*
+ * Don't use hPtr to delete the hash entry here, because it's
+ * possible that the deletion callback renamed the command.
+ * Instead, use cmdPtr->hptr, and make sure that no-one else
+ * has already deleted the hash entry.
+ */
+
+ if (cmdPtr->hPtr != NULL) {
+ Tcl_DeleteHashEntry(cmdPtr->hPtr);
+ }
+ ckfree((char *) cmdPtr);
+
+ 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) {
+
+ /*
+ * If we have been deleted, return an error preventing further
+ * evals.
+ */
+
+ if (iPtr->flags & DELETED) {
+ Tcl_ResetResult(interp);
+ interp->result = "attempt to call eval in deleted interpreter";
+ Tcl_SetErrorCode(interp, "CORE", "IDELETE", interp->result,
+ (char *) NULL);
+ iPtr->numLevels--;
+ return TCL_ERROR;
+ }
+
+ 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 == '#') {
+ while (*src != 0) {
+ if (*src == '\\') {
+ int length;
+ Tcl_Backslash(src, &length);
+ src += length;
+ } else if (*src == '\n') {
+ src++;
+ termPtr = src;
+ break;
+ } else {
+ src++;
+ }
+ }
+ 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 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
+Tcl_VarEval TCL_VARARGS_DEF(Tcl_Interp *,arg1)
+{
+ va_list argList;
+ Tcl_DString buf;
+ char *string;
+ 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.
+ */
+
+ interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList);
+ Tcl_DStringInit(&buf);
+ while (1) {
+ string = va_arg(argList, char *);
+ if (string == NULL) {
+ break;
+ }
+ Tcl_DStringAppend(&buf, string, -1);
+ }
+ va_end(argList);
+
+ result = Tcl_Eval(interp, Tcl_DStringValue(&buf));
+ Tcl_DStringFree(&buf);
+ 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;
+}
diff --git a/contrib/tcl/generic/tclCkalloc.c b/contrib/tcl/generic/tclCkalloc.c
new file mode 100644
index 000000000000..e8f3b37ff426
--- /dev/null
+++ b/contrib/tcl/generic/tclCkalloc.c
@@ -0,0 +1,738 @@
+/*
+ * 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-1996 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
+ *
+ *
+ * SCCS: @(#) tclCkalloc.c 1.17 96/03/14 13:05:56
+ */
+
+#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.
+ */
+
+#define BODY_OFFSET \
+ ((unsigned long) (&((struct mem_header *) 0)->body))
+
+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;
+{
+ /*
+ * The following cast is *very* tricky. Must convert the pointer
+ * to an integer before doing arithmetic on it, because otherwise
+ * the arithmetic will be done differently (and incorrectly) on
+ * word-addressed machines such as Crays (will subtract only bytes,
+ * even though BODY_OFFSET is in words on these machines).
+ */
+
+ struct mem_header *memp = (struct mem_header *)
+ (((unsigned long) 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;
+
+ /*
+ * See comment from Tcl_DbCkfree before you change the following
+ * line.
+ */
+
+ struct mem_header *memp = (struct mem_header *)
+ (((unsigned long) 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_TranslateFileName(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;
+}
+
+
+char *
+Tcl_DbCkalloc(size, file, line)
+ unsigned int size;
+ char *file;
+ int line;
+{
+ char *result;
+
+ result = (char *) malloc(size);
+
+ if (result == NULL) {
+ fflush(stdout);
+ panic("unable to alloc %d bytes, %s line %d", size, file,
+ line);
+ }
+ return result;
+}
+
+char *
+Tcl_DbCkrealloc(ptr, size, file, line)
+ char *ptr;
+ unsigned int size;
+ char *file;
+ int line;
+{
+ char *result;
+
+ result = (char *) realloc(ptr, size);
+
+ if (result == NULL) {
+ fflush(stdout);
+ panic("unable to realloc %d bytes, %s line %d", size, file,
+ line);
+ }
+ 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)
+ char *ptr;
+{
+ free (ptr);
+}
+
+int
+Tcl_DbCkfree(ptr, file, line)
+ char * ptr;
+ char *file;
+ int line;
+{
+ free (ptr);
+ return 0;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+{
+}
+
+#undef Tcl_DumpActiveMemory
+#undef Tcl_ValidateAllMemory
+
+extern int Tcl_DumpActiveMemory _ANSI_ARGS_((char *fileName));
+extern void Tcl_ValidateAllMemory _ANSI_ARGS_((char *file,
+ int line));
+
+int
+Tcl_DumpActiveMemory (fileName)
+ char *fileName;
+{
+ return TCL_OK;
+}
+
+void
+Tcl_ValidateAllMemory (file, line)
+ char *file;
+ int line;
+{
+}
+
+#endif
diff --git a/contrib/tcl/generic/tclClock.c b/contrib/tcl/generic/tclClock.c
new file mode 100644
index 000000000000..3fb4abdd4504
--- /dev/null
+++ b/contrib/tcl/generic/tclClock.c
@@ -0,0 +1,353 @@
+/*
+ * tclClock.c --
+ *
+ * Contains the time and date related commands. This code
+ * is derived from the time and date facilities of TclX,
+ * by Mark Diekhans and Karl Lehenbauer.
+ *
+ * Copyright 1991-1995 Karl Lehenbauer and Mark Diekhans.
+ * 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.
+ *
+ * SCCS: @(#) tclClock.c 1.19 96/03/13 11:28:45
+ */
+
+#include "tcl.h"
+#include "tclInt.h"
+#include "tclPort.h"
+
+/*
+ * Function prototypes for local procedures in this file:
+ */
+
+static int FormatClock _ANSI_ARGS_((Tcl_Interp *interp,
+ unsigned long clockVal, int useGMT,
+ char *format));
+static int ParseTime _ANSI_ARGS_((Tcl_Interp *interp,
+ char *string, unsigned long *timePtr));
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * Tcl_ClockCmd --
+ *
+ * This procedure is invoked to process the "clock" Tcl command.
+ * See the user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+int
+Tcl_ClockCmd (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;
+ char **argPtr;
+ int useGMT = 0;
+ unsigned long clockVal;
+
+ if (argc < 2) {
+ Tcl_AppendResult(interp, "wrong # args: should be \"",
+ argv[0], " option ?arg ...?\"", (char *) NULL);
+ return TCL_ERROR;
+ }
+ c = argv[1][0];
+ length = strlen(argv[1]);
+ if ((c == 'c') && (strncmp(argv[1], "clicks", length) == 0)) {
+ if (argc != 2) {
+ Tcl_AppendResult(interp, "wrong # arguments: must be \"",
+ argv[0], " clicks\"", (char *) NULL);
+ return TCL_ERROR;
+ }
+ sprintf(interp->result, "%lu", TclGetClicks());
+ return TCL_OK;
+ } else if ((c == 'f') && (strncmp(argv[1], "format", length) == 0)) {
+ char *format = "%a %b %d %X %Z %Y";
+
+ if ((argc < 3) || (argc > 7)) {
+ wrongFmtArgs:
+ Tcl_AppendResult(interp, "wrong # args: ", argv [0],
+ " format clockval ?-format string? ?-gmt boolean?",
+ (char *) NULL);
+ return TCL_ERROR;
+ }
+
+ if (ParseTime(interp, argv[2], &clockVal) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ argPtr = argv+3;
+ argc -= 3;
+ while ((argc > 1) && (argPtr[0][0] == '-')) {
+ if (strcmp(argPtr[0], "-format") == 0) {
+ format = argPtr[1];
+ } else if (strcmp(argPtr[0], "-gmt") == 0) {
+ if (Tcl_GetBoolean(interp, argPtr[1], &useGMT) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ } else {
+ Tcl_AppendResult(interp, "bad option \"", argPtr[0],
+ "\": must be -format or -gmt", (char *) NULL);
+ return TCL_ERROR;
+ }
+ argPtr += 2;
+ argc -= 2;
+ }
+ if (argc != 0) {
+ goto wrongFmtArgs;
+ }
+
+ return FormatClock(interp, clockVal, useGMT, format);
+ } else if ((c == 's') && (strncmp(argv[1], "scan", length) == 0)) {
+ unsigned long baseClock;
+ long zone;
+ char * baseStr = NULL;
+
+ if ((argc < 3) || (argc > 7)) {
+ wrongScanArgs:
+ Tcl_AppendResult (interp, "wrong # args: ", argv [0],
+ " scan dateString ?-base clockValue? ?-gmt boolean?",
+ (char *) NULL);
+ return TCL_ERROR;
+ }
+
+ argPtr = argv+3;
+ argc -= 3;
+ while ((argc > 1) && (argPtr[0][0] == '-')) {
+ if (strcmp(argPtr[0], "-base") == 0) {
+ baseStr = argPtr[1];
+ } else if (strcmp(argPtr[0], "-gmt") == 0) {
+ if (Tcl_GetBoolean(interp, argPtr[1], &useGMT) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ } else {
+ Tcl_AppendResult(interp, "bad option \"", argPtr[0],
+ "\": must be -base or -gmt", (char *) NULL);
+ return TCL_ERROR;
+ }
+ argPtr += 2;
+ argc -= 2;
+ }
+ if (argc != 0) {
+ goto wrongScanArgs;
+ }
+
+ if (baseStr != NULL) {
+ if (ParseTime(interp, baseStr, &baseClock) != TCL_OK)
+ return TCL_ERROR;
+ } else {
+ baseClock = TclGetSeconds();
+ }
+
+ if (useGMT) {
+ zone = -50000; /* Force GMT */
+ } else {
+ zone = TclGetTimeZone(baseClock);
+ }
+
+ if (TclGetDate(argv[2], baseClock, zone, &clockVal) < 0) {
+ Tcl_AppendResult(interp, "unable to convert date-time string \"",
+ argv[2], "\"", (char *) NULL);
+ return TCL_ERROR;
+ }
+
+ sprintf(interp->result, "%lu", (long) clockVal);
+ return TCL_OK;
+ } else if ((c == 's') && (strncmp(argv[1], "seconds", length) == 0)) {
+ if (argc != 2) {
+ Tcl_AppendResult(interp, "wrong # arguments: must be \"",
+ argv[0], " seconds\"", (char *) NULL);
+ return TCL_ERROR;
+ }
+ sprintf(interp->result, "%lu", TclGetSeconds());
+ return TCL_OK;
+ } else {
+ Tcl_AppendResult(interp, "unknown option \"", argv[1],
+ "\": must be clicks, format, scan, or seconds",
+ (char *) NULL);
+ return TCL_ERROR;
+ }
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * ParseTime --
+ *
+ * Given a string, produce the corresponding time_t value.
+ *
+ * Results:
+ * The return value is normally TCL_OK; in this case *timePtr
+ * 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.
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+static int
+ParseTime(interp, string, timePtr)
+ Tcl_Interp *interp;
+ char *string;
+ unsigned long *timePtr;
+{
+ char *end, *p;
+ unsigned long i;
+
+ /*
+ * Since some strtoul functions don't detect negative numbers, check
+ * in advance.
+ */
+ errno = 0;
+ for (p = (char *) string; isspace(UCHAR(*p)); p++) {
+ /* Empty loop body. */
+ }
+ if (*p == '+') {
+ p++;
+ }
+ i = strtoul(p, &end, 0);
+ if (end == p) {
+ goto badTime;
+ }
+ 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 badTime;
+ }
+
+ *timePtr = (time_t) i;
+ if (*timePtr != i) {
+ goto badTime;
+ }
+ return TCL_OK;
+
+ badTime:
+ Tcl_AppendResult (interp, "expected unsigned time but got \"",
+ string, "\"", (char *) NULL);
+ return TCL_ERROR;
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * FormatClock --
+ *
+ * Formats a time value based on seconds into a human readable
+ * string.
+ *
+ * Results:
+ * Standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+static int
+FormatClock(interp, clockVal, useGMT, format)
+ Tcl_Interp *interp; /* Current interpreter. */
+ unsigned long clockVal; /* Time in seconds. */
+ int useGMT; /* Boolean */
+ char *format; /* Format string */
+{
+ struct tm *timeDataPtr;
+ Tcl_DString buffer;
+ int bufSize;
+#ifdef TCL_USE_TIMEZONE_VAR
+ int savedTimeZone;
+ char *savedTZEnv;
+#endif
+
+#ifdef HAVE_TZSET
+ /*
+ * Some systems forgot to call tzset in localtime, make sure its done.
+ */
+ static int calledTzset = 0;
+
+ if (!calledTzset) {
+ tzset();
+ calledTzset = 1;
+ }
+#endif
+
+#ifdef TCL_USE_TIMEZONE_VAR
+ /*
+ * This is a horrible kludge for systems not having the timezone in
+ * struct tm. No matter what was specified, they use the global time
+ * zone. (Thanks Solaris).
+ */
+ if (useGMT) {
+ char *varValue;
+
+ varValue = Tcl_GetVar2(interp, "env", "TZ", TCL_GLOBAL_ONLY);
+ if (varValue != NULL) {
+ savedTZEnv = strcpy(ckalloc(strlen(varValue) + 1), varValue);
+ } else {
+ savedTZEnv = NULL;
+ }
+ Tcl_SetVar2(interp, "env", "TZ", "GMT", TCL_GLOBAL_ONLY);
+ savedTimeZone = timezone;
+ timezone = 0;
+ tzset();
+ }
+#endif
+
+ if (useGMT) {
+ timeDataPtr = gmtime((time_t *) &clockVal);
+ } else {
+ timeDataPtr = localtime((time_t *) &clockVal);
+ }
+
+ /*
+ * Format the time, increasing the buffer size until strftime succeeds.
+ */
+ bufSize = TCL_DSTRING_STATIC_SIZE - 1;
+ Tcl_DStringInit(&buffer);
+ Tcl_DStringSetLength(&buffer, bufSize);
+
+ while (strftime(buffer.string, (unsigned int) bufSize, format,
+ timeDataPtr) == 0) {
+ bufSize *= 2;
+ Tcl_DStringSetLength(&buffer, bufSize);
+ }
+
+#ifdef TCL_USE_TIMEZONE_VAR
+ if (useGMT) {
+ if (savedTZEnv != NULL) {
+ Tcl_SetVar2(interp, "env", "TZ", savedTZEnv, TCL_GLOBAL_ONLY);
+ ckfree(savedTZEnv);
+ } else {
+ Tcl_UnsetVar2(interp, "env", "TZ", TCL_GLOBAL_ONLY);
+ }
+ timezone = savedTimeZone;
+ tzset();
+ }
+#endif
+
+ Tcl_DStringResult(interp, &buffer);
+ return TCL_OK;
+}
+
diff --git a/contrib/tcl/generic/tclCmdAH.c b/contrib/tcl/generic/tclCmdAH.c
new file mode 100644
index 000000000000..526a11181ac7
--- /dev/null
+++ b/contrib/tcl/generic/tclCmdAH.c
@@ -0,0 +1,1678 @@
+/*
+ * 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-1996 Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * SCCS: @(#) tclCmdAH.c 1.107 96/04/09 17:14:39
+ */
+
+#include "tclInt.h"
+#include "tclPort.h"
+
+/*
+ * Prototypes for local procedures defined in this file:
+ */
+
+static char * GetTypeFromMode _ANSI_ARGS_((int mode));
+static int StoreStatData _ANSI_ARGS_((Tcl_Interp *interp,
+ char *varName, struct stat *statPtr));
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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_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_TranslateFileName(interp, dirName, &buffer);
+ if (dirName == NULL) {
+ return TCL_ERROR;
+ }
+ result = TclChdir(interp, dirName);
+ Tcl_DStringFree(&buffer);
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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_DYNAMIC;
+ }
+ 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_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) {
+ value = 0;
+ } else if (Tcl_GetInt(interp, argv[1], &value) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ Tcl_Exit(value);
+ /*NOTREACHED*/
+ return TCL_OK; /* Better not ever reach this! */
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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_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 *fileName, *extension;
+ 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;
+ Tcl_DStringInit(&buffer);
+
+ /*
+ * First handle operations on the file name.
+ */
+
+ if ((c == 'd') && (strncmp(argv[1], "dirname", length) == 0)) {
+ int pargc;
+ char **pargv;
+
+ if (argc != 3) {
+ argv[1] = "dirname";
+ goto not3Args;
+ }
+
+ fileName = argv[2];
+
+ /*
+ * If there is only one element, and it starts with a tilde,
+ * perform tilde substitution and resplit the path.
+ */
+
+ Tcl_SplitPath(fileName, &pargc, &pargv);
+ if ((pargc == 1) && (*fileName == '~')) {
+ ckfree((char*) pargv);
+ fileName = Tcl_TranslateFileName(interp, fileName, &buffer);
+ if (fileName == NULL) {
+ result = TCL_ERROR;
+ goto done;
+ }
+ Tcl_SplitPath(fileName, &pargc, &pargv);
+ Tcl_DStringSetLength(&buffer, 0);
+ }
+
+ /*
+ * Return all but the last component. If there is only one
+ * component, return it if the path was non-relative, otherwise
+ * return the current directory.
+ */
+
+ if (pargc > 1) {
+ Tcl_JoinPath(pargc-1, pargv, &buffer);
+ Tcl_DStringResult(interp, &buffer);
+ } else if ((pargc == 0)
+ || (Tcl_GetPathType(pargv[0]) == TCL_PATH_RELATIVE)) {
+ Tcl_SetResult(interp,
+ (tclPlatform == TCL_PLATFORM_MAC) ? ":" : ".", TCL_STATIC);
+ } else {
+ Tcl_SetResult(interp, pargv[0], TCL_VOLATILE);
+ }
+ ckfree((char *)pargv);
+ goto done;
+
+ } else if ((c == 't') && (strncmp(argv[1], "tail", length) == 0)
+ && (length >= 2)) {
+ int pargc;
+ char **pargv;
+
+ if (argc != 3) {
+ argv[1] = "tail";
+ goto not3Args;
+ }
+
+ Tcl_SplitPath(argv[2], &pargc, &pargv);
+ if (pargc > 0) {
+ if ((pargc > 1)
+ || (Tcl_GetPathType(pargv[0]) == TCL_PATH_RELATIVE)) {
+ Tcl_SetResult(interp, pargv[pargc-1], TCL_VOLATILE);
+ }
+ }
+ ckfree((char *)pargv);
+ goto done;
+
+ } else if ((c == 'r') && (strncmp(argv[1], "rootname", length) == 0)
+ && (length >= 2)) {
+ char tmp;
+ if (argc != 3) {
+ argv[1] = "rootname";
+ goto not3Args;
+ }
+ extension = TclGetExtension(argv[2]);
+ if (extension == NULL) {
+ Tcl_SetResult(interp, argv[2], TCL_VOLATILE);
+ } else {
+ tmp = *extension;
+ *extension = 0;
+ Tcl_SetResult(interp, argv[2], TCL_VOLATILE);
+ *extension = tmp;
+ }
+ goto done;
+ } else if ((c == 'e') && (strncmp(argv[1], "extension", length) == 0)
+ && (length >= 3)) {
+ if (argc != 3) {
+ argv[1] = "extension";
+ goto not3Args;
+ }
+ extension = TclGetExtension(argv[2]);
+
+ if (extension != NULL) {
+ Tcl_SetResult(interp, extension, TCL_VOLATILE);
+ }
+ goto done;
+ } else if ((c == 'p') && (strncmp(argv[1], "pathtype", length) == 0)) {
+ if (argc != 3) {
+ argv[1] = "pathtype";
+ goto not3Args;
+ }
+ switch (Tcl_GetPathType(argv[2])) {
+ case TCL_PATH_ABSOLUTE:
+ Tcl_SetResult(interp, "absolute", TCL_STATIC);
+ break;
+ case TCL_PATH_RELATIVE:
+ Tcl_SetResult(interp, "relative", TCL_STATIC);
+ break;
+ case TCL_PATH_VOLUME_RELATIVE:
+ Tcl_SetResult(interp, "volumerelative", TCL_STATIC);
+ break;
+ }
+ goto done;
+ } else if ((c == 's') && (strncmp(argv[1], "split", length) == 0)
+ && (length >= 2)) {
+ int pargc, i;
+ char **pargvList;
+
+ if (argc != 3) {
+ argv[1] = "split";
+ goto not3Args;
+ }
+
+ Tcl_SplitPath(argv[2], &pargc, &pargvList);
+ for (i = 0; i < pargc; i++) {
+ Tcl_AppendElement(interp, pargvList[i]);
+ }
+ ckfree((char *) pargvList);
+ goto done;
+ } else if ((c == 'j') && (strncmp(argv[1], "join", length) == 0)) {
+ Tcl_JoinPath(argc-2, argv+2, &buffer);
+ Tcl_DStringResult(interp, &buffer);
+ goto done;
+ }
+
+ /*
+ * Next, handle operations that can be satisfied with the "access"
+ * kernel call.
+ */
+
+ fileName = Tcl_TranslateFileName(interp, argv[2], &buffer);
+ 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", (long) 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", (long) 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, "%lu", (unsigned long) 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 = GetTypeFromMode((int) statBuf.st_mode);
+ goto done;
+ } else {
+ Tcl_AppendResult(interp, "bad option \"", argv[1],
+ "\": should be atime, dirname, executable, exists, ",
+ "extension, isdirectory, isfile, join, ",
+ "lstat, mtime, owned, pathtype, readable, readlink, ",
+ "root, size, split, 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:
+ /*
+ * For Windows and Macintosh, there are no user ids
+ * associated with a file, so we always return 1.
+ */
+
+#if (defined(__WIN32__) || defined(MAC_TCL))
+ mode = 1;
+#else
+ mode = (geteuid() == statBuf.st_uid);
+#endif
+ 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;
+
+ not3Args:
+ Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
+ " ", argv[1], " name\"", (char *) NULL);
+ result = TCL_ERROR;
+ goto done;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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", (long) statPtr->st_dev);
+ if (Tcl_SetVar2(interp, varName, "dev", string, TCL_LEAVE_ERR_MSG)
+ == NULL) {
+ return TCL_ERROR;
+ }
+ sprintf(string, "%ld", (long) statPtr->st_ino);
+ if (Tcl_SetVar2(interp, varName, "ino", string, TCL_LEAVE_ERR_MSG)
+ == NULL) {
+ return TCL_ERROR;
+ }
+ sprintf(string, "%ld", (long) statPtr->st_mode);
+ if (Tcl_SetVar2(interp, varName, "mode", string, TCL_LEAVE_ERR_MSG)
+ == NULL) {
+ return TCL_ERROR;
+ }
+ sprintf(string, "%ld", (long) 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, "%lu", (unsigned long) statPtr->st_size);
+ if (Tcl_SetVar2(interp, varName, "size", string, TCL_LEAVE_ERR_MSG)
+ == NULL) {
+ return TCL_ERROR;
+ }
+ sprintf(string, "%ld", (long) statPtr->st_atime);
+ if (Tcl_SetVar2(interp, varName, "atime", string, TCL_LEAVE_ERR_MSG)
+ == NULL) {
+ return TCL_ERROR;
+ }
+ sprintf(string, "%ld", (long) statPtr->st_mtime);
+ if (Tcl_SetVar2(interp, varName, "mtime", string, TCL_LEAVE_ERR_MSG)
+ == NULL) {
+ return TCL_ERROR;
+ }
+ sprintf(string, "%ld", (long) statPtr->st_ctime);
+ if (Tcl_SetVar2(interp, varName, "ctime", string, TCL_LEAVE_ERR_MSG)
+ == NULL) {
+ return TCL_ERROR;
+ }
+ if (Tcl_SetVar2(interp, varName, "type",
+ GetTypeFromMode((int) statPtr->st_mode), TCL_LEAVE_ERR_MSG) == NULL) {
+ return TCL_ERROR;
+ }
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * GetTypeFromMode --
+ *
+ * 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 *
+GetTypeFromMode(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_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 result = TCL_OK;
+ int i; /* i selects a value list */
+ int j, maxj; /* Number of loop iterations */
+ int v; /* v selects a loop variable */
+ int numLists; /* Count of value lists */
+#define STATIC_SIZE 4
+ int indexArray[STATIC_SIZE]; /* Array of value list indices */
+ int varcListArray[STATIC_SIZE]; /* Number of loop variables per list */
+ char **varvListArray[STATIC_SIZE]; /* Array of variable name lists */
+ int argcListArray[STATIC_SIZE]; /* Array of value list sizes */
+ char **argvListArray[STATIC_SIZE]; /* Array of value lists */
+
+ int *index = indexArray;
+ int *varcList = varcListArray;
+ char ***varvList = varvListArray;
+ int *argcList = argcListArray;
+ char ***argvList = argvListArray;
+
+ if (argc < 4 || (argc%2 != 0)) {
+ Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
+ " varList list ?varList list ...? command\"", (char *) NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Manage numList parallel value lists.
+ * argvList[i] is a value list counted by argcList[i]
+ * varvList[i] is the list of variables associated with the value list
+ * varcList[i] is the number of variables associated with the value list
+ * index[i] is the current pointer into the value list argvList[i]
+ */
+
+ numLists = (argc-2)/2;
+ if (numLists > STATIC_SIZE) {
+ index = (int *) ckalloc(numLists * sizeof(int));
+ varcList = (int *) ckalloc(numLists * sizeof(int));
+ varvList = (char ***) ckalloc(numLists * sizeof(char **));
+ argcList = (int *) ckalloc(numLists * sizeof(int));
+ argvList = (char ***) ckalloc(numLists * sizeof(char **));
+ }
+ for (i=0 ; i<numLists ; i++) {
+ index[i] = 0;
+ varcList[i] = 0;
+ varvList[i] = (char **)NULL;
+ argcList[i] = 0;
+ argvList[i] = (char **)NULL;
+ }
+
+ /*
+ * Break up the value lists and variable lists into elements
+ */
+
+ maxj = 0;
+ for (i=0 ; i<numLists ; i++) {
+ result = Tcl_SplitList(interp, argv[1+i*2], &varcList[i], &varvList[i]);
+ if (result != TCL_OK) {
+ goto errorReturn;
+ }
+ result = Tcl_SplitList(interp, argv[2+i*2], &argcList[i], &argvList[i]);
+ if (result != TCL_OK) {
+ goto errorReturn;
+ }
+ j = argcList[i] / varcList[i];
+ if ((argcList[i] % varcList[i]) != 0) {
+ j++;
+ }
+ if (j > maxj) {
+ maxj = j;
+ }
+ }
+
+ /*
+ * Iterate maxj times through the lists in parallel
+ * If some value lists run out of values, set loop vars to ""
+ */
+ for (j = 0; j < maxj; j++) {
+ for (i=0 ; i<numLists ; i++) {
+ for (v=0 ; v<varcList[i] ; v++) {
+ int k = index[i]++;
+ char *value = "";
+ if (k < argcList[i]) {
+ value = argvList[i][k];
+ }
+ if (Tcl_SetVar(interp, varvList[i][v], value, 0) == NULL) {
+ Tcl_AppendResult(interp, "couldn't set loop variable: \"",
+ varvList[i][v], "\"", (char *)NULL);
+ result = TCL_ERROR;
+ goto errorReturn;
+ }
+ }
+ }
+
+ result = Tcl_Eval(interp, argv[argc-1]);
+ 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;
+ }
+ }
+ }
+ if (result == TCL_OK) {
+ Tcl_ResetResult(interp);
+ }
+errorReturn:
+ for (i=0 ; i<numLists ; i++) {
+ if (argvList[i] != (char **)NULL) {
+ ckfree((char *) argvList[i]);
+ }
+ if (varvList[i] != (char **)NULL) {
+ ckfree((char *) varvList[i]);
+ }
+ }
+ if (numLists > STATIC_SIZE) {
+ ckfree((char *) index);
+ ckfree((char *) varcList);
+ ckfree((char *) argcList);
+ ckfree((char *) varvList);
+ ckfree((char *) argvList);
+ }
+#undef STATIC_SIZE
+ 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 > 1000) {
+ /*
+ * Don't allow arbitrarily large widths: could cause core
+ * dump when we try to allocate a zillion bytes of memory
+ * below.
+ */
+
+ width = 1000;
+ } else if (width < 0) {
+ width = 0;
+ }
+ 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_DYNAMIC;
+ } 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;
+}
diff --git a/contrib/tcl/generic/tclCmdIL.c b/contrib/tcl/generic/tclCmdIL.c
new file mode 100644
index 000000000000..9998e19a97ee
--- /dev/null
+++ b/contrib/tcl/generic/tclCmdIL.c
@@ -0,0 +1,1487 @@
+/*
+ * 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.
+ *
+ * SCCS: @(#) tclCmdIL.c 1.119 96/03/22 12:10:14
+ */
+
+#include "tclInt.h"
+#include "tclPort.h"
+
+/*
+ * The following variable holds the full path name of the binary
+ * from which this application was executed, or NULL if it isn't
+ * know. The value of the variable is set by the procedure
+ * Tcl_FindExecutable. The storage space is dynamically allocated.
+ */
+
+char *tclExecutableName = NULL;
+
+/*
+ * 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 == 'h') && (strncmp(argv[1], "hostname", length) == 0)) {
+ if (argc > 2) {
+ Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
+ " hostname\"", (char *) NULL);
+ return TCL_ERROR;
+ }
+ Tcl_AppendResult(interp, Tcl_GetHostName(), NULL);
+ 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_DYNAMIC;
+ 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], "loaded", length) == 0)
+ && (length >= 3)) {
+ if ((argc != 2) && (argc != 3)) {
+ Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
+ " loaded ?interp?\"", (char *) NULL);
+ return TCL_ERROR;
+ }
+ return TclGetLoadedPackages(interp, argv[2]);
+ } else if ((c == 'l') && (strncmp(argv[1], "locals", length) == 0)
+ && (length >= 3)) {
+ 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 == 'n') && (strncmp(argv[1], "nameofexecutable",
+ length) == 0)) {
+ if (argc != 2) {
+ Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
+ " nameofexecutable\"", (char *) NULL);
+ return TCL_ERROR;
+ }
+ if (tclExecutableName != NULL) {
+ interp->result = tclExecutableName;
+ }
+ return TCL_OK;
+ } else if ((c == 'p') && (strncmp(argv[1], "patchlevel", length) == 0)
+ && (length >= 2)) {
+ char *value;
+
+ if (argc != 2) {
+ Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
+ " patchlevel\"", (char *) NULL);
+ return TCL_ERROR;
+ }
+ value = Tcl_GetVar(interp, "tcl_patchLevel",
+ TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG);
+ if (value == NULL) {
+ return TCL_ERROR;
+ }
+ interp->result = value;
+ 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)
+ && (length >= 2)) {
+ 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 == 's') && (strncmp(argv[1], "sharedlibextension",
+ length) == 0) && (length >= 2)) {
+ if (argc != 2) {
+ Tcl_AppendResult(interp, "wrong # args: should be \"",
+ argv[0], " sharedlibextension\"", (char *) NULL);
+ return TCL_ERROR;
+ }
+#ifdef TCL_SHLIB_EXT
+ interp->result = TCL_SHLIB_EXT;
+#endif
+ return TCL_OK;
+ } else if ((c == 't') && (strncmp(argv[1], "tclversion", length) == 0)) {
+ char *value;
+
+ if (argc != 2) {
+ Tcl_AppendResult(interp, "wrong # args: should be \"",
+ argv[0], " tclversion\"", (char *) NULL);
+ return TCL_ERROR;
+ }
+ value = Tcl_GetVar(interp, "tcl_version",
+ TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG);
+ if (value == NULL) {
+ return TCL_ERROR;
+ }
+ interp->result = value;
+ 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, hostname, level, library, loaded, locals, ",
+ "nameofexecutable, patchlevel, procs, script, ",
+ "sharedlibextension, 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_DYNAMIC;
+ }
+ 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_DYNAMIC;
+ }
+ 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) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendResult(interp, "bad index \"", argv[2],
+ "\": must be integer or \"end\"", (char *) NULL);
+ return TCL_ERROR;
+ }
+ }
+ 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, "bad index \"", argv[3],
+ "\": must be integer or \"end\"", (char *) NULL);
+ return TCL_ERROR;
+ }
+ }
+ if (first < 0) {
+ first = 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;
+ }
+
+ /*
+ * 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_DYNAMIC;
+ }
+ 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;
+}
diff --git a/contrib/tcl/generic/tclCmdMZ.c b/contrib/tcl/generic/tclCmdMZ.c
new file mode 100644
index 000000000000..faf9eed47b65
--- /dev/null
+++ b/contrib/tcl/generic/tclCmdMZ.c
@@ -0,0 +1,2107 @@
+/*
+ * 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-1996 Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * SCCS: @(#) tclCmdMZ.c 1.65 96/02/09 14:59:52
+ */
+
+#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_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 *dirName;
+
+ if (argc != 1) {
+ Tcl_AppendResult(interp, "wrong # args: should be \"",
+ argv[0], "\"", (char *) NULL);
+ return TCL_ERROR;
+ }
+
+ dirName = TclGetCwd(interp);
+ if (dirName == NULL) {
+ return TCL_ERROR;
+ }
+ interp->result = dirName;
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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 = (char)tolower(UCHAR(*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 = (char)tolower(UCHAR(*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", (int)(start - string),
+ (int)(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 = (char)tolower(UCHAR(*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 = (char)tolower(UCHAR(*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;
+ char *srcName, *dstName;
+
+ 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;
+ }
+
+ srcName = argv[1];
+ dstName = argv[2];
+ hPtr = Tcl_FindHashEntry(&iPtr->commandTable, dstName);
+ if (hPtr != NULL) {
+ Tcl_AppendResult(interp, "can't rename to \"", argv[2],
+ "\": command already exists", (char *) NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * The code below was added in 11/95 to preserve backwards compatibility
+ * when "tkerror" was renamed "bgerror": we guarantee that the hash
+ * table entries for both commands refer to a single shared Command
+ * structure. This code should eventually become unnecessary.
+ */
+
+ if ((srcName[0] == 't') && (strcmp(srcName, "tkerror") == 0)) {
+ srcName = "bgerror";
+ }
+ dstName = argv[2];
+ if ((dstName[0] == 't') && (strcmp(dstName, "tkerror") == 0)) {
+ dstName = "bgerror";
+ }
+
+ hPtr = Tcl_FindHashEntry(&iPtr->commandTable, srcName);
+ 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);
+
+ /*
+ * Prevent formation of alias loops through renaming.
+ */
+
+ if (TclPreventAliasLoop(interp, interp, dstName, cmdPtr->proc,
+ cmdPtr->clientData) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ Tcl_DeleteHashEntry(hPtr);
+ hPtr = Tcl_CreateHashEntry(&iPtr->commandTable, dstName, &new);
+ Tcl_SetHashValue(hPtr, cmdPtr);
+ cmdPtr->hPtr = hPtr;
+
+ /*
+ * The code below provides more backwards compatibility for the
+ * "tkerror" => "bgerror" renaming. As with the other compatibility
+ * code above, it should eventually be removed.
+ */
+
+ if ((dstName[0] == 'b') && (strcmp(dstName, "bgerror") == 0)) {
+ /*
+ * The destination command is "bgerror"; create a "tkerror"
+ * command that shares the same Command structure.
+ */
+
+ hPtr = Tcl_CreateHashEntry(&iPtr->commandTable, "tkerror", &new);
+ Tcl_SetHashValue(hPtr, cmdPtr);
+ }
+ if ((srcName[0] == 'b') && (strcmp(srcName, "bgerror") == 0)) {
+ /*
+ * The source command is "bgerror": delete the hash table
+ * entry for "tkerror" if it exists.
+ */
+
+ Tcl_DeleteHashEntry(Tcl_FindHashEntry(&iPtr->commandTable, "tkerror"));
+ }
+ 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 = (char *) ckalloc((unsigned) (strlen(argv[1]) + 1));
+ strcpy(iPtr->errorInfo, argv[1]);
+ } else if (strcmp(argv[0], "-errorcode") == 0) {
+ iPtr->errorCode = (char *) 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 = (char *) 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_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_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 = (char)tolower(UCHAR(*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 = (char) toupper(UCHAR(*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_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;
+ Tcl_Time start, stop;
+
+ 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;
+ }
+ TclGetTime(&start);
+ 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;
+ }
+ }
+ TclGetTime(&stop);
+ timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
+ Tcl_ResetResult(interp);
+ sprintf(interp->result, "%.0f microseconds per iteration",
+ (count <= 0) ? 0 : timePer/count);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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 = (char *) 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;
+}
diff --git a/contrib/tcl/generic/tclDate.c b/contrib/tcl/generic/tclDate.c
new file mode 100644
index 000000000000..b39d817e9eaa
--- /dev/null
+++ b/contrib/tcl/generic/tclDate.c
@@ -0,0 +1,1619 @@
+/*
+ * tclGetdate.c --
+ *
+ * This file is generated from a yacc grammar defined in
+ * the file tclGetdate.y
+ *
+ * Copyright (c) 1992-1995 Karl Lehenbauer and Mark Diekhans.
+ * Copyright (c) 1995-1996 Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * @(#) tclDate.c 1.24 96/04/18 16:53:56
+ */
+
+#include "tclInt.h"
+#include "tclPort.h"
+
+#ifdef MAC_TCL
+# define EPOCH 1904
+# define START_OF_TIME 1904
+# define END_OF_TIME 2039
+#else
+# define EPOCH 1970
+# define START_OF_TIME 1902
+# define END_OF_TIME 2037
+
+extern struct tm *localtime();
+#endif
+
+#define HOUR(x) ((int) (60 * x))
+#define SECSPERDAY (24L * 60L * 60L)
+
+
+/*
+ * An entry in the lexical lookup table.
+ */
+typedef struct _TABLE {
+ char *name;
+ int type;
+ time_t value;
+} TABLE;
+
+
+/*
+ * Daylight-savings mode: on, off, or not yet known.
+ */
+typedef enum _DSTMODE {
+ DSTon, DSToff, DSTmaybe
+} DSTMODE;
+
+/*
+ * Meridian: am, pm, or 24-hour style.
+ */
+typedef enum _MERIDIAN {
+ MERam, MERpm, MER24
+} MERIDIAN;
+
+
+/*
+ * Global variables. We could get rid of most of these by using a good
+ * union as the yacc stack. (This routine was originally written before
+ * yacc had the %union construct.) Maybe someday; right now we only use
+ * the %union very rarely.
+ */
+static char *TclDateInput;
+static DSTMODE TclDateDSTmode;
+static time_t TclDateDayOrdinal;
+static time_t TclDateDayNumber;
+static int TclDateHaveDate;
+static int TclDateHaveDay;
+static int TclDateHaveRel;
+static int TclDateHaveTime;
+static int TclDateHaveZone;
+static time_t TclDateTimezone;
+static time_t TclDateDay;
+static time_t TclDateHour;
+static time_t TclDateMinutes;
+static time_t TclDateMonth;
+static time_t TclDateSeconds;
+static time_t TclDateYear;
+static MERIDIAN TclDateMeridian;
+static time_t TclDateRelMonth;
+static time_t TclDateRelSeconds;
+
+
+/*
+ * Prototypes of internal functions.
+ */
+static void
+TclDateerror _ANSI_ARGS_((char *s));
+
+static time_t
+ToSeconds _ANSI_ARGS_((time_t Hours,
+ time_t Minutes,
+ time_t Seconds,
+ MERIDIAN Meridian));
+
+static int
+Convert _ANSI_ARGS_((time_t Month,
+ time_t Day,
+ time_t Year,
+ time_t Hours,
+ time_t Minutes,
+ time_t Seconds,
+ MERIDIAN Meridia,
+ DSTMODE DSTmode,
+ time_t *TimePtr));
+
+static time_t
+DSTcorrect _ANSI_ARGS_((time_t Start,
+ time_t Future));
+
+static time_t
+RelativeDate _ANSI_ARGS_((time_t Start,
+ time_t DayOrdinal,
+ time_t DayNumber));
+
+static int
+RelativeMonth _ANSI_ARGS_((time_t Start,
+ time_t RelMonth,
+ time_t *TimePtr));
+static int
+LookupWord _ANSI_ARGS_((char *buff));
+
+static int
+TclDatelex _ANSI_ARGS_((void));
+
+int
+TclDateparse _ANSI_ARGS_((void));
+typedef union
+#ifdef __cplusplus
+ YYSTYPE
+#endif
+ {
+ time_t Number;
+ enum _MERIDIAN Meridian;
+} YYSTYPE;
+# define tAGO 257
+# define tDAY 258
+# define tDAYZONE 259
+# define tID 260
+# define tMERIDIAN 261
+# define tMINUTE_UNIT 262
+# define tMONTH 263
+# define tMONTH_UNIT 264
+# define tSEC_UNIT 265
+# define tSNUMBER 266
+# define tUNUMBER 267
+# define tZONE 268
+# define tEPOCH 269
+# define tDST 270
+
+
+
+#ifdef __cplusplus
+
+#ifndef TclDateerror
+ void TclDateerror(const char *);
+#endif
+
+#ifndef TclDatelex
+#ifdef __EXTERN_C__
+ extern "C" { int TclDatelex(void); }
+#else
+ int TclDatelex(void);
+#endif
+#endif
+ int TclDateparse(void);
+
+#endif
+#define TclDateclearin TclDatechar = -1
+#define TclDateerrok TclDateerrflag = 0
+extern int TclDatechar;
+extern int TclDateerrflag;
+YYSTYPE TclDatelval;
+YYSTYPE TclDateval;
+typedef int TclDatetabelem;
+#ifndef YYMAXDEPTH
+#define YYMAXDEPTH 150
+#endif
+#if YYMAXDEPTH > 0
+int TclDate_TclDates[YYMAXDEPTH], *TclDates = TclDate_TclDates;
+YYSTYPE TclDate_TclDatev[YYMAXDEPTH], *TclDatev = TclDate_TclDatev;
+#else /* user does initial allocation */
+int *TclDates;
+YYSTYPE *TclDatev;
+#endif
+static int TclDatemaxdepth = YYMAXDEPTH;
+# define YYERRCODE 256
+
+
+/*
+ * Month and day table.
+ */
+static TABLE MonthDayTable[] = {
+ { "january", tMONTH, 1 },
+ { "february", tMONTH, 2 },
+ { "march", tMONTH, 3 },
+ { "april", tMONTH, 4 },
+ { "may", tMONTH, 5 },
+ { "june", tMONTH, 6 },
+ { "july", tMONTH, 7 },
+ { "august", tMONTH, 8 },
+ { "september", tMONTH, 9 },
+ { "sept", tMONTH, 9 },
+ { "october", tMONTH, 10 },
+ { "november", tMONTH, 11 },
+ { "december", tMONTH, 12 },
+ { "sunday", tDAY, 0 },
+ { "monday", tDAY, 1 },
+ { "tuesday", tDAY, 2 },
+ { "tues", tDAY, 2 },
+ { "wednesday", tDAY, 3 },
+ { "wednes", tDAY, 3 },
+ { "thursday", tDAY, 4 },
+ { "thur", tDAY, 4 },
+ { "thurs", tDAY, 4 },
+ { "friday", tDAY, 5 },
+ { "saturday", tDAY, 6 },
+ { NULL }
+};
+
+/*
+ * Time units table.
+ */
+static TABLE UnitsTable[] = {
+ { "year", tMONTH_UNIT, 12 },
+ { "month", tMONTH_UNIT, 1 },
+ { "fortnight", tMINUTE_UNIT, 14 * 24 * 60 },
+ { "week", tMINUTE_UNIT, 7 * 24 * 60 },
+ { "day", tMINUTE_UNIT, 1 * 24 * 60 },
+ { "hour", tMINUTE_UNIT, 60 },
+ { "minute", tMINUTE_UNIT, 1 },
+ { "min", tMINUTE_UNIT, 1 },
+ { "second", tSEC_UNIT, 1 },
+ { "sec", tSEC_UNIT, 1 },
+ { NULL }
+};
+
+/*
+ * Assorted relative-time words.
+ */
+static TABLE OtherTable[] = {
+ { "tomorrow", tMINUTE_UNIT, 1 * 24 * 60 },
+ { "yesterday", tMINUTE_UNIT, -1 * 24 * 60 },
+ { "today", tMINUTE_UNIT, 0 },
+ { "now", tMINUTE_UNIT, 0 },
+ { "last", tUNUMBER, -1 },
+ { "this", tMINUTE_UNIT, 0 },
+ { "next", tUNUMBER, 2 },
+#if 0
+ { "first", tUNUMBER, 1 },
+/* { "second", tUNUMBER, 2 }, */
+ { "third", tUNUMBER, 3 },
+ { "fourth", tUNUMBER, 4 },
+ { "fifth", tUNUMBER, 5 },
+ { "sixth", tUNUMBER, 6 },
+ { "seventh", tUNUMBER, 7 },
+ { "eighth", tUNUMBER, 8 },
+ { "ninth", tUNUMBER, 9 },
+ { "tenth", tUNUMBER, 10 },
+ { "eleventh", tUNUMBER, 11 },
+ { "twelfth", tUNUMBER, 12 },
+#endif
+ { "ago", tAGO, 1 },
+ { "epoch", tEPOCH, 0 },
+ { NULL }
+};
+
+/*
+ * The timezone table. (Note: This table was modified to not use any floating
+ * point constants to work around an SGI compiler bug).
+ */
+static TABLE TimezoneTable[] = {
+ { "gmt", tZONE, HOUR( 0) }, /* Greenwich Mean */
+ { "ut", tZONE, HOUR( 0) }, /* Universal (Coordinated) */
+ { "utc", tZONE, HOUR( 0) },
+ { "wet", tZONE, HOUR( 0) } , /* Western European */
+ { "bst", tDAYZONE, HOUR( 0) }, /* British Summer */
+ { "wat", tZONE, HOUR( 1) }, /* West Africa */
+ { "at", tZONE, HOUR( 2) }, /* Azores */
+#if 0
+ /* For completeness. BST is also British Summer, and GST is
+ * also Guam Standard. */
+ { "bst", tZONE, HOUR( 3) }, /* Brazil Standard */
+ { "gst", tZONE, HOUR( 3) }, /* Greenland Standard */
+#endif
+ { "nft", tZONE, HOUR( 7/2) }, /* Newfoundland */
+ { "nst", tZONE, HOUR( 7/2) }, /* Newfoundland Standard */
+ { "ndt", tDAYZONE, HOUR( 7/2) }, /* Newfoundland Daylight */
+ { "ast", tZONE, HOUR( 4) }, /* Atlantic Standard */
+ { "adt", tDAYZONE, HOUR( 4) }, /* Atlantic Daylight */
+ { "est", tZONE, HOUR( 5) }, /* Eastern Standard */
+ { "edt", tDAYZONE, HOUR( 5) }, /* Eastern Daylight */
+ { "cst", tZONE, HOUR( 6) }, /* Central Standard */
+ { "cdt", tDAYZONE, HOUR( 6) }, /* Central Daylight */
+ { "mst", tZONE, HOUR( 7) }, /* Mountain Standard */
+ { "mdt", tDAYZONE, HOUR( 7) }, /* Mountain Daylight */
+ { "pst", tZONE, HOUR( 8) }, /* Pacific Standard */
+ { "pdt", tDAYZONE, HOUR( 8) }, /* Pacific Daylight */
+ { "yst", tZONE, HOUR( 9) }, /* Yukon Standard */
+ { "ydt", tDAYZONE, HOUR( 9) }, /* Yukon Daylight */
+ { "hst", tZONE, HOUR(10) }, /* Hawaii Standard */
+ { "hdt", tDAYZONE, HOUR(10) }, /* Hawaii Daylight */
+ { "cat", tZONE, HOUR(10) }, /* Central Alaska */
+ { "ahst", tZONE, HOUR(10) }, /* Alaska-Hawaii Standard */
+ { "nt", tZONE, HOUR(11) }, /* Nome */
+ { "idlw", tZONE, HOUR(12) }, /* International Date Line West */
+ { "cet", tZONE, -HOUR( 1) }, /* Central European */
+ { "met", tZONE, -HOUR( 1) }, /* Middle European */
+ { "mewt", tZONE, -HOUR( 1) }, /* Middle European Winter */
+ { "mest", tDAYZONE, -HOUR( 1) }, /* Middle European Summer */
+ { "swt", tZONE, -HOUR( 1) }, /* Swedish Winter */
+ { "sst", tDAYZONE, -HOUR( 1) }, /* Swedish Summer */
+ { "fwt", tZONE, -HOUR( 1) }, /* French Winter */
+ { "fst", tDAYZONE, -HOUR( 1) }, /* French Summer */
+ { "eet", tZONE, -HOUR( 2) }, /* Eastern Europe, USSR Zone 1 */
+ { "bt", tZONE, -HOUR( 3) }, /* Baghdad, USSR Zone 2 */
+ { "it", tZONE, -HOUR( 7/2) }, /* Iran */
+ { "zp4", tZONE, -HOUR( 4) }, /* USSR Zone 3 */
+ { "zp5", tZONE, -HOUR( 5) }, /* USSR Zone 4 */
+ { "ist", tZONE, -HOUR(11/2) }, /* Indian Standard */
+ { "zp6", tZONE, -HOUR( 6) }, /* USSR Zone 5 */
+#if 0
+ /* For completeness. NST is also Newfoundland Stanard, nad SST is
+ * also Swedish Summer. */
+ { "nst", tZONE, -HOUR(13/2) }, /* North Sumatra */
+ { "sst", tZONE, -HOUR( 7) }, /* South Sumatra, USSR Zone 6 */
+#endif /* 0 */
+ { "wast", tZONE, -HOUR( 7) }, /* West Australian Standard */
+ { "wadt", tDAYZONE, -HOUR( 7) }, /* West Australian Daylight */
+ { "jt", tZONE, -HOUR(15/2) }, /* Java (3pm in Cronusland!) */
+ { "cct", tZONE, -HOUR( 8) }, /* China Coast, USSR Zone 7 */
+ { "jst", tZONE, -HOUR( 9) }, /* Japan Standard, USSR Zone 8 */
+ { "cast", tZONE, -HOUR(19/2) }, /* Central Australian Standard */
+ { "cadt", tDAYZONE, -HOUR(19/2) }, /* Central Australian Daylight */
+ { "east", tZONE, -HOUR(10) }, /* Eastern Australian Standard */
+ { "eadt", tDAYZONE, -HOUR(10) }, /* Eastern Australian Daylight */
+ { "gst", tZONE, -HOUR(10) }, /* Guam Standard, USSR Zone 9 */
+ { "nzt", tZONE, -HOUR(12) }, /* New Zealand */
+ { "nzst", tZONE, -HOUR(12) }, /* New Zealand Standard */
+ { "nzdt", tDAYZONE, -HOUR(12) }, /* New Zealand Daylight */
+ { "idle", tZONE, -HOUR(12) }, /* International Date Line East */
+ /* ADDED BY Marco Nijdam */
+ { "dst", tDST, HOUR( 0) }, /* DST on (hour is ignored) */
+ /* End ADDED */
+ { NULL }
+};
+
+/*
+ * Military timezone table.
+ */
+static TABLE MilitaryTable[] = {
+ { "a", tZONE, HOUR( 1) },
+ { "b", tZONE, HOUR( 2) },
+ { "c", tZONE, HOUR( 3) },
+ { "d", tZONE, HOUR( 4) },
+ { "e", tZONE, HOUR( 5) },
+ { "f", tZONE, HOUR( 6) },
+ { "g", tZONE, HOUR( 7) },
+ { "h", tZONE, HOUR( 8) },
+ { "i", tZONE, HOUR( 9) },
+ { "k", tZONE, HOUR( 10) },
+ { "l", tZONE, HOUR( 11) },
+ { "m", tZONE, HOUR( 12) },
+ { "n", tZONE, HOUR(- 1) },
+ { "o", tZONE, HOUR(- 2) },
+ { "p", tZONE, HOUR(- 3) },
+ { "q", tZONE, HOUR(- 4) },
+ { "r", tZONE, HOUR(- 5) },
+ { "s", tZONE, HOUR(- 6) },
+ { "t", tZONE, HOUR(- 7) },
+ { "u", tZONE, HOUR(- 8) },
+ { "v", tZONE, HOUR(- 9) },
+ { "w", tZONE, HOUR(-10) },
+ { "x", tZONE, HOUR(-11) },
+ { "y", tZONE, HOUR(-12) },
+ { "z", tZONE, HOUR( 0) },
+ { NULL }
+};
+
+
+/*
+ * Dump error messages in the bit bucket.
+ */
+static void
+TclDateerror(s)
+ char *s;
+{
+}
+
+
+static time_t
+ToSeconds(Hours, Minutes, Seconds, Meridian)
+ time_t Hours;
+ time_t Minutes;
+ time_t Seconds;
+ MERIDIAN Meridian;
+{
+ if (Minutes < 0 || Minutes > 59 || Seconds < 0 || Seconds > 59)
+ return -1;
+ switch (Meridian) {
+ case MER24:
+ if (Hours < 0 || Hours > 23)
+ return -1;
+ return (Hours * 60L + Minutes) * 60L + Seconds;
+ case MERam:
+ if (Hours < 1 || Hours > 12)
+ return -1;
+ return ((Hours % 12) * 60L + Minutes) * 60L + Seconds;
+ case MERpm:
+ if (Hours < 1 || Hours > 12)
+ return -1;
+ return (((Hours % 12) + 12) * 60L + Minutes) * 60L + Seconds;
+ }
+ return -1; /* Should never be reached */
+}
+
+
+static int
+Convert(Month, Day, Year, Hours, Minutes, Seconds, Meridian, DSTmode, TimePtr)
+ time_t Month;
+ time_t Day;
+ time_t Year;
+ time_t Hours;
+ time_t Minutes;
+ time_t Seconds;
+ MERIDIAN Meridian;
+ DSTMODE DSTmode;
+ time_t *TimePtr;
+{
+ static int DaysInMonth[12] = {
+ 31, 0, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31
+ };
+ time_t tod;
+ time_t Julian;
+ int i;
+
+ if (Year < 0)
+ Year = -Year;
+ if (Year < 100)
+ Year += 1900;
+ DaysInMonth[1] = Year % 4 == 0 && (Year % 100 != 0 || Year % 400 == 0)
+ ? 29 : 28;
+ if (Month < 1 || Month > 12
+ || Year < START_OF_TIME || Year > END_OF_TIME
+ || Day < 1 || Day > DaysInMonth[(int)--Month])
+ return -1;
+
+ for (Julian = Day - 1, i = 0; i < Month; i++)
+ Julian += DaysInMonth[i];
+ if (Year >= EPOCH) {
+ for (i = EPOCH; i < Year; i++)
+ Julian += 365 + (i % 4 == 0);
+ } else {
+ for (i = Year; i < EPOCH; i++)
+ Julian -= 365 + (i % 4 == 0);
+ }
+ Julian *= SECSPERDAY;
+ Julian += TclDateTimezone * 60L;
+ if ((tod = ToSeconds(Hours, Minutes, Seconds, Meridian)) < 0)
+ return -1;
+ Julian += tod;
+ if (DSTmode == DSTon
+ || (DSTmode == DSTmaybe && localtime(&Julian)->tm_isdst))
+ Julian -= 60 * 60;
+ *TimePtr = Julian;
+ return 0;
+}
+
+
+static time_t
+DSTcorrect(Start, Future)
+ time_t Start;
+ time_t Future;
+{
+ time_t StartDay;
+ time_t FutureDay;
+
+ StartDay = (localtime(&Start)->tm_hour + 1) % 24;
+ FutureDay = (localtime(&Future)->tm_hour + 1) % 24;
+ return (Future - Start) + (StartDay - FutureDay) * 60L * 60L;
+}
+
+
+static time_t
+RelativeDate(Start, DayOrdinal, DayNumber)
+ time_t Start;
+ time_t DayOrdinal;
+ time_t DayNumber;
+{
+ struct tm *tm;
+ time_t now;
+
+ now = Start;
+ tm = localtime(&now);
+ now += SECSPERDAY * ((DayNumber - tm->tm_wday + 7) % 7);
+ now += 7 * SECSPERDAY * (DayOrdinal <= 0 ? DayOrdinal : DayOrdinal - 1);
+ return DSTcorrect(Start, now);
+}
+
+
+static int
+RelativeMonth(Start, RelMonth, TimePtr)
+ time_t Start;
+ time_t RelMonth;
+ time_t *TimePtr;
+{
+ struct tm *tm;
+ time_t Month;
+ time_t Year;
+ time_t Julian;
+
+ if (RelMonth == 0) {
+ *TimePtr = 0;
+ return 0;
+ }
+ tm = localtime(&Start);
+ Month = 12 * tm->tm_year + tm->tm_mon + RelMonth;
+ Year = Month / 12;
+ Month = Month % 12 + 1;
+ if (Convert(Month, (time_t)tm->tm_mday, Year,
+ (time_t)tm->tm_hour, (time_t)tm->tm_min, (time_t)tm->tm_sec,
+ MER24, DSTmaybe, &Julian) < 0)
+ return -1;
+ *TimePtr = DSTcorrect(Start, Julian);
+ return 0;
+}
+
+
+static int
+LookupWord(buff)
+ char *buff;
+{
+ register char *p;
+ register char *q;
+ register TABLE *tp;
+ int i;
+ int abbrev;
+
+ /*
+ * Make it lowercase.
+ */
+ for (p = buff; *p; p++) {
+ if (isupper(*p)) {
+ *p = (char) tolower(*p);
+ }
+ }
+
+ if (strcmp(buff, "am") == 0 || strcmp(buff, "a.m.") == 0) {
+ TclDatelval.Meridian = MERam;
+ return tMERIDIAN;
+ }
+ if (strcmp(buff, "pm") == 0 || strcmp(buff, "p.m.") == 0) {
+ TclDatelval.Meridian = MERpm;
+ return tMERIDIAN;
+ }
+
+ /*
+ * See if we have an abbreviation for a month.
+ */
+ if (strlen(buff) == 3) {
+ abbrev = 1;
+ } else if (strlen(buff) == 4 && buff[3] == '.') {
+ abbrev = 1;
+ buff[3] = '\0';
+ } else {
+ abbrev = 0;
+ }
+
+ for (tp = MonthDayTable; tp->name; tp++) {
+ if (abbrev) {
+ if (strncmp(buff, tp->name, 3) == 0) {
+ TclDatelval.Number = tp->value;
+ return tp->type;
+ }
+ } else if (strcmp(buff, tp->name) == 0) {
+ TclDatelval.Number = tp->value;
+ return tp->type;
+ }
+ }
+
+ for (tp = TimezoneTable; tp->name; tp++) {
+ if (strcmp(buff, tp->name) == 0) {
+ TclDatelval.Number = tp->value;
+ return tp->type;
+ }
+ }
+
+ for (tp = UnitsTable; tp->name; tp++) {
+ if (strcmp(buff, tp->name) == 0) {
+ TclDatelval.Number = tp->value;
+ return tp->type;
+ }
+ }
+
+ /*
+ * Strip off any plural and try the units table again.
+ */
+ i = strlen(buff) - 1;
+ if (buff[i] == 's') {
+ buff[i] = '\0';
+ for (tp = UnitsTable; tp->name; tp++) {
+ if (strcmp(buff, tp->name) == 0) {
+ TclDatelval.Number = tp->value;
+ return tp->type;
+ }
+ }
+ }
+
+ for (tp = OtherTable; tp->name; tp++) {
+ if (strcmp(buff, tp->name) == 0) {
+ TclDatelval.Number = tp->value;
+ return tp->type;
+ }
+ }
+
+ /*
+ * Military timezones.
+ */
+ if (buff[1] == '\0' && isalpha(*buff)) {
+ for (tp = MilitaryTable; tp->name; tp++) {
+ if (strcmp(buff, tp->name) == 0) {
+ TclDatelval.Number = tp->value;
+ return tp->type;
+ }
+ }
+ }
+
+ /*
+ * Drop out any periods and try the timezone table again.
+ */
+ for (i = 0, p = q = buff; *q; q++)
+ if (*q != '.')
+ *p++ = *q;
+ else
+ i++;
+ *p = '\0';
+ if (i)
+ for (tp = TimezoneTable; tp->name; tp++) {
+ if (strcmp(buff, tp->name) == 0) {
+ TclDatelval.Number = tp->value;
+ return tp->type;
+ }
+ }
+
+ return tID;
+}
+
+
+static int
+TclDatelex()
+{
+ register char c;
+ register char *p;
+ char buff[20];
+ int Count;
+ int sign;
+
+ for ( ; ; ) {
+ while (isspace((unsigned char) (*TclDateInput))) {
+ TclDateInput++;
+ }
+
+ if (isdigit(c = *TclDateInput) || c == '-' || c == '+') {
+ if (c == '-' || c == '+') {
+ sign = c == '-' ? -1 : 1;
+ if (!isdigit(*++TclDateInput)) {
+ /*
+ * skip the '-' sign
+ */
+ continue;
+ }
+ } else {
+ sign = 0;
+ }
+ for (TclDatelval.Number = 0; isdigit(c = *TclDateInput++); ) {
+ TclDatelval.Number = 10 * TclDatelval.Number + c - '0';
+ }
+ TclDateInput--;
+ if (sign < 0) {
+ TclDatelval.Number = -TclDatelval.Number;
+ }
+ return sign ? tSNUMBER : tUNUMBER;
+ }
+ if (isalpha(c)) {
+ for (p = buff; isalpha(c = *TclDateInput++) || c == '.'; ) {
+ if (p < &buff[sizeof buff - 1]) {
+ *p++ = c;
+ }
+ }
+ *p = '\0';
+ TclDateInput--;
+ return LookupWord(buff);
+ }
+ if (c != '(') {
+ return *TclDateInput++;
+ }
+ Count = 0;
+ do {
+ c = *TclDateInput++;
+ if (c == '\0') {
+ return c;
+ } else if (c == '(') {
+ Count++;
+ } else if (c == ')') {
+ Count--;
+ }
+ } while (Count > 0);
+ }
+}
+
+/*
+ * Specify zone is of -50000 to force GMT. (This allows BST to work).
+ */
+
+int
+TclGetDate(p, now, zone, timePtr)
+ char *p;
+ unsigned long now;
+ long zone;
+ unsigned long *timePtr;
+{
+ struct tm *tm;
+ time_t Start;
+ time_t Time;
+ time_t tod;
+
+ TclDateInput = p;
+ tm = localtime((time_t *) &now);
+ TclDateYear = tm->tm_year;
+ TclDateMonth = tm->tm_mon + 1;
+ TclDateDay = tm->tm_mday;
+ TclDateTimezone = zone;
+ if (zone == -50000) {
+ TclDateDSTmode = DSToff; /* assume GMT */
+ TclDateTimezone = 0;
+ } else {
+ TclDateDSTmode = DSTmaybe;
+ }
+ TclDateHour = 0;
+ TclDateMinutes = 0;
+ TclDateSeconds = 0;
+ TclDateMeridian = MER24;
+ TclDateRelSeconds = 0;
+ TclDateRelMonth = 0;
+ TclDateHaveDate = 0;
+ TclDateHaveDay = 0;
+ TclDateHaveRel = 0;
+ TclDateHaveTime = 0;
+ TclDateHaveZone = 0;
+
+ if (TclDateparse() || TclDateHaveTime > 1 || TclDateHaveZone > 1 || TclDateHaveDate > 1 ||
+ TclDateHaveDay > 1) {
+ return -1;
+ }
+
+ if (TclDateHaveDate || TclDateHaveTime || TclDateHaveDay) {
+ if (Convert(TclDateMonth, TclDateDay, TclDateYear, TclDateHour, TclDateMinutes, TclDateSeconds,
+ TclDateMeridian, TclDateDSTmode, &Start) < 0)
+ return -1;
+ }
+ else {
+ Start = now;
+ if (!TclDateHaveRel)
+ Start -= ((tm->tm_hour * 60L) + tm->tm_min * 60L) + tm->tm_sec;
+ }
+
+ Start += TclDateRelSeconds;
+ if (RelativeMonth(Start, TclDateRelMonth, &Time) < 0) {
+ return -1;
+ }
+ Start += Time;
+
+ if (TclDateHaveDay && !TclDateHaveDate) {
+ tod = RelativeDate(Start, TclDateDayOrdinal, TclDateDayNumber);
+ Start += tod;
+ }
+
+ *timePtr = Start;
+ return 0;
+}
+TclDatetabelem TclDateexca[] ={
+-1, 1,
+ 0, -1,
+ -2, 0,
+ };
+# define YYNPROD 41
+# define YYLAST 227
+TclDatetabelem TclDateact[]={
+
+ 14, 11, 23, 28, 17, 12, 19, 18, 16, 9,
+ 10, 13, 42, 21, 46, 45, 44, 48, 41, 37,
+ 36, 35, 32, 29, 34, 33, 31, 43, 39, 38,
+ 30, 15, 8, 7, 6, 5, 4, 3, 2, 1,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 47, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 22, 0, 0, 20, 25, 24, 27,
+ 26, 42, 0, 0, 0, 0, 40 };
+TclDatetabelem TclDatepact[]={
+
+-10000000, -258,-10000000,-10000000,-10000000,-10000000,-10000000,-10000000,-10000000, -45,
+ -267,-10000000, -244,-10000000, -14, -231, -240,-10000000,-10000000,-10000000,
+-10000000, -246,-10000000, -247, -248,-10000000,-10000000,-10000000,-10000000, -15,
+-10000000,-10000000,-10000000,-10000000,-10000000, -40, -20,-10000000, -251,-10000000,
+-10000000, -252,-10000000, -253,-10000000, -249,-10000000,-10000000,-10000000 };
+TclDatetabelem TclDatepgo[]={
+
+ 0, 28, 39, 38, 37, 36, 35, 34, 33, 32,
+ 31 };
+TclDatetabelem TclDater1[]={
+
+ 0, 2, 2, 3, 3, 3, 3, 3, 3, 4,
+ 4, 4, 4, 4, 5, 5, 5, 7, 7, 7,
+ 6, 6, 6, 6, 6, 6, 6, 8, 8, 10,
+ 10, 10, 10, 10, 10, 10, 10, 10, 9, 1,
+ 1 };
+TclDatetabelem TclDater2[]={
+
+ 0, 0, 4, 3, 3, 3, 3, 3, 2, 5,
+ 9, 9, 13, 13, 5, 3, 3, 3, 5, 5,
+ 7, 11, 5, 9, 5, 3, 7, 5, 2, 5,
+ 5, 3, 5, 5, 3, 5, 5, 3, 3, 1,
+ 3 };
+TclDatetabelem TclDatechk[]={
+
+-10000000, -2, -3, -4, -5, -6, -7, -8, -9, 267,
+ 268, 259, 263, 269, 258, -10, 266, 262, 265, 264,
+ 261, 58, 258, 47, 263, 262, 265, 264, 270, 267,
+ 44, 257, 262, 265, 264, 267, 267, 267, 44, -1,
+ 266, 58, 261, 47, 267, 267, 267, -1, 266 };
+TclDatetabelem TclDatedef[]={
+
+ 1, -2, 2, 3, 4, 5, 6, 7, 8, 38,
+ 15, 16, 0, 25, 17, 28, 0, 31, 34, 37,
+ 9, 0, 19, 0, 24, 29, 33, 36, 14, 22,
+ 18, 27, 30, 32, 35, 39, 20, 26, 0, 10,
+ 11, 0, 40, 0, 23, 39, 21, 12, 13 };
+typedef struct
+#ifdef __cplusplus
+ TclDatetoktype
+#endif
+{ char *t_name; int t_val; } TclDatetoktype;
+#ifndef YYDEBUG
+# define YYDEBUG 0 /* don't allow debugging */
+#endif
+
+#if YYDEBUG
+
+TclDatetoktype TclDatetoks[] =
+{
+ "tAGO", 257,
+ "tDAY", 258,
+ "tDAYZONE", 259,
+ "tID", 260,
+ "tMERIDIAN", 261,
+ "tMINUTE_UNIT", 262,
+ "tMONTH", 263,
+ "tMONTH_UNIT", 264,
+ "tSEC_UNIT", 265,
+ "tSNUMBER", 266,
+ "tUNUMBER", 267,
+ "tZONE", 268,
+ "tEPOCH", 269,
+ "tDST", 270,
+ "-unknown-", -1 /* ends search */
+};
+
+char * TclDatereds[] =
+{
+ "-no such reduction-",
+ "spec : /* empty */",
+ "spec : spec item",
+ "item : time",
+ "item : zone",
+ "item : date",
+ "item : day",
+ "item : rel",
+ "item : number",
+ "time : tUNUMBER tMERIDIAN",
+ "time : tUNUMBER ':' tUNUMBER o_merid",
+ "time : tUNUMBER ':' tUNUMBER tSNUMBER",
+ "time : tUNUMBER ':' tUNUMBER ':' tUNUMBER o_merid",
+ "time : tUNUMBER ':' tUNUMBER ':' tUNUMBER tSNUMBER",
+ "zone : tZONE tDST",
+ "zone : tZONE",
+ "zone : tDAYZONE",
+ "day : tDAY",
+ "day : tDAY ','",
+ "day : tUNUMBER tDAY",
+ "date : tUNUMBER '/' tUNUMBER",
+ "date : tUNUMBER '/' tUNUMBER '/' tUNUMBER",
+ "date : tMONTH tUNUMBER",
+ "date : tMONTH tUNUMBER ',' tUNUMBER",
+ "date : tUNUMBER tMONTH",
+ "date : tEPOCH",
+ "date : tUNUMBER tMONTH tUNUMBER",
+ "rel : relunit tAGO",
+ "rel : relunit",
+ "relunit : tUNUMBER tMINUTE_UNIT",
+ "relunit : tSNUMBER tMINUTE_UNIT",
+ "relunit : tMINUTE_UNIT",
+ "relunit : tSNUMBER tSEC_UNIT",
+ "relunit : tUNUMBER tSEC_UNIT",
+ "relunit : tSEC_UNIT",
+ "relunit : tSNUMBER tMONTH_UNIT",
+ "relunit : tUNUMBER tMONTH_UNIT",
+ "relunit : tMONTH_UNIT",
+ "number : tUNUMBER",
+ "o_merid : /* empty */",
+ "o_merid : tMERIDIAN",
+};
+#endif /* YYDEBUG */
+/*
+ * Copyright (c) 1993 by Sun Microsystems, Inc.
+ */
+
+
+/*
+** Skeleton parser driver for yacc output
+*/
+
+/*
+** yacc user known macros and defines
+*/
+#define YYERROR goto TclDateerrlab
+#define YYACCEPT return(0)
+#define YYABORT return(1)
+#define YYBACKUP( newtoken, newvalue )\
+{\
+ if ( TclDatechar >= 0 || ( TclDater2[ TclDatetmp ] >> 1 ) != 1 )\
+ {\
+ TclDateerror( "syntax error - cannot backup" );\
+ goto TclDateerrlab;\
+ }\
+ TclDatechar = newtoken;\
+ TclDatestate = *TclDateps;\
+ TclDatelval = newvalue;\
+ goto TclDatenewstate;\
+}
+#define YYRECOVERING() (!!TclDateerrflag)
+#define YYNEW(type) malloc(sizeof(type) * TclDatenewmax)
+#define YYCOPY(to, from, type) \
+ (type *) memcpy(to, (char *) from, TclDatenewmax * sizeof(type))
+#define YYENLARGE( from, type) \
+ (type *) realloc((char *) from, TclDatenewmax * sizeof(type))
+#ifndef YYDEBUG
+# define YYDEBUG 1 /* make debugging available */
+#endif
+
+/*
+** user known globals
+*/
+int TclDatedebug; /* set to 1 to get debugging */
+
+/*
+** driver internal defines
+*/
+#define YYFLAG (-10000000)
+
+/*
+** global variables used by the parser
+*/
+YYSTYPE *TclDatepv; /* top of value stack */
+int *TclDateps; /* top of state stack */
+
+int TclDatestate; /* current state */
+int TclDatetmp; /* extra var (lasts between blocks) */
+
+int TclDatenerrs; /* number of errors */
+int TclDateerrflag; /* error recovery flag */
+int TclDatechar; /* current input token number */
+
+
+
+#ifdef YYNMBCHARS
+#define YYLEX() TclDatecvtok(TclDatelex())
+/*
+** TclDatecvtok - return a token if i is a wchar_t value that exceeds 255.
+** If i<255, i itself is the token. If i>255 but the neither
+** of the 30th or 31st bit is on, i is already a token.
+*/
+#if defined(__STDC__) || defined(__cplusplus)
+int TclDatecvtok(int i)
+#else
+int TclDatecvtok(i) int i;
+#endif
+{
+ int first = 0;
+ int last = YYNMBCHARS - 1;
+ int mid;
+ wchar_t j;
+
+ if(i&0x60000000){/*Must convert to a token. */
+ if( TclDatembchars[last].character < i ){
+ return i;/*Giving up*/
+ }
+ while ((last>=first)&&(first>=0)) {/*Binary search loop*/
+ mid = (first+last)/2;
+ j = TclDatembchars[mid].character;
+ if( j==i ){/*Found*/
+ return TclDatembchars[mid].tvalue;
+ }else if( j<i ){
+ first = mid + 1;
+ }else{
+ last = mid -1;
+ }
+ }
+ /*No entry in the table.*/
+ return i;/* Giving up.*/
+ }else{/* i is already a token. */
+ return i;
+ }
+}
+#else/*!YYNMBCHARS*/
+#define YYLEX() TclDatelex()
+#endif/*!YYNMBCHARS*/
+
+/*
+** TclDateparse - return 0 if worked, 1 if syntax error not recovered from
+*/
+#if defined(__STDC__) || defined(__cplusplus)
+int TclDateparse(void)
+#else
+int TclDateparse()
+#endif
+{
+ register YYSTYPE *TclDatepvt; /* top of value stack for $vars */
+
+#if defined(__cplusplus) || defined(lint)
+/*
+ hacks to please C++ and lint - goto's inside switch should never be
+ executed; TclDatepvt is set to 0 to avoid "used before set" warning.
+*/
+ static int __yaccpar_lint_hack__ = 0;
+ switch (__yaccpar_lint_hack__)
+ {
+ case 1: goto TclDateerrlab;
+ case 2: goto TclDatenewstate;
+ }
+ TclDatepvt = 0;
+#endif
+
+ /*
+ ** Initialize externals - TclDateparse may be called more than once
+ */
+ TclDatepv = &TclDatev[-1];
+ TclDateps = &TclDates[-1];
+ TclDatestate = 0;
+ TclDatetmp = 0;
+ TclDatenerrs = 0;
+ TclDateerrflag = 0;
+ TclDatechar = -1;
+
+#if YYMAXDEPTH <= 0
+ if (TclDatemaxdepth <= 0)
+ {
+ if ((TclDatemaxdepth = YYEXPAND(0)) <= 0)
+ {
+ TclDateerror("yacc initialization error");
+ YYABORT;
+ }
+ }
+#endif
+
+ {
+ register YYSTYPE *TclDate_pv; /* top of value stack */
+ register int *TclDate_ps; /* top of state stack */
+ register int TclDate_state; /* current state */
+ register int TclDate_n; /* internal state number info */
+ goto TclDatestack; /* moved from 6 lines above to here to please C++ */
+
+ /*
+ ** get globals into registers.
+ ** branch to here only if YYBACKUP was called.
+ */
+ TclDate_pv = TclDatepv;
+ TclDate_ps = TclDateps;
+ TclDate_state = TclDatestate;
+ goto TclDate_newstate;
+
+ /*
+ ** get globals into registers.
+ ** either we just started, or we just finished a reduction
+ */
+ TclDatestack:
+ TclDate_pv = TclDatepv;
+ TclDate_ps = TclDateps;
+ TclDate_state = TclDatestate;
+
+ /*
+ ** top of for (;;) loop while no reductions done
+ */
+ TclDate_stack:
+ /*
+ ** put a state and value onto the stacks
+ */
+#if YYDEBUG
+ /*
+ ** if debugging, look up token value in list of value vs.
+ ** name pairs. 0 and negative (-1) are special values.
+ ** Note: linear search is used since time is not a real
+ ** consideration while debugging.
+ */
+ if ( TclDatedebug )
+ {
+ register int TclDate_i;
+
+ printf( "State %d, token ", TclDate_state );
+ if ( TclDatechar == 0 )
+ printf( "end-of-file\n" );
+ else if ( TclDatechar < 0 )
+ printf( "-none-\n" );
+ else
+ {
+ for ( TclDate_i = 0; TclDatetoks[TclDate_i].t_val >= 0;
+ TclDate_i++ )
+ {
+ if ( TclDatetoks[TclDate_i].t_val == TclDatechar )
+ break;
+ }
+ printf( "%s\n", TclDatetoks[TclDate_i].t_name );
+ }
+ }
+#endif /* YYDEBUG */
+ if ( ++TclDate_ps >= &TclDates[ TclDatemaxdepth ] ) /* room on stack? */
+ {
+ /*
+ ** reallocate and recover. Note that pointers
+ ** have to be reset, or bad things will happen
+ */
+ int TclDateps_index = (TclDate_ps - TclDates);
+ int TclDatepv_index = (TclDate_pv - TclDatev);
+ int TclDatepvt_index = (TclDatepvt - TclDatev);
+ int TclDatenewmax;
+#ifdef YYEXPAND
+ TclDatenewmax = YYEXPAND(TclDatemaxdepth);
+#else
+ TclDatenewmax = 2 * TclDatemaxdepth; /* double table size */
+ if (TclDatemaxdepth == YYMAXDEPTH) /* first time growth */
+ {
+ char *newTclDates = (char *)YYNEW(int);
+ char *newTclDatev = (char *)YYNEW(YYSTYPE);
+ if (newTclDates != 0 && newTclDatev != 0)
+ {
+ TclDates = YYCOPY(newTclDates, TclDates, int);
+ TclDatev = YYCOPY(newTclDatev, TclDatev, YYSTYPE);
+ }
+ else
+ TclDatenewmax = 0; /* failed */
+ }
+ else /* not first time */
+ {
+ TclDates = YYENLARGE(TclDates, int);
+ TclDatev = YYENLARGE(TclDatev, YYSTYPE);
+ if (TclDates == 0 || TclDatev == 0)
+ TclDatenewmax = 0; /* failed */
+ }
+#endif
+ if (TclDatenewmax <= TclDatemaxdepth) /* tables not expanded */
+ {
+ TclDateerror( "yacc stack overflow" );
+ YYABORT;
+ }
+ TclDatemaxdepth = TclDatenewmax;
+
+ TclDate_ps = TclDates + TclDateps_index;
+ TclDate_pv = TclDatev + TclDatepv_index;
+ TclDatepvt = TclDatev + TclDatepvt_index;
+ }
+ *TclDate_ps = TclDate_state;
+ *++TclDate_pv = TclDateval;
+
+ /*
+ ** we have a new state - find out what to do
+ */
+ TclDate_newstate:
+ if ( ( TclDate_n = TclDatepact[ TclDate_state ] ) <= YYFLAG )
+ goto TclDatedefault; /* simple state */
+#if YYDEBUG
+ /*
+ ** if debugging, need to mark whether new token grabbed
+ */
+ TclDatetmp = TclDatechar < 0;
+#endif
+ if ( ( TclDatechar < 0 ) && ( ( TclDatechar = YYLEX() ) < 0 ) )
+ TclDatechar = 0; /* reached EOF */
+#if YYDEBUG
+ if ( TclDatedebug && TclDatetmp )
+ {
+ register int TclDate_i;
+
+ printf( "Received token " );
+ if ( TclDatechar == 0 )
+ printf( "end-of-file\n" );
+ else if ( TclDatechar < 0 )
+ printf( "-none-\n" );
+ else
+ {
+ for ( TclDate_i = 0; TclDatetoks[TclDate_i].t_val >= 0;
+ TclDate_i++ )
+ {
+ if ( TclDatetoks[TclDate_i].t_val == TclDatechar )
+ break;
+ }
+ printf( "%s\n", TclDatetoks[TclDate_i].t_name );
+ }
+ }
+#endif /* YYDEBUG */
+ if ( ( ( TclDate_n += TclDatechar ) < 0 ) || ( TclDate_n >= YYLAST ) )
+ goto TclDatedefault;
+ if ( TclDatechk[ TclDate_n = TclDateact[ TclDate_n ] ] == TclDatechar ) /*valid shift*/
+ {
+ TclDatechar = -1;
+ TclDateval = TclDatelval;
+ TclDate_state = TclDate_n;
+ if ( TclDateerrflag > 0 )
+ TclDateerrflag--;
+ goto TclDate_stack;
+ }
+
+ TclDatedefault:
+ if ( ( TclDate_n = TclDatedef[ TclDate_state ] ) == -2 )
+ {
+#if YYDEBUG
+ TclDatetmp = TclDatechar < 0;
+#endif
+ if ( ( TclDatechar < 0 ) && ( ( TclDatechar = YYLEX() ) < 0 ) )
+ TclDatechar = 0; /* reached EOF */
+#if YYDEBUG
+ if ( TclDatedebug && TclDatetmp )
+ {
+ register int TclDate_i;
+
+ printf( "Received token " );
+ if ( TclDatechar == 0 )
+ printf( "end-of-file\n" );
+ else if ( TclDatechar < 0 )
+ printf( "-none-\n" );
+ else
+ {
+ for ( TclDate_i = 0;
+ TclDatetoks[TclDate_i].t_val >= 0;
+ TclDate_i++ )
+ {
+ if ( TclDatetoks[TclDate_i].t_val
+ == TclDatechar )
+ {
+ break;
+ }
+ }
+ printf( "%s\n", TclDatetoks[TclDate_i].t_name );
+ }
+ }
+#endif /* YYDEBUG */
+ /*
+ ** look through exception table
+ */
+ {
+ register int *TclDatexi = TclDateexca;
+
+ while ( ( *TclDatexi != -1 ) ||
+ ( TclDatexi[1] != TclDate_state ) )
+ {
+ TclDatexi += 2;
+ }
+ while ( ( *(TclDatexi += 2) >= 0 ) &&
+ ( *TclDatexi != TclDatechar ) )
+ ;
+ if ( ( TclDate_n = TclDatexi[1] ) < 0 )
+ YYACCEPT;
+ }
+ }
+
+ /*
+ ** check for syntax error
+ */
+ if ( TclDate_n == 0 ) /* have an error */
+ {
+ /* no worry about speed here! */
+ switch ( TclDateerrflag )
+ {
+ case 0: /* new error */
+ TclDateerror( "syntax error" );
+ goto skip_init;
+ /*
+ ** get globals into registers.
+ ** we have a user generated syntax type error
+ */
+ TclDate_pv = TclDatepv;
+ TclDate_ps = TclDateps;
+ TclDate_state = TclDatestate;
+ skip_init:
+ TclDatenerrs++;
+ /* FALLTHRU */
+ case 1:
+ case 2: /* incompletely recovered error */
+ /* try again... */
+ TclDateerrflag = 3;
+ /*
+ ** find state where "error" is a legal
+ ** shift action
+ */
+ while ( TclDate_ps >= TclDates )
+ {
+ TclDate_n = TclDatepact[ *TclDate_ps ] + YYERRCODE;
+ if ( TclDate_n >= 0 && TclDate_n < YYLAST &&
+ TclDatechk[TclDateact[TclDate_n]] == YYERRCODE) {
+ /*
+ ** simulate shift of "error"
+ */
+ TclDate_state = TclDateact[ TclDate_n ];
+ goto TclDate_stack;
+ }
+ /*
+ ** current state has no shift on
+ ** "error", pop stack
+ */
+#if YYDEBUG
+# define _POP_ "Error recovery pops state %d, uncovers state %d\n"
+ if ( TclDatedebug )
+ printf( _POP_, *TclDate_ps,
+ TclDate_ps[-1] );
+# undef _POP_
+#endif
+ TclDate_ps--;
+ TclDate_pv--;
+ }
+ /*
+ ** there is no state on stack with "error" as
+ ** a valid shift. give up.
+ */
+ YYABORT;
+ case 3: /* no shift yet; eat a token */
+#if YYDEBUG
+ /*
+ ** if debugging, look up token in list of
+ ** pairs. 0 and negative shouldn't occur,
+ ** but since timing doesn't matter when
+ ** debugging, it doesn't hurt to leave the
+ ** tests here.
+ */
+ if ( TclDatedebug )
+ {
+ register int TclDate_i;
+
+ printf( "Error recovery discards " );
+ if ( TclDatechar == 0 )
+ printf( "token end-of-file\n" );
+ else if ( TclDatechar < 0 )
+ printf( "token -none-\n" );
+ else
+ {
+ for ( TclDate_i = 0;
+ TclDatetoks[TclDate_i].t_val >= 0;
+ TclDate_i++ )
+ {
+ if ( TclDatetoks[TclDate_i].t_val
+ == TclDatechar )
+ {
+ break;
+ }
+ }
+ printf( "token %s\n",
+ TclDatetoks[TclDate_i].t_name );
+ }
+ }
+#endif /* YYDEBUG */
+ if ( TclDatechar == 0 ) /* reached EOF. quit */
+ YYABORT;
+ TclDatechar = -1;
+ goto TclDate_newstate;
+ }
+ }/* end if ( TclDate_n == 0 ) */
+ /*
+ ** reduction by production TclDate_n
+ ** put stack tops, etc. so things right after switch
+ */
+#if YYDEBUG
+ /*
+ ** if debugging, print the string that is the user's
+ ** specification of the reduction which is just about
+ ** to be done.
+ */
+ if ( TclDatedebug )
+ printf( "Reduce by (%d) \"%s\"\n",
+ TclDate_n, TclDatereds[ TclDate_n ] );
+#endif
+ TclDatetmp = TclDate_n; /* value to switch over */
+ TclDatepvt = TclDate_pv; /* $vars top of value stack */
+ /*
+ ** Look in goto table for next state
+ ** Sorry about using TclDate_state here as temporary
+ ** register variable, but why not, if it works...
+ ** If TclDater2[ TclDate_n ] doesn't have the low order bit
+ ** set, then there is no action to be done for
+ ** this reduction. So, no saving & unsaving of
+ ** registers done. The only difference between the
+ ** code just after the if and the body of the if is
+ ** the goto TclDate_stack in the body. This way the test
+ ** can be made before the choice of what to do is needed.
+ */
+ {
+ /* length of production doubled with extra bit */
+ register int TclDate_len = TclDater2[ TclDate_n ];
+
+ if ( !( TclDate_len & 01 ) )
+ {
+ TclDate_len >>= 1;
+ TclDateval = ( TclDate_pv -= TclDate_len )[1]; /* $$ = $1 */
+ TclDate_state = TclDatepgo[ TclDate_n = TclDater1[ TclDate_n ] ] +
+ *( TclDate_ps -= TclDate_len ) + 1;
+ if ( TclDate_state >= YYLAST ||
+ TclDatechk[ TclDate_state =
+ TclDateact[ TclDate_state ] ] != -TclDate_n )
+ {
+ TclDate_state = TclDateact[ TclDatepgo[ TclDate_n ] ];
+ }
+ goto TclDate_stack;
+ }
+ TclDate_len >>= 1;
+ TclDateval = ( TclDate_pv -= TclDate_len )[1]; /* $$ = $1 */
+ TclDate_state = TclDatepgo[ TclDate_n = TclDater1[ TclDate_n ] ] +
+ *( TclDate_ps -= TclDate_len ) + 1;
+ if ( TclDate_state >= YYLAST ||
+ TclDatechk[ TclDate_state = TclDateact[ TclDate_state ] ] != -TclDate_n )
+ {
+ TclDate_state = TclDateact[ TclDatepgo[ TclDate_n ] ];
+ }
+ }
+ /* save until reenter driver code */
+ TclDatestate = TclDate_state;
+ TclDateps = TclDate_ps;
+ TclDatepv = TclDate_pv;
+ }
+ /*
+ ** code supplied by user is placed in this switch
+ */
+ switch( TclDatetmp )
+ {
+
+case 3:{
+ TclDateHaveTime++;
+ } break;
+case 4:{
+ TclDateHaveZone++;
+ } break;
+case 5:{
+ TclDateHaveDate++;
+ } break;
+case 6:{
+ TclDateHaveDay++;
+ } break;
+case 7:{
+ TclDateHaveRel++;
+ } break;
+case 9:{
+ TclDateHour = TclDatepvt[-1].Number;
+ TclDateMinutes = 0;
+ TclDateSeconds = 0;
+ TclDateMeridian = TclDatepvt[-0].Meridian;
+ } break;
+case 10:{
+ TclDateHour = TclDatepvt[-3].Number;
+ TclDateMinutes = TclDatepvt[-1].Number;
+ TclDateSeconds = 0;
+ TclDateMeridian = TclDatepvt[-0].Meridian;
+ } break;
+case 11:{
+ TclDateHour = TclDatepvt[-3].Number;
+ TclDateMinutes = TclDatepvt[-1].Number;
+ TclDateMeridian = MER24;
+ TclDateDSTmode = DSToff;
+ TclDateTimezone = - (TclDatepvt[-0].Number % 100 + (TclDatepvt[-0].Number / 100) * 60);
+ } break;
+case 12:{
+ TclDateHour = TclDatepvt[-5].Number;
+ TclDateMinutes = TclDatepvt[-3].Number;
+ TclDateSeconds = TclDatepvt[-1].Number;
+ TclDateMeridian = TclDatepvt[-0].Meridian;
+ } break;
+case 13:{
+ TclDateHour = TclDatepvt[-5].Number;
+ TclDateMinutes = TclDatepvt[-3].Number;
+ TclDateSeconds = TclDatepvt[-1].Number;
+ TclDateMeridian = MER24;
+ TclDateDSTmode = DSToff;
+ TclDateTimezone = - (TclDatepvt[-0].Number % 100 + (TclDatepvt[-0].Number / 100) * 60);
+ } break;
+case 14:{
+ TclDateTimezone = TclDatepvt[-1].Number;
+ TclDateDSTmode = DSTon;
+ } break;
+case 15:{
+ TclDateTimezone = TclDatepvt[-0].Number;
+ TclDateDSTmode = DSToff;
+ } break;
+case 16:{
+ TclDateTimezone = TclDatepvt[-0].Number;
+ TclDateDSTmode = DSTon;
+ } break;
+case 17:{
+ TclDateDayOrdinal = 1;
+ TclDateDayNumber = TclDatepvt[-0].Number;
+ } break;
+case 18:{
+ TclDateDayOrdinal = 1;
+ TclDateDayNumber = TclDatepvt[-1].Number;
+ } break;
+case 19:{
+ TclDateDayOrdinal = TclDatepvt[-1].Number;
+ TclDateDayNumber = TclDatepvt[-0].Number;
+ } break;
+case 20:{
+ TclDateMonth = TclDatepvt[-2].Number;
+ TclDateDay = TclDatepvt[-0].Number;
+ } break;
+case 21:{
+ TclDateMonth = TclDatepvt[-4].Number;
+ TclDateDay = TclDatepvt[-2].Number;
+ TclDateYear = TclDatepvt[-0].Number;
+ } break;
+case 22:{
+ TclDateMonth = TclDatepvt[-1].Number;
+ TclDateDay = TclDatepvt[-0].Number;
+ } break;
+case 23:{
+ TclDateMonth = TclDatepvt[-3].Number;
+ TclDateDay = TclDatepvt[-2].Number;
+ TclDateYear = TclDatepvt[-0].Number;
+ } break;
+case 24:{
+ TclDateMonth = TclDatepvt[-0].Number;
+ TclDateDay = TclDatepvt[-1].Number;
+ } break;
+case 25:{
+ TclDateMonth = 1;
+ TclDateDay = 1;
+ TclDateYear = EPOCH;
+ } break;
+case 26:{
+ TclDateMonth = TclDatepvt[-1].Number;
+ TclDateDay = TclDatepvt[-2].Number;
+ TclDateYear = TclDatepvt[-0].Number;
+ } break;
+case 27:{
+ TclDateRelSeconds = -TclDateRelSeconds;
+ TclDateRelMonth = -TclDateRelMonth;
+ } break;
+case 29:{
+ TclDateRelSeconds += TclDatepvt[-1].Number * TclDatepvt[-0].Number * 60L;
+ } break;
+case 30:{
+ TclDateRelSeconds += TclDatepvt[-1].Number * TclDatepvt[-0].Number * 60L;
+ } break;
+case 31:{
+ TclDateRelSeconds += TclDatepvt[-0].Number * 60L;
+ } break;
+case 32:{
+ TclDateRelSeconds += TclDatepvt[-1].Number;
+ } break;
+case 33:{
+ TclDateRelSeconds += TclDatepvt[-1].Number;
+ } break;
+case 34:{
+ TclDateRelSeconds++;
+ } break;
+case 35:{
+ TclDateRelMonth += TclDatepvt[-1].Number * TclDatepvt[-0].Number;
+ } break;
+case 36:{
+ TclDateRelMonth += TclDatepvt[-1].Number * TclDatepvt[-0].Number;
+ } break;
+case 37:{
+ TclDateRelMonth += TclDatepvt[-0].Number;
+ } break;
+case 38:{
+ if (TclDateHaveTime && TclDateHaveDate && !TclDateHaveRel)
+ TclDateYear = TclDatepvt[-0].Number;
+ else {
+ TclDateHaveTime++;
+ if (TclDatepvt[-0].Number < 100) {
+ TclDateHour = TclDatepvt[-0].Number;
+ TclDateMinutes = 0;
+ }
+ else {
+ TclDateHour = TclDatepvt[-0].Number / 100;
+ TclDateMinutes = TclDatepvt[-0].Number % 100;
+ }
+ TclDateSeconds = 0;
+ TclDateMeridian = MER24;
+ }
+ } break;
+case 39:{
+ TclDateval.Meridian = MER24;
+ } break;
+case 40:{
+ TclDateval.Meridian = TclDatepvt[-0].Meridian;
+ } break;
+ }
+ goto TclDatestack; /* reset registers in driver code */
+}
+
diff --git a/contrib/tcl/generic/tclEnv.c b/contrib/tcl/generic/tclEnv.c
new file mode 100644
index 000000000000..4b92cc29c55a
--- /dev/null
+++ b/contrib/tcl/generic/tclEnv.c
@@ -0,0 +1,604 @@
+/*
+ * 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-1996 Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * SCCS: @(#) tclEnv.c 1.34 96/04/15 18:18:36
+ */
+
+/*
+ * 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 EnvExitProc _ANSI_ARGS_((ClientData clientData));
+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;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclGetEnv --
+ *
+ * Get an environment variable or return NULL if the variable
+ * doesn't exist. This procedure is intended to be a
+ * stand-in for the UNIX "getenv" procedure so that applications
+ * using that procedure will interface properly to Tcl. To make
+ * it a stand-in, the Makefile must define "TclGetEnv" to "getenv".
+ *
+ * Results:
+ * ptr to value on success, NULL if error.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+char *
+TclGetEnv(name)
+ char *name; /* Name of desired environment variable. */
+{
+ int i;
+ size_t len;
+
+ for (i = 0; environ[i] != NULL; i++) {
+ len = (size_t) ((char *) strchr(environ[i], '=') - environ[i]);
+ if ((len > 0 && !strncmp(name, environ[i], len))
+ || (*name == '\0')) {
+ /*
+ * The caller of this function should regard this
+ * as static memory.
+ */
+ return &environ[i][len+1];
+ }
+ }
+
+ return NULL;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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);
+ }
+
+ /*
+ * Update the system environment.
+ */
+
+ TclSetSystemEnv(name, value);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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 = (char *) 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);
+ }
+
+ /*
+ * Update the system environment.
+ */
+
+ TclSetSystemEnv(name, NULL);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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()
+{
+#ifdef MAC_TCL
+ environSize = TclMacCreateEnv();
+#else
+ 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;
+ Tcl_CreateExitHandler(EnvExitProc, (ClientData) NULL);
+#endif
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * EnvExitProc --
+ *
+ * This procedure is called just before the process exits. It
+ * frees the memory associated with environment variables.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Memory is freed.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+EnvExitProc(clientData)
+ ClientData clientData; /* Not used. */
+{
+ char **p;
+
+ for (p = environ; *p != NULL; p++) {
+ ckfree(*p);
+ }
+ ckfree((char *) environ);
+}
diff --git a/contrib/tcl/generic/tclEvent.c b/contrib/tcl/generic/tclEvent.c
new file mode 100644
index 000000000000..3c9f7d249ef1
--- /dev/null
+++ b/contrib/tcl/generic/tclEvent.c
@@ -0,0 +1,2187 @@
+/*
+ * tclEvent.c --
+ *
+ * This file provides basic event-managing facilities for Tcl,
+ * including an event queue, and mechanisms for attaching
+ * callbacks to certain events.
+ *
+ * It also contains the command procedures for the commands
+ * "after", "vwait", and "update".
+ *
+ * Copyright (c) 1990-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.
+ *
+ * SCCS: @(#) tclEvent.c 1.127 96/03/22 12:12:33
+ */
+
+#include "tclInt.h"
+#include "tclPort.h"
+
+/*
+ * For each file registered in a call to Tcl_CreateFileHandler,
+ * there is one record of the following type. All of these records
+ * are chained together into a single list.
+ */
+
+typedef struct FileHandler {
+ Tcl_File file; /* Generic file handle for file. */
+ int mask; /* Mask of desired events: TCL_READABLE, etc. */
+ int readyMask; /* Events that were ready the last time that
+ * FileHandlerCheckProc checked this file. */
+ Tcl_FileProc *proc; /* Procedure to call, in the style of
+ * Tcl_CreateFileHandler. This is NULL
+ * if the handler was created by
+ * Tcl_CreateFileHandler2. */
+ ClientData clientData; /* Argument to pass to proc. */
+ struct FileHandler *nextPtr;/* Next in list of all files we care
+ * about (NULL for end of list). */
+} FileHandler;
+
+static FileHandler *firstFileHandlerPtr = (FileHandler *) NULL;
+ /* List of all file handlers. */
+static int fileEventSourceCreated = 0;
+ /* Non-zero means that the file event source
+ * hasn't been registerd with the Tcl
+ * notifier yet. */
+
+/*
+ * The following structure is what is added to the Tcl event queue when
+ * file handlers are ready to fire.
+ */
+
+typedef struct FileHandlerEvent {
+ Tcl_Event header; /* Information that is standard for
+ * all events. */
+ Tcl_File file; /* File descriptor that is ready. Used
+ * to find the FileHandler structure for
+ * the file (can't point directly to the
+ * FileHandler structure because it could
+ * go away while the event is queued). */
+} FileHandlerEvent;
+
+/*
+ * For each timer callback that's pending (either regular or "modal"),
+ * there is one record of the following type. The normal handlers
+ * (created by Tcl_CreateTimerHandler) are chained together in a
+ * list sorted by time (earliest event first).
+ */
+
+typedef struct TimerHandler {
+ Tcl_Time time; /* When timer is to fire. */
+ Tcl_TimerProc *proc; /* Procedure to call. */
+ ClientData clientData; /* Argument to pass to proc. */
+ Tcl_TimerToken token; /* Identifies event so it can be
+ * deleted. Not used in modal
+ * timeouts. */
+ struct TimerHandler *nextPtr; /* Next event in queue, or NULL for
+ * end of queue. */
+} TimerHandler;
+
+static TimerHandler *firstTimerHandlerPtr = NULL;
+ /* First event in queue. */
+static int timerEventSourceCreated = 0; /* 0 means that the timer event source
+ * hasn't yet been registered with the
+ * Tcl notifier. */
+
+/*
+ * The information below describes a stack of modal timeouts managed by
+ * Tcl_CreateModalTimer and Tcl_DeleteModalTimer. Only the first element
+ * in the list is used at any given time.
+ */
+
+static TimerHandler *firstModalHandlerPtr = NULL;
+
+/*
+ * The following structure is what's added to the Tcl event queue when
+ * timer handlers are ready to fire.
+ */
+
+typedef struct TimerEvent {
+ Tcl_Event header; /* Information that is standard for
+ * all events. */
+ Tcl_Time time; /* All timer events that specify this
+ * time or earlier are ready
+ * to fire. */
+} TimerEvent;
+
+/*
+ * There is one of the following structures for each of the
+ * handlers declared in a call to Tcl_DoWhenIdle. All of the
+ * currently-active handlers are linked together into a list.
+ */
+
+typedef struct IdleHandler {
+ Tcl_IdleProc (*proc); /* Procedure to call. */
+ ClientData clientData; /* Value to pass to proc. */
+ int generation; /* Used to distinguish older handlers from
+ * recently-created ones. */
+ struct IdleHandler *nextPtr;/* Next in list of active handlers. */
+} IdleHandler;
+
+static IdleHandler *idleList = NULL;
+ /* First in list of all idle handlers. */
+static IdleHandler *lastIdlePtr = NULL;
+ /* Last in list (or NULL for empty list). */
+static int idleGeneration = 0; /* Used to fill in the "generation" fields
+ * of IdleHandler structures. Increments
+ * each time Tcl_DoOneEvent starts calling
+ * idle handlers, so that all old handlers
+ * can be called without calling any of the
+ * new ones created by old ones. */
+
+/*
+ * The data structure below is used by the "after" command to remember
+ * the command to be executed later. All of the pending "after" commands
+ * for an interpreter are linked together in a list.
+ */
+
+typedef struct AfterInfo {
+ struct AfterAssocData *assocPtr;
+ /* Pointer to the "tclAfter" assocData for
+ * the interp in which command will be
+ * executed. */
+ char *command; /* Command to execute. Malloc'ed, so must
+ * be freed when structure is deallocated. */
+ int id; /* Integer identifier for command; used to
+ * cancel it. */
+ Tcl_TimerToken token; /* Used to cancel the "after" command. NULL
+ * means that the command is run as an
+ * idle handler rather than as a timer
+ * handler. NULL means this is an "after
+ * idle" handler rather than a
+ * timer handler. */
+ struct AfterInfo *nextPtr; /* Next in list of all "after" commands for
+ * this interpreter. */
+} AfterInfo;
+
+/*
+ * One of the following structures is associated with each interpreter
+ * for which an "after" command has ever been invoked. A pointer to
+ * this structure is stored in the AssocData for the "tclAfter" key.
+ */
+
+typedef struct AfterAssocData {
+ Tcl_Interp *interp; /* The interpreter for which this data is
+ * registered. */
+ AfterInfo *firstAfterPtr; /* First in list of all "after" commands
+ * still pending for this interpreter, or
+ * NULL if none. */
+} AfterAssocData;
+
+/*
+ * The data structure below is used to report background errors. One
+ * such structure is allocated for each error; it holds information
+ * about the interpreter and the error until bgerror can be invoked
+ * later as an idle handler.
+ */
+
+typedef struct BgError {
+ Tcl_Interp *interp; /* Interpreter in which error occurred. NULL
+ * means this error report has been cancelled
+ * (a previous report generated a break). */
+ char *errorMsg; /* The error message (interp->result when
+ * the error occurred). Malloc-ed. */
+ char *errorInfo; /* Value of the errorInfo variable
+ * (malloc-ed). */
+ char *errorCode; /* Value of the errorCode variable
+ * (malloc-ed). */
+ struct BgError *nextPtr; /* Next in list of all pending error
+ * reports for this interpreter, or NULL
+ * for end of list. */
+} BgError;
+
+/*
+ * One of the structures below is associated with the "tclBgError"
+ * assoc data for each interpreter. It keeps track of the head and
+ * tail of the list of pending background errors for the interpreter.
+ */
+
+typedef struct ErrAssocData {
+ BgError *firstBgPtr; /* First in list of all background errors
+ * waiting to be processed for this
+ * interpreter (NULL if none). */
+ BgError *lastBgPtr; /* Last in list of all background errors
+ * waiting to be processed for this
+ * interpreter (NULL if none). */
+} ErrAssocData;
+
+/*
+ * For each exit handler created with a call to Tcl_CreateExitHandler
+ * there is a structure of the following type:
+ */
+
+typedef struct ExitHandler {
+ Tcl_ExitProc *proc; /* Procedure to call when process exits. */
+ ClientData clientData; /* One word of information to pass to proc. */
+ struct ExitHandler *nextPtr;/* Next in list of all exit handlers for
+ * this application, or NULL for end of list. */
+} ExitHandler;
+
+static ExitHandler *firstExitPtr = NULL;
+ /* First in list of all exit handlers for
+ * application. */
+
+/*
+ * Structures of the following type are used during the execution
+ * of Tcl_WaitForFile, to keep track of the file and timeout.
+ */
+
+typedef struct FileWait {
+ Tcl_File file; /* File to wait on. */
+ int mask; /* Conditions to wait for (TCL_READABLE,
+ * etc.) */
+ int timeout; /* Original "timeout" argument to
+ * Tcl_WaitForFile. */
+ Tcl_Time abortTime; /* Time at which to abort the wait. */
+ int present; /* Conditions present on the file during
+ * the last time through the event loop. */
+ int done; /* Non-zero means we're done: either one of
+ * the desired conditions is present or the
+ * timeout period has elapsed. */
+} FileWait;
+
+/*
+ * The following variable is a "secret" indication to Tcl_Exit that
+ * it should dump out the state of memory before exiting. If the
+ * value is non-NULL, it gives the name of the file in which to
+ * dump memory usage information.
+ */
+
+char *tclMemDumpFileName = NULL;
+
+/*
+ * Prototypes for procedures referenced only in this file:
+ */
+
+static void AfterCleanupProc _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp));
+static void AfterProc _ANSI_ARGS_((ClientData clientData));
+static void BgErrorDeleteProc _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp));
+static void FileHandlerCheckProc _ANSI_ARGS_((
+ ClientData clientData, int flags));
+static int FileHandlerEventProc _ANSI_ARGS_((Tcl_Event *evPtr,
+ int flags));
+static void FileHandlerExitProc _ANSI_ARGS_((ClientData data));
+static void FileHandlerSetupProc _ANSI_ARGS_((
+ ClientData clientData, int flags));
+static void FreeAfterPtr _ANSI_ARGS_((AfterInfo *afterPtr));
+static AfterInfo * GetAfterEvent _ANSI_ARGS_((AfterAssocData *assocPtr,
+ char *string));
+static void HandleBgErrors _ANSI_ARGS_((ClientData clientData));
+static void TimerHandlerCheckProc _ANSI_ARGS_((
+ ClientData clientData, int flags));
+static int TimerHandlerEventProc _ANSI_ARGS_((Tcl_Event *evPtr,
+ int flags));
+static void TimerHandlerExitProc _ANSI_ARGS_((ClientData data));
+static void TimerHandlerSetupProc _ANSI_ARGS_((
+ ClientData clientData, int flags));
+static char * VwaitVarProc _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, char *name1, char *name2,
+ int flags));
+
+/*
+ *--------------------------------------------------------------
+ *
+ * Tcl_CreateFileHandler --
+ *
+ * Arrange for a given procedure to be invoked whenever
+ * a given file becomes readable or writable.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * From now on, whenever the I/O channel given by file becomes
+ * ready in the way indicated by mask, proc will be invoked.
+ * See the manual entry for details on the calling sequence
+ * to proc. If file is already registered then the old mask
+ * and proc and clientData values will be replaced with
+ * new ones.
+ *
+ *--------------------------------------------------------------
+ */
+
+void
+Tcl_CreateFileHandler(file, mask, proc, clientData)
+ Tcl_File file; /* Handle of stream to watch. */
+ int mask; /* OR'ed combination of TCL_READABLE,
+ * TCL_WRITABLE, and TCL_EXCEPTION:
+ * indicates conditions under which
+ * proc should be called. */
+ Tcl_FileProc *proc; /* Procedure to call for each
+ * selected event. */
+ ClientData clientData; /* Arbitrary data to pass to proc. */
+{
+ register FileHandler *filePtr;
+
+ if (!fileEventSourceCreated) {
+ fileEventSourceCreated = 1;
+ Tcl_CreateEventSource(FileHandlerSetupProc, FileHandlerCheckProc,
+ (ClientData) NULL);
+ Tcl_CreateExitHandler(FileHandlerExitProc, (ClientData) NULL);
+ }
+
+ /*
+ * Make sure the file isn't already registered. Create a
+ * new record in the normal case where there's no existing
+ * record.
+ */
+
+ for (filePtr = firstFileHandlerPtr; filePtr != NULL;
+ filePtr = filePtr->nextPtr) {
+ if (filePtr->file == file) {
+ break;
+ }
+ }
+ if (filePtr == NULL) {
+ filePtr = (FileHandler *) ckalloc(sizeof(FileHandler));
+ filePtr->file = file;
+ filePtr->nextPtr = firstFileHandlerPtr;
+ firstFileHandlerPtr = filePtr;
+ }
+
+ /*
+ * The remainder of the initialization below is done regardless
+ * of whether or not this is a new record or a modification of
+ * an old one.
+ */
+
+ filePtr->mask = mask;
+ filePtr->readyMask = 0;
+ filePtr->proc = proc;
+ filePtr->clientData = clientData;
+}
+
+/*
+ *--------------------------------------------------------------
+ *
+ * Tcl_DeleteFileHandler --
+ *
+ * Cancel a previously-arranged callback arrangement for
+ * a file.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * If a callback was previously registered on file, remove it.
+ *
+ *--------------------------------------------------------------
+ */
+
+void
+Tcl_DeleteFileHandler(file)
+ Tcl_File file; /* Stream id for which to remove
+ * callback procedure. */
+{
+ FileHandler *filePtr, *prevPtr;
+
+ /*
+ * Find the entry for the given file (and return if there
+ * isn't one).
+ */
+
+ for (prevPtr = NULL, filePtr = firstFileHandlerPtr; ;
+ prevPtr = filePtr, filePtr = filePtr->nextPtr) {
+ if (filePtr == NULL) {
+ return;
+ }
+ if (filePtr->file == file) {
+ break;
+ }
+ }
+
+ /*
+ * Clean up information in the callback record.
+ */
+
+ if (prevPtr == NULL) {
+ firstFileHandlerPtr = filePtr->nextPtr;
+ } else {
+ prevPtr->nextPtr = filePtr->nextPtr;
+ }
+ ckfree((char *) filePtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FileHandlerExitProc --
+ *
+ * Cleanup procedure to delete the file event source during exit
+ * cleanup.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Destroys the file event source.
+ *
+ *----------------------------------------------------------------------
+ */
+
+ /* ARGSUSED */
+static void
+FileHandlerExitProc(clientData)
+ ClientData clientData; /* Not used. */
+{
+ Tcl_DeleteEventSource(FileHandlerSetupProc, FileHandlerCheckProc,
+ (ClientData) NULL);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FileHandlerSetupProc --
+ *
+ * This procedure is part of the "event source" for file handlers.
+ * It is invoked by Tcl_DoOneEvent before it calls select (or
+ * whatever it uses to wait).
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Tells the notifier which files should be waited for.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+FileHandlerSetupProc(clientData, flags)
+ ClientData clientData; /* Not used. */
+ int flags; /* Flags passed to Tk_DoOneEvent:
+ * if it doesn't include
+ * TCL_FILE_EVENTS then we do
+ * nothing. */
+{
+ FileHandler *filePtr;
+
+ if (!(flags & TCL_FILE_EVENTS)) {
+ return;
+ }
+ for (filePtr = firstFileHandlerPtr; filePtr != NULL;
+ filePtr = filePtr->nextPtr) {
+ if (filePtr->mask != 0) {
+ Tcl_WatchFile(filePtr->file, filePtr->mask);
+ }
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FileHandlerCheckProc --
+ *
+ * This procedure is the second part of the "event source" for
+ * file handlers. It is invoked by Tcl_DoOneEvent after it calls
+ * select (or whatever it uses to wait for events).
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Makes entries on the Tcl event queue for each file that is
+ * now ready.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+FileHandlerCheckProc(clientData, flags)
+ ClientData clientData; /* Not used. */
+ int flags; /* Flags passed to Tk_DoOneEvent:
+ * if it doesn't include
+ * TCL_FILE_EVENTS then we do
+ * nothing. */
+{
+ FileHandler *filePtr;
+ FileHandlerEvent *fileEvPtr;
+
+ if (!(flags & TCL_FILE_EVENTS)) {
+ return;
+ }
+ for (filePtr = firstFileHandlerPtr; filePtr != NULL;
+ filePtr = filePtr->nextPtr) {
+ if (filePtr->mask != 0) {
+ filePtr->readyMask = Tcl_FileReady(filePtr->file, filePtr->mask);
+ if (filePtr->readyMask != 0) {
+ fileEvPtr = (FileHandlerEvent *) ckalloc(
+ sizeof(FileHandlerEvent));
+ fileEvPtr->header.proc = FileHandlerEventProc;
+ fileEvPtr->file = filePtr->file;
+ Tcl_QueueEvent((Tcl_Event *) fileEvPtr, TCL_QUEUE_TAIL);
+ }
+ }
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FileHandlerEventProc --
+ *
+ * This procedure is called by Tcl_DoOneEvent when a file event
+ * reaches the front of the event queue. This procedure is responsible
+ * for actually handling the event by invoking the callback for the
+ * file handler.
+ *
+ * Results:
+ * Returns 1 if the event was handled, meaning it should be removed
+ * from the queue. Returns 0 if the event was not handled, meaning
+ * it should stay on the queue. The only time the event isn't
+ * handled is if the TCL_FILE_EVENTS flag bit isn't set.
+ *
+ * Side effects:
+ * Whatever the file handler's callback procedure does
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+FileHandlerEventProc(evPtr, flags)
+ Tcl_Event *evPtr; /* Event to service. */
+ int flags; /* Flags that indicate what events to
+ * handle, such as TCL_FILE_EVENTS. */
+{
+ FileHandler *filePtr;
+ FileHandlerEvent *fileEvPtr = (FileHandlerEvent *) evPtr;
+ int mask;
+
+ if (!(flags & TCL_FILE_EVENTS)) {
+ return 0;
+ }
+
+ /*
+ * Search through the file handlers to find the one whose handle matches
+ * the event. We do this rather than keeping a pointer to the file
+ * handler directly in the event, so that the handler can be deleted
+ * while the event is queued without leaving a dangling pointer.
+ */
+
+ for (filePtr = firstFileHandlerPtr; filePtr != NULL;
+ filePtr = filePtr->nextPtr) {
+ if (filePtr->file != fileEvPtr->file) {
+ continue;
+ }
+
+ /*
+ * The code is tricky for two reasons:
+ * 1. The file handler's desired events could have changed
+ * since the time when the event was queued, so AND the
+ * ready mask with the desired mask.
+ * 2. The file could have been closed and re-opened since
+ * the time when the event was queued. This is why the
+ * ready mask is stored in the file handler rather than
+ * the queued event: it will be zeroed when a new
+ * file handler is created for the newly opened file.
+ */
+
+ mask = filePtr->readyMask & filePtr->mask;
+ filePtr->readyMask = 0;
+ if (mask != 0) {
+ (*filePtr->proc)(filePtr->clientData, mask);
+ }
+ break;
+ }
+ return 1;
+}
+
+/*
+ *--------------------------------------------------------------
+ *
+ * Tcl_CreateTimerHandler --
+ *
+ * Arrange for a given procedure to be invoked at a particular
+ * time in the future.
+ *
+ * Results:
+ * The return value is a token for the timer event, which
+ * may be used to delete the event before it fires.
+ *
+ * Side effects:
+ * When milliseconds have elapsed, proc will be invoked
+ * exactly once.
+ *
+ *--------------------------------------------------------------
+ */
+
+Tcl_TimerToken
+Tcl_CreateTimerHandler(milliseconds, proc, clientData)
+ int milliseconds; /* How many milliseconds to wait
+ * before invoking proc. */
+ Tcl_TimerProc *proc; /* Procedure to invoke. */
+ ClientData clientData; /* Arbitrary data to pass to proc. */
+{
+ register TimerHandler *timerHandlerPtr, *tPtr2, *prevPtr;
+ static int id = 0;
+
+ if (!timerEventSourceCreated) {
+ timerEventSourceCreated = 1;
+ Tcl_CreateEventSource(TimerHandlerSetupProc, TimerHandlerCheckProc,
+ (ClientData) NULL);
+ Tcl_CreateExitHandler(TimerHandlerExitProc, (ClientData) NULL);
+ }
+
+ timerHandlerPtr = (TimerHandler *) ckalloc(sizeof(TimerHandler));
+
+ /*
+ * Compute when the event should fire.
+ */
+
+ TclGetTime(&timerHandlerPtr->time);
+ timerHandlerPtr->time.sec += milliseconds/1000;
+ timerHandlerPtr->time.usec += (milliseconds%1000)*1000;
+ if (timerHandlerPtr->time.usec >= 1000000) {
+ timerHandlerPtr->time.usec -= 1000000;
+ timerHandlerPtr->time.sec += 1;
+ }
+
+ /*
+ * Fill in other fields for the event.
+ */
+
+ timerHandlerPtr->proc = proc;
+ timerHandlerPtr->clientData = clientData;
+ id++;
+ timerHandlerPtr->token = (Tcl_TimerToken) id;
+
+ /*
+ * Add the event to the queue in the correct position
+ * (ordered by event firing time).
+ */
+
+ for (tPtr2 = firstTimerHandlerPtr, prevPtr = NULL; tPtr2 != NULL;
+ prevPtr = tPtr2, tPtr2 = tPtr2->nextPtr) {
+ if ((tPtr2->time.sec > timerHandlerPtr->time.sec)
+ || ((tPtr2->time.sec == timerHandlerPtr->time.sec)
+ && (tPtr2->time.usec > timerHandlerPtr->time.usec))) {
+ break;
+ }
+ }
+ timerHandlerPtr->nextPtr = tPtr2;
+ if (prevPtr == NULL) {
+ firstTimerHandlerPtr = timerHandlerPtr;
+ } else {
+ prevPtr->nextPtr = timerHandlerPtr;
+ }
+ return timerHandlerPtr->token;
+}
+
+/*
+ *--------------------------------------------------------------
+ *
+ * Tcl_DeleteTimerHandler --
+ *
+ * Delete a previously-registered timer handler.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Destroy the timer callback identified by TimerToken,
+ * so that its associated procedure will not be called.
+ * If the callback has already fired, or if the given
+ * token doesn't exist, then nothing happens.
+ *
+ *--------------------------------------------------------------
+ */
+
+void
+Tcl_DeleteTimerHandler(token)
+ Tcl_TimerToken token; /* Result previously returned by
+ * Tcl_DeleteTimerHandler. */
+{
+ register TimerHandler *timerHandlerPtr, *prevPtr;
+
+ for (timerHandlerPtr = firstTimerHandlerPtr, prevPtr = NULL;
+ timerHandlerPtr != NULL; prevPtr = timerHandlerPtr,
+ timerHandlerPtr = timerHandlerPtr->nextPtr) {
+ if (timerHandlerPtr->token != token) {
+ continue;
+ }
+ if (prevPtr == NULL) {
+ firstTimerHandlerPtr = timerHandlerPtr->nextPtr;
+ } else {
+ prevPtr->nextPtr = timerHandlerPtr->nextPtr;
+ }
+ ckfree((char *) timerHandlerPtr);
+ return;
+ }
+}
+
+/*
+ *--------------------------------------------------------------
+ *
+ * Tcl_CreateModalTimeout --
+ *
+ * Arrange for a given procedure to be invoked at a particular
+ * time in the future, independently of all other timer events.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * When milliseconds have elapsed, proc will be invoked
+ * exactly once.
+ *
+ *--------------------------------------------------------------
+ */
+
+void
+Tcl_CreateModalTimeout(milliseconds, proc, clientData)
+ int milliseconds; /* How many milliseconds to wait
+ * before invoking proc. */
+ Tcl_TimerProc *proc; /* Procedure to invoke. */
+ ClientData clientData; /* Arbitrary data to pass to proc. */
+{
+ TimerHandler *timerHandlerPtr;
+
+ if (!timerEventSourceCreated) {
+ timerEventSourceCreated = 1;
+ Tcl_CreateEventSource(TimerHandlerSetupProc, TimerHandlerCheckProc,
+ (ClientData) NULL);
+ Tcl_CreateExitHandler(TimerHandlerExitProc, (ClientData) NULL);
+ }
+
+ timerHandlerPtr = (TimerHandler *) ckalloc(sizeof(TimerHandler));
+
+ /*
+ * Compute when the timeout should fire and fill in the other fields
+ * of the handler.
+ */
+
+ TclGetTime(&timerHandlerPtr->time);
+ timerHandlerPtr->time.sec += milliseconds/1000;
+ timerHandlerPtr->time.usec += (milliseconds%1000)*1000;
+ if (timerHandlerPtr->time.usec >= 1000000) {
+ timerHandlerPtr->time.usec -= 1000000;
+ timerHandlerPtr->time.sec += 1;
+ }
+ timerHandlerPtr->proc = proc;
+ timerHandlerPtr->clientData = clientData;
+
+ /*
+ * Push the handler on the top of the modal stack.
+ */
+
+ timerHandlerPtr->nextPtr = firstModalHandlerPtr;
+ firstModalHandlerPtr = timerHandlerPtr;
+}
+
+/*
+ *--------------------------------------------------------------
+ *
+ * Tcl_DeleteModalTimeout --
+ *
+ * Remove the topmost modal timer handler from the stack of
+ * modal handlers.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Destroys the topmost modal timeout handler, which must
+ * match proc and clientData.
+ *
+ *--------------------------------------------------------------
+ */
+
+void
+Tcl_DeleteModalTimeout(proc, clientData)
+ Tcl_TimerProc *proc; /* Callback procedure for the timeout. */
+ ClientData clientData; /* Arbitrary data to pass to proc. */
+{
+ TimerHandler *timerHandlerPtr;
+
+ timerHandlerPtr = firstModalHandlerPtr;
+ firstModalHandlerPtr = timerHandlerPtr->nextPtr;
+ if ((timerHandlerPtr->proc != proc)
+ || (timerHandlerPtr->clientData != clientData)) {
+ panic("Tcl_DeleteModalTimeout found timeout stack corrupted");
+ }
+ ckfree((char *) timerHandlerPtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TimerHandlerSetupProc --
+ *
+ * This procedure is part of the "event source" for timers.
+ * It is invoked by Tcl_DoOneEvent before it calls select (or
+ * whatever it uses to wait).
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Tells the notifier how long to sleep if it decides to block.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+TimerHandlerSetupProc(clientData, flags)
+ ClientData clientData; /* Not used. */
+ int flags; /* Flags passed to Tk_DoOneEvent:
+ * if it doesn't include
+ * TCL_TIMER_EVENTS then we only
+ * consider modal timers. */
+{
+ TimerHandler *timerHandlerPtr, *tPtr2;
+ Tcl_Time blockTime;
+
+ /*
+ * Find the timer handler (regular or modal) that fires first.
+ */
+
+ timerHandlerPtr = firstTimerHandlerPtr;
+ if (!(flags & TCL_TIMER_EVENTS)) {
+ timerHandlerPtr = NULL;
+ }
+ if (timerHandlerPtr != NULL) {
+ tPtr2 = firstModalHandlerPtr;
+ if (tPtr2 != NULL) {
+ if ((timerHandlerPtr->time.sec > tPtr2->time.sec)
+ || ((timerHandlerPtr->time.sec == tPtr2->time.sec)
+ && (timerHandlerPtr->time.usec > tPtr2->time.usec))) {
+ timerHandlerPtr = tPtr2;
+ }
+ }
+ } else {
+ timerHandlerPtr = firstModalHandlerPtr;
+ }
+ if (timerHandlerPtr == NULL) {
+ return;
+ }
+
+ TclGetTime(&blockTime);
+ blockTime.sec = timerHandlerPtr->time.sec - blockTime.sec;
+ blockTime.usec = timerHandlerPtr->time.usec - blockTime.usec;
+ if (blockTime.usec < 0) {
+ blockTime.sec -= 1;
+ blockTime.usec += 1000000;
+ }
+ if (blockTime.sec < 0) {
+ blockTime.sec = 0;
+ blockTime.usec = 0;
+ }
+ Tcl_SetMaxBlockTime(&blockTime);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TimerHandlerCheckProc --
+ *
+ * This procedure is the second part of the "event source" for
+ * file handlers. It is invoked by Tcl_DoOneEvent after it calls
+ * select (or whatever it uses to wait for events).
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Makes entries on the Tcl event queue for each file that is
+ * now ready.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+TimerHandlerCheckProc(clientData, flags)
+ ClientData clientData; /* Not used. */
+ int flags; /* Flags passed to Tk_DoOneEvent:
+ * if it doesn't include
+ * TCL_TIMER_EVENTS then we only
+ * consider modal timeouts. */
+{
+ TimerHandler *timerHandlerPtr;
+ TimerEvent *timerEvPtr;
+ int triggered, gotTime;
+ Tcl_Time curTime;
+
+ triggered = 0;
+ gotTime = 0;
+ timerHandlerPtr = firstTimerHandlerPtr;
+ if ((flags & TCL_TIMER_EVENTS) && (timerHandlerPtr != NULL)) {
+ TclGetTime(&curTime);
+ gotTime = 1;
+ if ((timerHandlerPtr->time.sec < curTime.sec)
+ || ((timerHandlerPtr->time.sec == curTime.sec)
+ && (timerHandlerPtr->time.usec <= curTime.usec))) {
+ triggered = 1;
+ }
+ }
+ timerHandlerPtr = firstModalHandlerPtr;
+ if (timerHandlerPtr != NULL) {
+ if (!gotTime) {
+ TclGetTime(&curTime);
+ }
+ if ((timerHandlerPtr->time.sec < curTime.sec)
+ || ((timerHandlerPtr->time.sec == curTime.sec)
+ && (timerHandlerPtr->time.usec <= curTime.usec))) {
+ triggered = 1;
+ }
+ }
+ if (triggered) {
+ timerEvPtr = (TimerEvent *) ckalloc(sizeof(TimerEvent));
+ timerEvPtr->header.proc = TimerHandlerEventProc;
+ timerEvPtr->time.sec = curTime.sec;
+ timerEvPtr->time.usec = curTime.usec;
+ Tcl_QueueEvent((Tcl_Event *) timerEvPtr, TCL_QUEUE_TAIL);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TimerHandlerExitProc --
+ *
+ * Callback invoked during exit cleanup to destroy the timer event
+ * source.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Destroys the timer event source.
+ *
+ *----------------------------------------------------------------------
+ */
+
+ /* ARGSUSED */
+static void
+TimerHandlerExitProc(clientData)
+ ClientData clientData; /* Not used. */
+{
+ Tcl_DeleteEventSource(TimerHandlerSetupProc, TimerHandlerCheckProc,
+ (ClientData) NULL);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TimerHandlerEventProc --
+ *
+ * This procedure is called by Tcl_DoOneEvent when a timer event
+ * reaches the front of the event queue. This procedure handles
+ * the event by invoking the callbacks for all timers that are
+ * ready.
+ *
+ * Results:
+ * Returns 1 if the event was handled, meaning it should be removed
+ * from the queue. Returns 0 if the event was not handled, meaning
+ * it should stay on the queue. The only time the event isn't
+ * handled is if the TCL_TIMER_EVENTS flag bit isn't set.
+ *
+ * Side effects:
+ * Whatever the timer handler callback procedures do.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TimerHandlerEventProc(evPtr, flags)
+ Tcl_Event *evPtr; /* Event to service. */
+ int flags; /* Flags that indicate what events to
+ * handle, such as TCL_FILE_EVENTS. */
+{
+ TimerHandler *timerHandlerPtr;
+ TimerEvent *timerEvPtr = (TimerEvent *) evPtr;
+
+ /*
+ * Invoke the current modal timeout first, if there is one and
+ * it has triggered.
+ */
+
+ timerHandlerPtr = firstModalHandlerPtr;
+ if (firstModalHandlerPtr != NULL) {
+ if ((timerHandlerPtr->time.sec < timerEvPtr->time.sec)
+ || ((timerHandlerPtr->time.sec == timerEvPtr->time.sec)
+ && (timerHandlerPtr->time.usec <= timerEvPtr->time.usec))) {
+ (*timerHandlerPtr->proc)(timerHandlerPtr->clientData);
+ }
+ }
+
+ /*
+ * Invoke any normal timers that have fired.
+ */
+
+ if (!(flags & TCL_TIMER_EVENTS)) {
+ return 1;
+ }
+
+ while (1) {
+ timerHandlerPtr = firstTimerHandlerPtr;
+ if (timerHandlerPtr == NULL) {
+ break;
+ }
+ if ((timerHandlerPtr->time.sec > timerEvPtr->time.sec)
+ || ((timerHandlerPtr->time.sec == timerEvPtr->time.sec)
+ && (timerHandlerPtr->time.usec >= timerEvPtr->time.usec))) {
+ break;
+ }
+
+ /*
+ * Remove the handler from the queue before invoking it,
+ * to avoid potential reentrancy problems.
+ */
+
+ firstTimerHandlerPtr = timerHandlerPtr->nextPtr;
+ (*timerHandlerPtr->proc)(timerHandlerPtr->clientData);
+ ckfree((char *) timerHandlerPtr);
+ }
+ return 1;
+}
+
+/*
+ *--------------------------------------------------------------
+ *
+ * Tcl_DoWhenIdle --
+ *
+ * Arrange for proc to be invoked the next time the system is
+ * idle (i.e., just before the next time that Tcl_DoOneEvent
+ * would have to wait for something to happen).
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Proc will eventually be called, with clientData as argument.
+ * See the manual entry for details.
+ *
+ *--------------------------------------------------------------
+ */
+
+void
+Tcl_DoWhenIdle(proc, clientData)
+ Tcl_IdleProc *proc; /* Procedure to invoke. */
+ ClientData clientData; /* Arbitrary value to pass to proc. */
+{
+ register IdleHandler *idlePtr;
+
+ idlePtr = (IdleHandler *) ckalloc(sizeof(IdleHandler));
+ idlePtr->proc = proc;
+ idlePtr->clientData = clientData;
+ idlePtr->generation = idleGeneration;
+ idlePtr->nextPtr = NULL;
+ if (lastIdlePtr == NULL) {
+ idleList = idlePtr;
+ } else {
+ lastIdlePtr->nextPtr = idlePtr;
+ }
+ lastIdlePtr = idlePtr;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_CancelIdleCall --
+ *
+ * If there are any when-idle calls requested to a given procedure
+ * with given clientData, cancel all of them.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * If the proc/clientData combination were on the when-idle list,
+ * they are removed so that they will never be called.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_CancelIdleCall(proc, clientData)
+ Tcl_IdleProc *proc; /* Procedure that was previously registered. */
+ ClientData clientData; /* Arbitrary value to pass to proc. */
+{
+ register IdleHandler *idlePtr, *prevPtr;
+ IdleHandler *nextPtr;
+
+ for (prevPtr = NULL, idlePtr = idleList; idlePtr != NULL;
+ prevPtr = idlePtr, idlePtr = idlePtr->nextPtr) {
+ while ((idlePtr->proc == proc)
+ && (idlePtr->clientData == clientData)) {
+ nextPtr = idlePtr->nextPtr;
+ ckfree((char *) idlePtr);
+ idlePtr = nextPtr;
+ if (prevPtr == NULL) {
+ idleList = idlePtr;
+ } else {
+ prevPtr->nextPtr = idlePtr;
+ }
+ if (idlePtr == NULL) {
+ lastIdlePtr = prevPtr;
+ return;
+ }
+ }
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclIdlePending --
+ *
+ * This function is called by the notifier subsystem to determine
+ * whether there are any idle handlers currently scheduled.
+ *
+ * Results:
+ * Returns 0 if the idle list is empty, otherwise it returns 1.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclIdlePending()
+{
+ return (idleList == NULL) ? 0 : 1;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclServiceIdle --
+ *
+ * This procedure is invoked by the notifier when it becomes idle.
+ *
+ * Results:
+ * The return value is 1 if the procedure actually found an idle
+ * handler to invoke. If no handler was found then 0 is returned.
+ *
+ * Side effects:
+ * Invokes all pending idle handlers.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclServiceIdle()
+{
+ IdleHandler *idlePtr;
+ int oldGeneration;
+ int foundIdle;
+
+ if (idleList == NULL) {
+ return 0;
+ }
+
+ foundIdle = 0;
+ oldGeneration = idleGeneration;
+ idleGeneration++;
+
+ /*
+ * The code below is trickier than it may look, for the following
+ * reasons:
+ *
+ * 1. New handlers can get added to the list while the current
+ * one is being processed. If new ones get added, we don't
+ * want to process them during this pass through the list (want
+ * to check for other work to do first). This is implemented
+ * using the generation number in the handler: new handlers
+ * will have a different generation than any of the ones currently
+ * on the list.
+ * 2. The handler can call Tcl_DoOneEvent, so we have to remove
+ * the handler from the list before calling it. Otherwise an
+ * infinite loop could result.
+ * 3. Tcl_CancelIdleCall can be called to remove an element from
+ * the list while a handler is executing, so the list could
+ * change structure during the call.
+ */
+
+ for (idlePtr = idleList;
+ ((idlePtr != NULL)
+ && ((oldGeneration - idlePtr->generation) >= 0));
+ idlePtr = idleList) {
+ idleList = idlePtr->nextPtr;
+ if (idleList == NULL) {
+ lastIdlePtr = NULL;
+ }
+ foundIdle = 1;
+ (*idlePtr->proc)(idlePtr->clientData);
+ ckfree((char *) idlePtr);
+ }
+
+ return foundIdle;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_BackgroundError --
+ *
+ * This procedure is invoked to handle errors that occur in Tcl
+ * commands that are invoked in "background" (e.g. from event or
+ * timer bindings).
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The command "bgerror" is invoked later as an idle handler to
+ * process the error, passing it the error message. If that fails,
+ * then an error message is output on stderr.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_BackgroundError(interp)
+ Tcl_Interp *interp; /* Interpreter in which an error has
+ * occurred. */
+{
+ BgError *errPtr;
+ char *varValue;
+ ErrAssocData *assocPtr;
+
+ /*
+ * The Tcl_AddErrorInfo call below (with an empty string) ensures that
+ * errorInfo gets properly set. It's needed in cases where the error
+ * came from a utility procedure like Tcl_GetVar instead of Tcl_Eval;
+ * in these cases errorInfo still won't have been set when this
+ * procedure is called.
+ */
+
+ Tcl_AddErrorInfo(interp, "");
+ errPtr = (BgError *) ckalloc(sizeof(BgError));
+ errPtr->interp = interp;
+ errPtr->errorMsg = (char *) ckalloc((unsigned) (strlen(interp->result)
+ + 1));
+ strcpy(errPtr->errorMsg, interp->result);
+ varValue = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);
+ if (varValue == NULL) {
+ varValue = errPtr->errorMsg;
+ }
+ errPtr->errorInfo = (char *) ckalloc((unsigned) (strlen(varValue) + 1));
+ strcpy(errPtr->errorInfo, varValue);
+ varValue = Tcl_GetVar(interp, "errorCode", TCL_GLOBAL_ONLY);
+ if (varValue == NULL) {
+ varValue = "";
+ }
+ errPtr->errorCode = (char *) ckalloc((unsigned) (strlen(varValue) + 1));
+ strcpy(errPtr->errorCode, varValue);
+ errPtr->nextPtr = NULL;
+
+ assocPtr = (ErrAssocData *) Tcl_GetAssocData(interp, "tclBgError",
+ (Tcl_InterpDeleteProc **) NULL);
+ if (assocPtr == NULL) {
+
+ /*
+ * This is the first time a background error has occurred in
+ * this interpreter. Create associated data to keep track of
+ * pending error reports.
+ */
+
+ assocPtr = (ErrAssocData *) ckalloc(sizeof(ErrAssocData));
+ assocPtr->firstBgPtr = NULL;
+ assocPtr->lastBgPtr = NULL;
+ Tcl_SetAssocData(interp, "tclBgError", BgErrorDeleteProc,
+ (ClientData) assocPtr);
+ }
+ if (assocPtr->firstBgPtr == NULL) {
+ assocPtr->firstBgPtr = errPtr;
+ Tcl_DoWhenIdle(HandleBgErrors, (ClientData) assocPtr);
+ } else {
+ assocPtr->lastBgPtr->nextPtr = errPtr;
+ }
+ assocPtr->lastBgPtr = errPtr;
+ Tcl_ResetResult(interp);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * HandleBgErrors --
+ *
+ * This procedure is invoked as an idle handler to process all of
+ * the accumulated background errors.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Depends on what actions "bgerror" takes for the errors.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+HandleBgErrors(clientData)
+ ClientData clientData; /* Pointer to ErrAssocData structure. */
+{
+ Tcl_Interp *interp;
+ char *command;
+ char *argv[2];
+ int code;
+ BgError *errPtr;
+ ErrAssocData *assocPtr = (ErrAssocData *) clientData;
+ Tcl_Channel errChannel;
+
+ while (assocPtr->firstBgPtr != NULL) {
+ interp = assocPtr->firstBgPtr->interp;
+ if (interp == NULL) {
+ goto doneWithReport;
+ }
+
+ /*
+ * Restore important state variables to what they were at
+ * the time the error occurred.
+ */
+
+ Tcl_SetVar(interp, "errorInfo", assocPtr->firstBgPtr->errorInfo,
+ TCL_GLOBAL_ONLY);
+ Tcl_SetVar(interp, "errorCode", assocPtr->firstBgPtr->errorCode,
+ TCL_GLOBAL_ONLY);
+
+ /*
+ * Create and invoke the bgerror command.
+ */
+
+ argv[0] = "bgerror";
+ argv[1] = assocPtr->firstBgPtr->errorMsg;
+ command = Tcl_Merge(2, argv);
+ Tcl_AllowExceptions(interp);
+ Tcl_Preserve((ClientData) interp);
+ code = Tcl_GlobalEval(interp, command);
+ ckfree(command);
+ if (code == TCL_ERROR) {
+
+ /*
+ * We have to get the error output channel at the latest possible
+ * time, because the eval (above) might have changed the channel.
+ */
+
+ errChannel = Tcl_GetStdChannel(TCL_STDERR);
+ if (errChannel != (Tcl_Channel) NULL) {
+ if (strcmp(interp->result,
+ "\"bgerror\" is an invalid command name or ambiguous abbreviation")
+ == 0) {
+ Tcl_Write(errChannel, assocPtr->firstBgPtr->errorInfo, -1);
+ Tcl_Write(errChannel, "\n", -1);
+ } else {
+ Tcl_Write(errChannel,
+ "bgerror failed to handle background error.\n",
+ -1);
+ Tcl_Write(errChannel, " Original error: ", -1);
+ Tcl_Write(errChannel, assocPtr->firstBgPtr->errorMsg,
+ -1);
+ Tcl_Write(errChannel, "\n", -1);
+ Tcl_Write(errChannel, " Error in bgerror: ", -1);
+ Tcl_Write(errChannel, interp->result, -1);
+ Tcl_Write(errChannel, "\n", -1);
+ }
+ Tcl_Flush(errChannel);
+ }
+ } else if (code == TCL_BREAK) {
+
+ /*
+ * Break means cancel any remaining error reports for this
+ * interpreter.
+ */
+
+ for (errPtr = assocPtr->firstBgPtr; errPtr != NULL;
+ errPtr = errPtr->nextPtr) {
+ if (errPtr->interp == interp) {
+ errPtr->interp = NULL;
+ }
+ }
+ }
+
+ Tcl_Release((ClientData) interp);
+
+ /*
+ * Discard the command and the information about the error report.
+ */
+
+ doneWithReport:
+ ckfree(assocPtr->firstBgPtr->errorMsg);
+ ckfree(assocPtr->firstBgPtr->errorInfo);
+ ckfree(assocPtr->firstBgPtr->errorCode);
+ errPtr = assocPtr->firstBgPtr->nextPtr;
+ ckfree((char *) assocPtr->firstBgPtr);
+ assocPtr->firstBgPtr = errPtr;
+ }
+ assocPtr->lastBgPtr = NULL;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * BgErrorDeleteProc --
+ *
+ * This procedure is associated with the "tclBgError" assoc data
+ * for an interpreter; it is invoked when the interpreter is
+ * deleted in order to free the information assoicated with any
+ * pending error reports.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Background error information is freed: if there were any
+ * pending error reports, they are cancelled.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+BgErrorDeleteProc(clientData, interp)
+ ClientData clientData; /* Pointer to ErrAssocData structure. */
+ Tcl_Interp *interp; /* Interpreter being deleted. */
+{
+ ErrAssocData *assocPtr = (ErrAssocData *) clientData;
+ BgError *errPtr;
+
+ while (assocPtr->firstBgPtr != NULL) {
+ errPtr = assocPtr->firstBgPtr;
+ assocPtr->firstBgPtr = errPtr->nextPtr;
+ ckfree(errPtr->errorMsg);
+ ckfree(errPtr->errorInfo);
+ ckfree(errPtr->errorCode);
+ ckfree((char *) errPtr);
+ }
+ ckfree((char *) assocPtr);
+ Tcl_CancelIdleCall(HandleBgErrors, (ClientData) assocPtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_CreateExitHandler --
+ *
+ * Arrange for a given procedure to be invoked just before the
+ * application exits.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Proc will be invoked with clientData as argument when the
+ * application exits.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_CreateExitHandler(proc, clientData)
+ Tcl_ExitProc *proc; /* Procedure to invoke. */
+ ClientData clientData; /* Arbitrary value to pass to proc. */
+{
+ ExitHandler *exitPtr;
+
+ exitPtr = (ExitHandler *) ckalloc(sizeof(ExitHandler));
+ exitPtr->proc = proc;
+ exitPtr->clientData = clientData;
+ exitPtr->nextPtr = firstExitPtr;
+ firstExitPtr = exitPtr;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_DeleteExitHandler --
+ *
+ * This procedure cancels an existing exit handler matching proc
+ * and clientData, if such a handler exits.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * If there is an exit handler corresponding to proc and clientData
+ * then it is cancelled; if no such handler exists then nothing
+ * happens.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_DeleteExitHandler(proc, clientData)
+ Tcl_ExitProc *proc; /* Procedure that was previously registered. */
+ ClientData clientData; /* Arbitrary value to pass to proc. */
+{
+ ExitHandler *exitPtr, *prevPtr;
+
+ for (prevPtr = NULL, exitPtr = firstExitPtr; exitPtr != NULL;
+ prevPtr = exitPtr, exitPtr = exitPtr->nextPtr) {
+ if ((exitPtr->proc == proc)
+ && (exitPtr->clientData == clientData)) {
+ if (prevPtr == NULL) {
+ firstExitPtr = exitPtr->nextPtr;
+ } else {
+ prevPtr->nextPtr = exitPtr->nextPtr;
+ }
+ ckfree((char *) exitPtr);
+ return;
+ }
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_Exit --
+ *
+ * This procedure is called to terminate the application.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * All existing exit handlers are invoked, then the application
+ * ends.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_Exit(status)
+ int status; /* Exit status for application; typically
+ * 0 for normal return, 1 for error return. */
+{
+ ExitHandler *exitPtr;
+
+ for (exitPtr = firstExitPtr; exitPtr != NULL; exitPtr = firstExitPtr) {
+ /*
+ * Be careful to remove the handler from the list before invoking
+ * its callback. This protects us against double-freeing if the
+ * callback should call Tcl_DeleteExitHandler on itself.
+ */
+
+ firstExitPtr = exitPtr->nextPtr;
+ (*exitPtr->proc)(exitPtr->clientData);
+ ckfree((char *) exitPtr);
+ }
+#ifdef TCL_MEM_DEBUG
+ if (tclMemDumpFileName != NULL) {
+ Tcl_DumpActiveMemory(tclMemDumpFileName);
+ }
+#endif
+
+ TclPlatformExit(status);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_AfterCmd --
+ *
+ * This procedure is invoked to process the "after" 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_AfterCmd(clientData, interp, argc, argv)
+ ClientData clientData; /* Points to the "tclAfter" assocData for
+ * this interpreter, or NULL if the assocData
+ * hasn't been created yet.*/
+ Tcl_Interp *interp; /* Current interpreter. */
+ int argc; /* Number of arguments. */
+ char **argv; /* Argument strings. */
+{
+ /*
+ * The variable below is used to generate unique identifiers for
+ * after commands. This id can wrap around, which can potentially
+ * cause problems. However, there are not likely to be problems
+ * in practice, because after commands can only be requested to
+ * about a month in the future, and wrap-around is unlikely to
+ * occur in less than about 1-10 years. Thus it's unlikely that
+ * any old ids will still be around when wrap-around occurs.
+ */
+
+ static int nextId = 1;
+ int ms;
+ AfterInfo *afterPtr;
+ AfterAssocData *assocPtr = (AfterAssocData *) clientData;
+ Tcl_CmdInfo cmdInfo;
+ size_t length;
+
+ if (argc < 2) {
+ Tcl_AppendResult(interp, "wrong # args: should be \"",
+ argv[0], " option ?arg arg ...?\"", (char *) NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Create the "after" information associated for this interpreter,
+ * if it doesn't already exist. Associate it with the command too,
+ * so that it will be passed in as the ClientData argument in the
+ * future.
+ */
+
+ if (assocPtr == NULL) {
+ assocPtr = (AfterAssocData *) ckalloc(sizeof(AfterAssocData));
+ assocPtr->interp = interp;
+ assocPtr->firstAfterPtr = NULL;
+ Tcl_SetAssocData(interp, "tclAfter", AfterCleanupProc,
+ (ClientData) assocPtr);
+ cmdInfo.proc = Tcl_AfterCmd;
+ cmdInfo.clientData = (ClientData) assocPtr;
+ cmdInfo.deleteProc = NULL;
+ cmdInfo.deleteData = (ClientData) assocPtr;
+ Tcl_SetCommandInfo(interp, argv[0], &cmdInfo);
+ }
+
+ /*
+ * Parse the command.
+ */
+
+ length = strlen(argv[1]);
+ if (isdigit(UCHAR(argv[1][0]))) {
+ if (Tcl_GetInt(interp, argv[1], &ms) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (ms < 0) {
+ ms = 0;
+ }
+ if (argc == 2) {
+ Tcl_Sleep(ms);
+ return TCL_OK;
+ }
+ afterPtr = (AfterInfo *) ckalloc((unsigned) (sizeof(AfterInfo)));
+ afterPtr->assocPtr = assocPtr;
+ if (argc == 3) {
+ afterPtr->command = (char *) ckalloc((unsigned)
+ (strlen(argv[2]) + 1));
+ strcpy(afterPtr->command, argv[2]);
+ } else {
+ afterPtr->command = Tcl_Concat(argc-2, argv+2);
+ }
+ afterPtr->id = nextId;
+ nextId += 1;
+ afterPtr->token = Tcl_CreateTimerHandler(ms, AfterProc,
+ (ClientData) afterPtr);
+ afterPtr->nextPtr = assocPtr->firstAfterPtr;
+ assocPtr->firstAfterPtr = afterPtr;
+ sprintf(interp->result, "after#%d", afterPtr->id);
+ } else if (strncmp(argv[1], "cancel", length) == 0) {
+ char *arg;
+
+ if (argc < 3) {
+ Tcl_AppendResult(interp, "wrong # args: should be \"",
+ argv[0], " cancel id|command\"", (char *) NULL);
+ return TCL_ERROR;
+ }
+ if (argc == 3) {
+ arg = argv[2];
+ } else {
+ arg = Tcl_Concat(argc-2, argv+2);
+ }
+ for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL;
+ afterPtr = afterPtr->nextPtr) {
+ if (strcmp(afterPtr->command, arg) == 0) {
+ break;
+ }
+ }
+ if (afterPtr == NULL) {
+ afterPtr = GetAfterEvent(assocPtr, arg);
+ }
+ if (arg != argv[2]) {
+ ckfree(arg);
+ }
+ if (afterPtr != NULL) {
+ if (afterPtr->token != NULL) {
+ Tcl_DeleteTimerHandler(afterPtr->token);
+ } else {
+ Tcl_CancelIdleCall(AfterProc, (ClientData) afterPtr);
+ }
+ FreeAfterPtr(afterPtr);
+ }
+ } else if ((strncmp(argv[1], "idle", length) == 0)
+ && (length >= 2)) {
+ if (argc < 3) {
+ Tcl_AppendResult(interp, "wrong # args: should be \"",
+ argv[0], " idle script script ...\"", (char *) NULL);
+ return TCL_ERROR;
+ }
+ afterPtr = (AfterInfo *) ckalloc((unsigned) (sizeof(AfterInfo)));
+ afterPtr->assocPtr = assocPtr;
+ if (argc == 3) {
+ afterPtr->command = (char *) ckalloc((unsigned)
+ (strlen(argv[2]) + 1));
+ strcpy(afterPtr->command, argv[2]);
+ } else {
+ afterPtr->command = Tcl_Concat(argc-2, argv+2);
+ }
+ afterPtr->id = nextId;
+ nextId += 1;
+ afterPtr->token = NULL;
+ afterPtr->nextPtr = assocPtr->firstAfterPtr;
+ assocPtr->firstAfterPtr = afterPtr;
+ Tcl_DoWhenIdle(AfterProc, (ClientData) afterPtr);
+ sprintf(interp->result, "after#%d", afterPtr->id);
+ } else if ((strncmp(argv[1], "info", length) == 0)
+ && (length >= 2)) {
+ if (argc == 2) {
+ char buffer[30];
+
+ for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL;
+ afterPtr = afterPtr->nextPtr) {
+ if (assocPtr->interp == interp) {
+ sprintf(buffer, "after#%d", afterPtr->id);
+ Tcl_AppendElement(interp, buffer);
+ }
+ }
+ return TCL_OK;
+ }
+ if (argc != 3) {
+ Tcl_AppendResult(interp, "wrong # args: should be \"",
+ argv[0], " info ?id?\"", (char *) NULL);
+ return TCL_ERROR;
+ }
+ afterPtr = GetAfterEvent(assocPtr, argv[2]);
+ if (afterPtr == NULL) {
+ Tcl_AppendResult(interp, "event \"", argv[2],
+ "\" doesn't exist", (char *) NULL);
+ return TCL_ERROR;
+ }
+ Tcl_AppendElement(interp, afterPtr->command);
+ Tcl_AppendElement(interp,
+ (afterPtr->token == NULL) ? "idle" : "timer");
+ } else {
+ Tcl_AppendResult(interp, "bad argument \"", argv[1],
+ "\": must be cancel, idle, info, or a number",
+ (char *) NULL);
+ return TCL_ERROR;
+ }
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * GetAfterEvent --
+ *
+ * This procedure parses an "after" id such as "after#4" and
+ * returns a pointer to the AfterInfo structure.
+ *
+ * Results:
+ * The return value is either a pointer to an AfterInfo structure,
+ * if one is found that corresponds to "string" and is for interp,
+ * or NULL if no corresponding after event can be found.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static AfterInfo *
+GetAfterEvent(assocPtr, string)
+ AfterAssocData *assocPtr; /* Points to "after"-related information for
+ * this interpreter. */
+ char *string; /* Textual identifier for after event, such
+ * as "after#6". */
+{
+ AfterInfo *afterPtr;
+ int id;
+ char *end;
+
+ if (strncmp(string, "after#", 6) != 0) {
+ return NULL;
+ }
+ string += 6;
+ id = strtoul(string, &end, 10);
+ if ((end == string) || (*end != 0)) {
+ return NULL;
+ }
+ for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL;
+ afterPtr = afterPtr->nextPtr) {
+ if (afterPtr->id == id) {
+ return afterPtr;
+ }
+ }
+ return NULL;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * AfterProc --
+ *
+ * Timer callback to execute commands registered with the
+ * "after" command.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Executes whatever command was specified. If the command
+ * returns an error, then the command "bgerror" is invoked
+ * to process the error; if bgerror fails then information
+ * about the error is output on stderr.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+AfterProc(clientData)
+ ClientData clientData; /* Describes command to execute. */
+{
+ AfterInfo *afterPtr = (AfterInfo *) clientData;
+ AfterAssocData *assocPtr = afterPtr->assocPtr;
+ AfterInfo *prevPtr;
+ int result;
+ Tcl_Interp *interp;
+
+ /*
+ * First remove the callback from our list of callbacks; otherwise
+ * someone could delete the callback while it's being executed, which
+ * could cause a core dump.
+ */
+
+ if (assocPtr->firstAfterPtr == afterPtr) {
+ assocPtr->firstAfterPtr = afterPtr->nextPtr;
+ } else {
+ for (prevPtr = assocPtr->firstAfterPtr; prevPtr->nextPtr != afterPtr;
+ prevPtr = prevPtr->nextPtr) {
+ /* Empty loop body. */
+ }
+ prevPtr->nextPtr = afterPtr->nextPtr;
+ }
+
+ /*
+ * Execute the callback.
+ */
+
+ interp = assocPtr->interp;
+ Tcl_Preserve((ClientData) interp);
+ result = Tcl_GlobalEval(interp, afterPtr->command);
+ if (result != TCL_OK) {
+ Tcl_AddErrorInfo(interp, "\n (\"after\" script)");
+ Tcl_BackgroundError(interp);
+ }
+ Tcl_Release((ClientData) interp);
+
+ /*
+ * Free the memory for the callback.
+ */
+
+ ckfree(afterPtr->command);
+ ckfree((char *) afterPtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FreeAfterPtr --
+ *
+ * This procedure removes an "after" command from the list of
+ * those that are pending and frees its resources. This procedure
+ * does *not* cancel the timer handler; if that's needed, the
+ * caller must do it.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The memory associated with afterPtr is released.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+FreeAfterPtr(afterPtr)
+ AfterInfo *afterPtr; /* Command to be deleted. */
+{
+ AfterInfo *prevPtr;
+ AfterAssocData *assocPtr = afterPtr->assocPtr;
+
+ if (assocPtr->firstAfterPtr == afterPtr) {
+ assocPtr->firstAfterPtr = afterPtr->nextPtr;
+ } else {
+ for (prevPtr = assocPtr->firstAfterPtr; prevPtr->nextPtr != afterPtr;
+ prevPtr = prevPtr->nextPtr) {
+ /* Empty loop body. */
+ }
+ prevPtr->nextPtr = afterPtr->nextPtr;
+ }
+ ckfree(afterPtr->command);
+ ckfree((char *) afterPtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * AfterCleanupProc --
+ *
+ * This procedure is invoked whenever an interpreter is deleted
+ * to cleanup the AssocData for "tclAfter".
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * After commands are removed.
+ *
+ *----------------------------------------------------------------------
+ */
+
+ /* ARGSUSED */
+static void
+AfterCleanupProc(clientData, interp)
+ ClientData clientData; /* Points to AfterAssocData for the
+ * interpreter. */
+ Tcl_Interp *interp; /* Interpreter that is being deleted. */
+{
+ AfterAssocData *assocPtr = (AfterAssocData *) clientData;
+ AfterInfo *afterPtr;
+
+ while (assocPtr->firstAfterPtr != NULL) {
+ afterPtr = assocPtr->firstAfterPtr;
+ assocPtr->firstAfterPtr = afterPtr->nextPtr;
+ if (afterPtr->token != NULL) {
+ Tcl_DeleteTimerHandler(afterPtr->token);
+ } else {
+ Tcl_CancelIdleCall(AfterProc, (ClientData) afterPtr);
+ }
+ ckfree(afterPtr->command);
+ ckfree((char *) afterPtr);
+ }
+ ckfree((char *) assocPtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_VwaitCmd --
+ *
+ * This procedure is invoked to process the "vwait" 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_VwaitCmd(clientData, interp, argc, argv)
+ ClientData clientData; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int argc; /* Number of arguments. */
+ char **argv; /* Argument strings. */
+{
+ int done, foundEvent;
+
+ if (argc != 2) {
+ Tcl_AppendResult(interp, "wrong # args: should be \"",
+ argv[0], " name\"", (char *) NULL);
+ return TCL_ERROR;
+ }
+ Tcl_TraceVar(interp, argv[1],
+ TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
+ VwaitVarProc, (ClientData) &done);
+ done = 0;
+ foundEvent = 1;
+ while (!done && foundEvent) {
+ foundEvent = Tcl_DoOneEvent(0);
+ }
+ Tcl_UntraceVar(interp, argv[1],
+ TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
+ VwaitVarProc, (ClientData) &done);
+
+ /*
+ * Clear out the interpreter's result, since it may have been set
+ * by event handlers.
+ */
+
+ Tcl_ResetResult(interp);
+ if (!foundEvent) {
+ Tcl_AppendResult(interp, "can't wait for variable \"", argv[1],
+ "\": would wait forever", (char *) NULL);
+ return TCL_ERROR;
+ }
+ return TCL_OK;
+}
+
+ /* ARGSUSED */
+static char *
+VwaitVarProc(clientData, interp, name1, name2, flags)
+ ClientData clientData; /* Pointer to integer to set to 1. */
+ Tcl_Interp *interp; /* Interpreter containing variable. */
+ char *name1; /* Name of variable. */
+ char *name2; /* Second part of variable name. */
+ int flags; /* Information about what happened. */
+{
+ int *donePtr = (int *) clientData;
+
+ *donePtr = 1;
+ return (char *) NULL;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_UpdateCmd --
+ *
+ * This procedure is invoked to process the "update" 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_UpdateCmd(clientData, interp, argc, argv)
+ ClientData clientData; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int argc; /* Number of arguments. */
+ char **argv; /* Argument strings. */
+{
+ int flags = 0; /* Initialization needed only to stop
+ * compiler warnings. */
+
+ if (argc == 1) {
+ flags = TCL_ALL_EVENTS|TCL_DONT_WAIT;
+ } else if (argc == 2) {
+ if (strncmp(argv[1], "idletasks", strlen(argv[1])) != 0) {
+ Tcl_AppendResult(interp, "bad option \"", argv[1],
+ "\": must be idletasks", (char *) NULL);
+ return TCL_ERROR;
+ }
+ flags = TCL_IDLE_EVENTS|TCL_DONT_WAIT;
+ } else {
+ Tcl_AppendResult(interp, "wrong # args: should be \"",
+ argv[0], " ?idletasks?\"", (char *) NULL);
+ return TCL_ERROR;
+ }
+
+ while (Tcl_DoOneEvent(flags) != 0) {
+ /* Empty loop body */
+ }
+
+ /*
+ * Must clear the interpreter's result because event handlers could
+ * have executed commands.
+ */
+
+ Tcl_ResetResult(interp);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclWaitForFile --
+ *
+ * This procedure waits synchronously for a file to become readable
+ * or writable, with an optional timeout.
+ *
+ * Results:
+ * The return value is an OR'ed combination of TCL_READABLE,
+ * TCL_WRITABLE, and TCL_EXCEPTION, indicating the conditions
+ * that are present on file at the time of the return. This
+ * procedure will not return until either "timeout" milliseconds
+ * have elapsed or at least one of the conditions given by mask
+ * has occurred for file (a return value of 0 means that a timeout
+ * occurred). No normal events will be serviced during the
+ * execution of this procedure.
+ *
+ * Side effects:
+ * Time passes.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclWaitForFile(file, mask, timeout)
+ Tcl_File file; /* Handle for file on which to wait. */
+ int mask; /* What to wait for: OR'ed combination of
+ * TCL_READABLE, TCL_WRITABLE, and
+ * TCL_EXCEPTION. */
+ int timeout; /* Maximum amount of time to wait for one
+ * of the conditions in mask to occur, in
+ * milliseconds. A value of 0 means don't
+ * wait at all, and a value of -1 means
+ * wait forever. */
+{
+ Tcl_Time abortTime, now, blockTime;
+ int present;
+
+ /*
+ * If there is a non-zero finite timeout, compute the time when
+ * we give up.
+ */
+
+ if (timeout > 0) {
+ TclGetTime(&now);
+ abortTime.sec = now.sec + timeout/1000;
+ abortTime.usec = now.usec + (timeout%1000)*1000;
+ if (abortTime.usec >= 1000000) {
+ abortTime.usec -= 1000000;
+ abortTime.sec += 1;
+ }
+ }
+
+ /*
+ * Loop in a mini-event loop of our own, waiting for either the
+ * file to become ready or a timeout to occur.
+ */
+
+ while (1) {
+ Tcl_WatchFile(file, mask);
+ if (timeout > 0) {
+ blockTime.sec = abortTime.sec - now.sec;
+ blockTime.usec = abortTime.usec - now.usec;
+ if (blockTime.usec < 0) {
+ blockTime.sec -= 1;
+ blockTime.usec += 1000000;
+ }
+ if (blockTime.sec < 0) {
+ blockTime.sec = 0;
+ blockTime.usec = 0;
+ }
+ Tcl_WaitForEvent(&blockTime);
+ } else if (timeout == 0) {
+ blockTime.sec = 0;
+ blockTime.usec = 0;
+ Tcl_WaitForEvent(&blockTime);
+ } else {
+ Tcl_WaitForEvent((Tcl_Time *) NULL);
+ }
+ present = Tcl_FileReady(file, mask);
+ if (present != 0) {
+ break;
+ }
+ if (timeout == 0) {
+ break;
+ }
+ TclGetTime(&now);
+ if ((abortTime.sec < now.sec)
+ || ((abortTime.sec == now.sec)
+ && (abortTime.usec <= now.usec))) {
+ break;
+ }
+ }
+ return present;
+}
diff --git a/contrib/tcl/generic/tclExpr.c b/contrib/tcl/generic/tclExpr.c
new file mode 100644
index 000000000000..13d020fa49c2
--- /dev/null
+++ b/contrib/tcl/generic/tclExpr.c
@@ -0,0 +1,2055 @@
+/*
+ * 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.
+ *
+ * SCCS: @(#) tclExpr.c 1.91 96/02/15 11:42:44
+ */
+
+#include "tclInt.h"
+#ifdef NO_FLOAT_H
+# include "../compat/float.h"
+#else
+# include <float.h>
+#endif
+#ifndef TCL_NO_MATH
+#include <math.h>
+#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"
+#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 = -((int)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) {
+ 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) {
+ if (!iPtr->noEval) {
+ badType = TYPE_STRING;
+ goto illegalType;
+ }
+
+ /*
+ * Must set valuePtr->intValue to avoid referencing
+ * uninitialized memory in the "if" below; the atual
+ * value doesn't matter, since it will be ignored.
+ */
+
+ valuePtr->intValue = 0;
+ }
+ 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) {
+ valuePtr->intValue = valuePtr->intValue * value2.intValue;
+ } 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;
+ }
+
+ /*
+ * 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) {
+ valuePtr->intValue = valuePtr->intValue + value2.intValue;
+ } else {
+ valuePtr->doubleValue += value2.doubleValue;
+ }
+ break;
+ case MINUS:
+ if (valuePtr->type == TYPE_INT) {
+ valuePtr->intValue = valuePtr->intValue - value2.intValue;
+ } 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;
+}
+
+/*
+ *--------------------------------------------------------------
+ *
+ * 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 = (long) 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_DYNAMIC;
+ 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, savedChar;
+ int i, 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 = (long) 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) _ANSI_ARGS_((double)) = (double (*)_ANSI_ARGS_((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) _ANSI_ARGS_((double, double))
+ = (double (*)_ANSI_ARGS_((double, 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 = (long) 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 = (long) (args[0].doubleValue - 0.5);
+ } else {
+ if (args[0].doubleValue >= (((double) LONG_MAX + 0.5))) {
+ goto tooLarge;
+ }
+ resultPtr->intValue = (long) (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;
+}
diff --git a/contrib/tcl/generic/tclFHandle.c b/contrib/tcl/generic/tclFHandle.c
new file mode 100644
index 000000000000..19875c5c4773
--- /dev/null
+++ b/contrib/tcl/generic/tclFHandle.c
@@ -0,0 +1,254 @@
+/*
+ * tclFHandle.c --
+ *
+ * This file contains functions for manipulating Tcl file handles.
+ *
+ * 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.
+ *
+ * SCCS: @(#) tclFHandle.c 1.6 96/02/13 16:29:55
+ */
+
+#include "tcl.h"
+#include "tclPort.h"
+
+/*
+ * The FileHashKey structure is used to associate the OS file handle and type
+ * with the corresponding notifier data in a FileHandle.
+ */
+
+typedef struct FileHashKey {
+ int type; /* File handle type. */
+ ClientData osHandle; /* Platform specific OS file handle. */
+} FileHashKey;
+
+typedef struct FileHandle {
+ FileHashKey key; /* Hash key for a given file. */
+ ClientData data; /* Platform specific notifier data. */
+ Tcl_FileFreeProc *proc; /* Callback to invoke when file is freed. */
+} FileHandle;
+
+/*
+ * Static variables used in this file:
+ */
+
+static Tcl_HashTable fileTable; /* Hash table containing file handles. */
+static int initialized = 0; /* 1 if this module has been initialized. */
+
+/*
+ * Static procedures used in this file:
+ */
+
+static void FileExitProc _ANSI_ARGS_((ClientData clientData));
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_GetFile --
+ *
+ * This function retrieves the file handle associated with a
+ * platform specific file handle of the given type. It creates
+ * a new file handle if needed.
+ *
+ * Results:
+ * Returns the file handle associated with the file descriptor.
+ *
+ * Side effects:
+ * Initializes the file handle table if necessary.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_File
+Tcl_GetFile(osHandle, type)
+ ClientData osHandle; /* Platform specific file handle. */
+ int type; /* Type of file handle. */
+{
+ FileHashKey key;
+ Tcl_HashEntry *entryPtr;
+ int new;
+
+ if (!initialized) {
+ Tcl_InitHashTable(&fileTable, sizeof(FileHashKey)/sizeof(int));
+ Tcl_CreateExitHandler(FileExitProc, 0);
+ initialized = 1;
+ }
+ key.osHandle = osHandle;
+ key.type = type;
+ entryPtr = Tcl_CreateHashEntry(&fileTable, (char *) &key, &new);
+ if (new) {
+ FileHandle *newHandlePtr;
+ newHandlePtr = (FileHandle *) ckalloc(sizeof(FileHandle));
+ newHandlePtr->key = key;
+ newHandlePtr->data = NULL;
+ newHandlePtr->proc = NULL;
+ Tcl_SetHashValue(entryPtr, newHandlePtr);
+ }
+
+ return (Tcl_File) Tcl_GetHashValue(entryPtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_FreeFile --
+ *
+ * Deallocates an entry in the file handle table.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_FreeFile(handle)
+ Tcl_File handle;
+{
+ Tcl_HashEntry *entryPtr;
+ FileHandle *handlePtr = (FileHandle *) handle;
+
+ /*
+ * Invoke free procedure, then delete the handle.
+ */
+
+ if (handlePtr->proc) {
+ (*handlePtr->proc)(handlePtr->data);
+ }
+
+ entryPtr = Tcl_FindHashEntry(&fileTable, (char *) &handlePtr->key);
+ if (entryPtr) {
+ Tcl_DeleteHashEntry(entryPtr);
+ ckfree((char *) handlePtr);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_GetFileInfo --
+ *
+ * This function retrieves the platform specific file data and
+ * type from the file handle.
+ *
+ * Results:
+ * If typePtr is not NULL, sets *typePtr to the type of the file.
+ * Returns the platform specific file data.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+ClientData
+Tcl_GetFileInfo(handle, typePtr)
+ Tcl_File handle;
+ int *typePtr;
+{
+ FileHandle *handlePtr = (FileHandle *) handle;
+
+ if (typePtr) {
+ *typePtr = handlePtr->key.type;
+ }
+ return handlePtr->key.osHandle;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_SetNotifierData --
+ *
+ * This function is used by the notifier to associate platform
+ * specific notifier information and a deletion procedure with
+ * a file handle.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Updates the data and delProc slots in the file handle.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_SetNotifierData(handle, proc, data)
+ Tcl_File handle;
+ Tcl_FileFreeProc *proc;
+ ClientData data;
+{
+ FileHandle *handlePtr = (FileHandle *) handle;
+ handlePtr->proc = proc;
+ handlePtr->data = data;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_GetNotifierData --
+ *
+ * This function is used by the notifier to retrieve the platform
+ * specific notifier information associated with a file handle.
+ *
+ * Results:
+ * Returns the data stored in a file handle by a previous call to
+ * Tcl_SetNotifierData, and places a pointer to the free proc
+ * in the location referred to by procPtr.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+ClientData
+Tcl_GetNotifierData(handle, procPtr)
+ Tcl_File handle;
+ Tcl_FileFreeProc **procPtr;
+{
+ FileHandle *handlePtr = (FileHandle *) handle;
+ if (procPtr != NULL) {
+ *procPtr = handlePtr->proc;
+ }
+ return handlePtr->data;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FileExitProc --
+ *
+ * This function an exit handler that frees any memory allocated
+ * for the file handle table.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Cleans up the file handle table.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+FileExitProc(clientData)
+ ClientData clientData; /* Not used. */
+{
+ Tcl_HashSearch search;
+ Tcl_HashEntry *entryPtr;
+
+ entryPtr = Tcl_FirstHashEntry(&fileTable, &search);
+
+ while (entryPtr) {
+ ckfree(Tcl_GetHashValue(entryPtr));
+ entryPtr = Tcl_NextHashEntry(&search);
+ }
+
+ Tcl_DeleteHashTable(&fileTable);
+}
diff --git a/contrib/tcl/generic/tclFileName.c b/contrib/tcl/generic/tclFileName.c
new file mode 100644
index 000000000000..90beb116d116
--- /dev/null
+++ b/contrib/tcl/generic/tclFileName.c
@@ -0,0 +1,1591 @@
+/*
+ * tclFileName.c --
+ *
+ * This file contains routines for converting file names betwen
+ * native and network form.
+ *
+ * Copyright (c) 1995-1996 Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * SCCS: @(#) tclFileName.c 1.23 96/04/19 12:34:28
+ */
+
+#include "tclInt.h"
+#include "tclPort.h"
+#include "tclRegexp.h"
+
+/*
+ * This variable indicates whether the cleanup procedure has been
+ * registered for this file yet.
+ */
+
+static int initialized = 0;
+
+/*
+ * The following regular expression matches the root portion of a Windows
+ * absolute or volume relative path. It will match both UNC and drive relative
+ * paths.
+ */
+
+#define WIN_ROOT_PATTERN "^(([a-zA-Z]:)|[/\\][/\\]+([^/\\]+)[/\\]+([^/\\]+)|([/\\]))([/\\])*"
+
+/*
+ * The following regular expression matches the root portion of a Macintosh
+ * absolute path. It will match degenerate Unix-style paths, tilde paths,
+ * Unix-style paths, and Mac paths.
+ */
+
+#define MAC_ROOT_PATTERN "^((/+([.][.]?/+)*([.][.]?)?)|(~[^:/]*)(/[^:]*)?|(~[^:]*)(:.*)?|/+([.][.]?/+)*([^:/]+)(/[^:]*)?|([^:]+):.*)$"
+
+/*
+ * The following variables are used to hold precompiled regular expressions
+ * for use in filename matching.
+ */
+
+static regexp *winRootPatternPtr = NULL;
+static regexp *macRootPatternPtr = NULL;
+
+/*
+ * The following variable is set in the TclPlatformInit call to one
+ * of: TCL_PLATFORM_UNIX, TCL_PLATFORM_MAC, or TCL_PLATFORM_WINDOWS.
+ */
+
+TclPlatformType tclPlatform = TCL_PLATFORM_UNIX;
+
+/*
+ * Prototypes for local procedures defined in this file:
+ */
+
+static char * DoTildeSubst _ANSI_ARGS_((Tcl_Interp *interp,
+ char *user, Tcl_DString *resultPtr));
+static char * ExtractWinRoot _ANSI_ARGS_((char *path,
+ Tcl_DString *resultPtr, int offset));
+static void FileNameCleanup _ANSI_ARGS_((ClientData clientData));
+static int SkipToChar _ANSI_ARGS_((char **stringPtr,
+ char *match));
+static char * SplitMacPath _ANSI_ARGS_((char *path,
+ Tcl_DString *bufPtr));
+static char * SplitWinPath _ANSI_ARGS_((char *path,
+ Tcl_DString *bufPtr));
+static char * SplitUnixPath _ANSI_ARGS_((char *path,
+ Tcl_DString *bufPtr));
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FileNameCleanup --
+ *
+ * This procedure is a Tcl_ExitProc used to clean up the static
+ * data structures used in this file.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Deallocates storage used by the procedures in this file.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+FileNameCleanup(clientData)
+ ClientData clientData; /* Not used. */
+{
+ if (winRootPatternPtr != NULL) {
+ ckfree((char *)winRootPatternPtr);
+ }
+ if (macRootPatternPtr != NULL) {
+ ckfree((char *)macRootPatternPtr);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ExtractWinRoot --
+ *
+ * Matches the root portion of a Windows path and appends it
+ * to the specified Tcl_DString.
+ *
+ * Results:
+ * Returns the position in the path immediately after the root
+ * including any trailing slashes.
+ * Appends a cleaned up version of the root to the Tcl_DString
+ * at the specified offest.
+ *
+ * Side effects:
+ * Modifies the specified Tcl_DString.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static char *
+ExtractWinRoot(path, resultPtr, offset)
+ char *path; /* Path to parse. */
+ Tcl_DString *resultPtr; /* Buffer to hold result. */
+ int offset; /* Offset in buffer where result should be
+ * stored. */
+{
+ int length;
+
+ /*
+ * Initialize the path name parser for Windows path names.
+ */
+
+ if (winRootPatternPtr == NULL) {
+ winRootPatternPtr = TclRegComp(WIN_ROOT_PATTERN);
+ if (!initialized) {
+ Tcl_CreateExitHandler(FileNameCleanup, NULL);
+ initialized = 1;
+ }
+ }
+
+ /*
+ * Match the root portion of a Windows path name.
+ */
+
+ if (!TclRegExec(winRootPatternPtr, path, path)) {
+ return path;
+ }
+
+ Tcl_DStringSetLength(resultPtr, offset);
+
+ if (winRootPatternPtr->startp[2] != NULL) {
+ Tcl_DStringAppend(resultPtr, winRootPatternPtr->startp[2], 2);
+ if (winRootPatternPtr->startp[6] != NULL) {
+ Tcl_DStringAppend(resultPtr, "/", 1);
+ }
+ } else if (winRootPatternPtr->startp[4] != NULL) {
+ Tcl_DStringAppend(resultPtr, "//", 2);
+ length = winRootPatternPtr->endp[3]
+ - winRootPatternPtr->startp[3];
+ Tcl_DStringAppend(resultPtr, winRootPatternPtr->startp[3], length);
+ Tcl_DStringAppend(resultPtr, "/", 1);
+ length = winRootPatternPtr->endp[4]
+ - winRootPatternPtr->startp[4];
+ Tcl_DStringAppend(resultPtr, winRootPatternPtr->startp[4], length);
+ } else {
+ Tcl_DStringAppend(resultPtr, "/", 1);
+ }
+ return winRootPatternPtr->endp[0];
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_GetPathType --
+ *
+ * Determines whether a given path is relative to the current
+ * directory, relative to the current volume, or absolute.
+ *
+ * Results:
+ * Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or
+ * TCL_PATH_VOLUME_RELATIVE.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_PathType
+Tcl_GetPathType(path)
+ char *path;
+{
+ Tcl_PathType type = TCL_PATH_ABSOLUTE;
+
+ switch (tclPlatform) {
+ case TCL_PLATFORM_UNIX:
+ /*
+ * Paths that begin with / or ~ are absolute.
+ */
+
+ if ((path[0] != '/') && (path[0] != '~')) {
+ type = TCL_PATH_RELATIVE;
+ }
+ break;
+
+ case TCL_PLATFORM_MAC:
+ if (path[0] == ':') {
+ type = TCL_PATH_RELATIVE;
+ } else if (path[0] != '~') {
+
+ /*
+ * Since we have eliminated the easy cases, use the
+ * root pattern to look for the other types.
+ */
+
+ if (!macRootPatternPtr) {
+ macRootPatternPtr = TclRegComp(MAC_ROOT_PATTERN);
+ if (!initialized) {
+ Tcl_CreateExitHandler(FileNameCleanup, NULL);
+ initialized = 1;
+ }
+ }
+ if (!TclRegExec(macRootPatternPtr, path, path)
+ || (macRootPatternPtr->startp[2] != NULL)) {
+ type = TCL_PATH_RELATIVE;
+ }
+ }
+ break;
+
+ case TCL_PLATFORM_WINDOWS:
+ if (path[0] != '~') {
+
+ /*
+ * Since we have eliminated the easy cases, check for
+ * drive relative paths using the regular expression.
+ */
+
+ if (!winRootPatternPtr) {
+ winRootPatternPtr = TclRegComp(WIN_ROOT_PATTERN);
+ if (!initialized) {
+ Tcl_CreateExitHandler(FileNameCleanup, NULL);
+ initialized = 1;
+ }
+ }
+ if (TclRegExec(winRootPatternPtr, path, path)) {
+ if (winRootPatternPtr->startp[5]
+ || (winRootPatternPtr->startp[2]
+ && !(winRootPatternPtr->startp[6]))) {
+ type = TCL_PATH_VOLUME_RELATIVE;
+ }
+ } else {
+ type = TCL_PATH_RELATIVE;
+ }
+ }
+ break;
+ }
+ return type;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_SplitPath --
+ *
+ * Split a path into a list of path components. The first element
+ * of the list will have the same path type as the original path.
+ *
+ * Results:
+ * Returns a standard Tcl result. The interpreter result contains
+ * a list of path components.
+ * *argvPtr will be filled in with the address of an array
+ * whose elements point to the elements of path, 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 path elements.
+ * The caller must eventually free this memory by calling ckfree()
+ * on *argvPtr. Note: *argvPtr and *argcPtr are only modified
+ * if the procedure returns normally.
+ *
+ * Side effects:
+ * Allocates memory.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_SplitPath(path, argcPtr, argvPtr)
+ char *path; /* Pointer to string containing a path. */
+ int *argcPtr; /* Pointer to location to fill in with
+ * the number of elements in the path. */
+ char ***argvPtr; /* Pointer to place to store pointer to array
+ * of pointers to path elements. */
+{
+ int i, size;
+ char *p;
+ Tcl_DString buffer;
+ Tcl_DStringInit(&buffer);
+
+ /*
+ * Perform platform specific splitting. These routines will leave the
+ * result in the specified buffer. Individual elements are terminated
+ * with a null character.
+ */
+
+ p = NULL; /* Needed only to prevent gcc warnings. */
+ switch (tclPlatform) {
+ case TCL_PLATFORM_UNIX:
+ p = SplitUnixPath(path, &buffer);
+ break;
+
+ case TCL_PLATFORM_WINDOWS:
+ p = SplitWinPath(path, &buffer);
+ break;
+
+ case TCL_PLATFORM_MAC:
+ p = SplitMacPath(path, &buffer);
+ break;
+ }
+
+ /*
+ * Compute the number of elements in the result.
+ */
+
+ size = Tcl_DStringLength(&buffer);
+ *argcPtr = 0;
+ for (i = 0; i < size; i++) {
+ if (p[i] == '\0') {
+ (*argcPtr)++;
+ }
+ }
+
+ /*
+ * Allocate a buffer large enough to hold the contents of the
+ * DString plus the argv pointers and the terminating NULL pointer.
+ */
+
+ *argvPtr = (char **) ckalloc((unsigned)
+ ((((*argcPtr) + 1) * sizeof(char *)) + size));
+
+ /*
+ * Position p after the last argv pointer and copy the contents of
+ * the DString.
+ */
+
+ p = (char *) &(*argvPtr)[(*argcPtr) + 1];
+ memcpy((VOID *) p, (VOID *) Tcl_DStringValue(&buffer), (size_t) size);
+
+ /*
+ * Now set up the argv pointers.
+ */
+
+ for (i = 0; i < *argcPtr; i++) {
+ (*argvPtr)[i] = p;
+ while ((*p++) != '\0') {}
+ }
+ (*argvPtr)[i] = NULL;
+
+ Tcl_DStringFree(&buffer);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * SplitUnixPath --
+ *
+ * This routine is used by Tcl_SplitPath to handle splitting
+ * Unix paths.
+ *
+ * Results:
+ * Stores a null separated array of strings in the specified
+ * Tcl_DString.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static char *
+SplitUnixPath(path, bufPtr)
+ char *path; /* Pointer to string containing a path. */
+ Tcl_DString *bufPtr; /* Pointer to DString to use for the result. */
+{
+ int length;
+ char *p, *elementStart;
+
+ /*
+ * Deal with the root directory as a special case.
+ */
+
+ if (path[0] == '/') {
+ Tcl_DStringAppend(bufPtr, "/", 2);
+ p = path+1;
+ } else {
+ p = path;
+ }
+
+ /*
+ * Split on slashes. Embedded elements that start with tilde will be
+ * prefixed with "./" so they are not affected by tilde substitution.
+ */
+
+ for (;;) {
+ elementStart = p;
+ while ((*p != '\0') && (*p != '/')) {
+ p++;
+ }
+ length = p - elementStart;
+ if (length > 0) {
+ if ((elementStart[0] == '~') && (elementStart != path)) {
+ Tcl_DStringAppend(bufPtr, "./", 2);
+ }
+ Tcl_DStringAppend(bufPtr, elementStart, length);
+ Tcl_DStringAppend(bufPtr, "", 1);
+ }
+ if (*p++ == '\0') {
+ break;
+ }
+ }
+ return Tcl_DStringValue(bufPtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * SplitWinPath --
+ *
+ * This routine is used by Tcl_SplitPath to handle splitting
+ * Windows paths.
+ *
+ * Results:
+ * Stores a null separated array of strings in the specified
+ * Tcl_DString.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static char *
+SplitWinPath(path, bufPtr)
+ char *path; /* Pointer to string containing a path. */
+ Tcl_DString *bufPtr; /* Pointer to DString to use for the result. */
+{
+ int length;
+ char *p, *elementStart;
+
+ p = ExtractWinRoot(path, bufPtr, 0);
+
+ /*
+ * Terminate the root portion, if we matched something.
+ */
+
+ if (p != path) {
+ Tcl_DStringAppend(bufPtr, "", 1);
+ }
+
+ /*
+ * Split on slashes. Embedded elements that start with tilde will be
+ * prefixed with "./" so they are not affected by tilde substitution.
+ */
+
+ do {
+ elementStart = p;
+ while ((*p != '\0') && (*p != '/') && (*p != '\\')) {
+ p++;
+ }
+ length = p - elementStart;
+ if (length > 0) {
+ if ((elementStart[0] == '~') && (elementStart != path)) {
+ Tcl_DStringAppend(bufPtr, "./", 2);
+ }
+ Tcl_DStringAppend(bufPtr, elementStart, length);
+ Tcl_DStringAppend(bufPtr, "", 1);
+ }
+ } while (*p++ != '\0');
+
+ return Tcl_DStringValue(bufPtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * SplitMacPath --
+ *
+ * This routine is used by Tcl_SplitPath to handle splitting
+ * Macintosh paths.
+ *
+ * Results:
+ * Returns a newly allocated argv array.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static char *
+SplitMacPath(path, bufPtr)
+ char *path; /* Pointer to string containing a path. */
+ Tcl_DString *bufPtr; /* Pointer to DString to use for the result. */
+{
+ int isMac = 0; /* 1 if is Mac-style, 0 if Unix-style path. */
+ int i, length;
+ char *p, *elementStart;
+
+ /*
+ * Initialize the path name parser for Macintosh path names.
+ */
+
+ if (macRootPatternPtr == NULL) {
+ macRootPatternPtr = TclRegComp(MAC_ROOT_PATTERN);
+ if (!initialized) {
+ Tcl_CreateExitHandler(FileNameCleanup, NULL);
+ initialized = 1;
+ }
+ }
+
+ /*
+ * Match the root portion of a Mac path name.
+ */
+
+ i = 0; /* Needed only to prevent gcc warnings. */
+ if (TclRegExec(macRootPatternPtr, path, path) == 1) {
+ /*
+ * Treat degenerate absolute paths like / and /../.. as
+ * Mac relative file names for lack of anything else to do.
+ */
+
+ if (macRootPatternPtr->startp[2] != NULL) {
+ Tcl_DStringAppend(bufPtr, ":", 1);
+ Tcl_DStringAppend(bufPtr, path, macRootPatternPtr->endp[0]
+ - macRootPatternPtr->startp[0] + 1);
+ return Tcl_DStringValue(bufPtr);
+ }
+
+ if (macRootPatternPtr->startp[5] != NULL) {
+
+ /*
+ * Unix-style tilde prefixed paths.
+ */
+
+ isMac = 0;
+ i = 5;
+ } else if (macRootPatternPtr->startp[7] != NULL) {
+
+ /*
+ * Mac-style tilde prefixed paths.
+ */
+
+ isMac = 1;
+ i = 7;
+ } else if (macRootPatternPtr->startp[10] != NULL) {
+
+ /*
+ * Normal Unix style paths.
+ */
+
+ isMac = 0;
+ i = 10;
+ } else if (macRootPatternPtr->startp[12] != NULL) {
+
+ /*
+ * Normal Mac style paths.
+ */
+
+ isMac = 1;
+ i = 12;
+ }
+
+ length = macRootPatternPtr->endp[i]
+ - macRootPatternPtr->startp[i];
+
+ /*
+ * Append the element and terminate it with a : and a null. Note that
+ * we are forcing the DString to contain an extra null at the end.
+ */
+
+ Tcl_DStringAppend(bufPtr, macRootPatternPtr->startp[i], length);
+ Tcl_DStringAppend(bufPtr, ":", 2);
+ p = macRootPatternPtr->endp[i];
+ } else {
+ isMac = (strchr(path, ':') != NULL);
+ p = path;
+ }
+
+ if (isMac) {
+
+ /*
+ * p is pointing at the first colon in the path. There
+ * will always be one, since this is a Mac-style path.
+ */
+
+ elementStart = p++;
+ while ((p = strchr(p, ':')) != NULL) {
+ length = p - elementStart;
+ if (length == 1) {
+ while (*p == ':') {
+ Tcl_DStringAppend(bufPtr, "::", 3);
+ elementStart = p++;
+ }
+ } else {
+ /*
+ * If this is a simple component, drop the leading colon.
+ */
+
+ if ((elementStart[1] != '~')
+ && (strchr(elementStart+1, '/') == NULL)) {
+ elementStart++;
+ length--;
+ }
+ Tcl_DStringAppend(bufPtr, elementStart, length);
+ Tcl_DStringAppend(bufPtr, "", 1);
+ elementStart = p++;
+ }
+ }
+ if (elementStart[1] != '\0' || elementStart == path) {
+ if ((elementStart[1] != '~') && (elementStart[1] != '\0')
+ && (strchr(elementStart+1, '/') == NULL)) {
+ elementStart++;
+ }
+ Tcl_DStringAppend(bufPtr, elementStart, -1);
+ Tcl_DStringAppend(bufPtr, "", 1);
+ }
+ } else {
+
+ /*
+ * Split on slashes, suppress extra /'s, and convert .. to ::.
+ */
+
+ for (;;) {
+ elementStart = p;
+ while ((*p != '\0') && (*p != '/')) {
+ p++;
+ }
+ length = p - elementStart;
+ if (length > 0) {
+ if ((length == 1) && (elementStart[0] == '.')) {
+ Tcl_DStringAppend(bufPtr, ":", 2);
+ } else if ((length == 2) && (elementStart[0] == '.')
+ && (elementStart[1] == '.')) {
+ Tcl_DStringAppend(bufPtr, "::", 3);
+ } else {
+ if (*elementStart == '~') {
+ Tcl_DStringAppend(bufPtr, ":", 1);
+ }
+ Tcl_DStringAppend(bufPtr, elementStart, length);
+ Tcl_DStringAppend(bufPtr, "", 1);
+ }
+ }
+ if (*p++ == '\0') {
+ break;
+ }
+ }
+ }
+ return Tcl_DStringValue(bufPtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_JoinPath --
+ *
+ * Combine a list of paths in a platform specific manner.
+ *
+ * Results:
+ * Appends the joined path to the end of the specified
+ * returning a pointer to the resulting string. Note that
+ * the Tcl_DString must already be initialized.
+ *
+ * Side effects:
+ * Modifies the Tcl_DString.
+ *
+ *----------------------------------------------------------------------
+ */
+
+char *
+Tcl_JoinPath(argc, argv, resultPtr)
+ int argc;
+ char **argv;
+ Tcl_DString *resultPtr; /* Pointer to previously initialized DString. */
+{
+ int oldLength, length, i, needsSep;
+ Tcl_DString buffer;
+ char *p, c, *dest;
+
+ Tcl_DStringInit(&buffer);
+ oldLength = Tcl_DStringLength(resultPtr);
+
+ switch (tclPlatform) {
+ case TCL_PLATFORM_UNIX:
+ for (i = 0; i < argc; i++) {
+ p = argv[i];
+ /*
+ * If the path is absolute, reset the result buffer.
+ * Consume any duplicate leading slashes or a ./ in
+ * front of a tilde prefixed path that isn't at the
+ * beginning of the path.
+ */
+
+ if (*p == '/') {
+ Tcl_DStringSetLength(resultPtr, oldLength);
+ Tcl_DStringAppend(resultPtr, "/", 1);
+ while (*p == '/') {
+ p++;
+ }
+ } else if (*p == '~') {
+ Tcl_DStringSetLength(resultPtr, oldLength);
+ } else if ((Tcl_DStringLength(resultPtr) != oldLength)
+ && (p[0] == '.') && (p[1] == '/')
+ && (p[2] == '~')) {
+ p += 2;
+ }
+
+ if (*p == '\0') {
+ continue;
+ }
+
+ /*
+ * Append a separator if needed.
+ */
+
+ length = Tcl_DStringLength(resultPtr);
+ if ((length != oldLength)
+ && (Tcl_DStringValue(resultPtr)[length-1] != '/')) {
+ Tcl_DStringAppend(resultPtr, "/", 1);
+ length++;
+ }
+
+ /*
+ * Append the element, eliminating duplicate and trailing
+ * slashes.
+ */
+
+ Tcl_DStringSetLength(resultPtr, (int) (length + strlen(p)));
+ dest = Tcl_DStringValue(resultPtr) + length;
+ for (; *p != '\0'; p++) {
+ if (*p == '/') {
+ while (p[1] == '/') {
+ p++;
+ }
+ if (p[1] != '\0') {
+ *dest++ = '/';
+ }
+ } else {
+ *dest++ = *p;
+ }
+ }
+ length = dest - Tcl_DStringValue(resultPtr);
+ Tcl_DStringSetLength(resultPtr, length);
+ }
+ break;
+
+ case TCL_PLATFORM_WINDOWS:
+ /*
+ * Iterate over all of the components. If a component is
+ * absolute, then reset the result and start building the
+ * path from the current component on.
+ */
+
+ for (i = 0; i < argc; i++) {
+ p = ExtractWinRoot(argv[i], resultPtr, oldLength);
+ length = Tcl_DStringLength(resultPtr);
+
+ /*
+ * If the pointer didn't move, then this is a relative path
+ * or a tilde prefixed path.
+ */
+
+ if (p == argv[i]) {
+ /*
+ * Remove the ./ from tilde prefixed elements unless
+ * it is the first component.
+ */
+
+ if ((length != oldLength)
+ && (p[0] == '.')
+ && ((p[1] == '/') || (p[1] == '\\'))
+ && (p[2] == '~')) {
+ p += 2;
+ } else if (*p == '~') {
+ Tcl_DStringSetLength(resultPtr, oldLength);
+ length = oldLength;
+ }
+ }
+
+ if (*p != '\0') {
+ /*
+ * Check to see if we need to append a separator.
+ */
+
+
+ if (length != oldLength) {
+ c = Tcl_DStringValue(resultPtr)[length-1];
+ if ((c != '/') && (c != ':')) {
+ Tcl_DStringAppend(resultPtr, "/", 1);
+ }
+ }
+
+ /*
+ * Append the element, eliminating duplicate and
+ * trailing slashes.
+ */
+
+ length = Tcl_DStringLength(resultPtr);
+ Tcl_DStringSetLength(resultPtr, (int) (length + strlen(p)));
+ dest = Tcl_DStringValue(resultPtr) + length;
+ for (; *p != '\0'; p++) {
+ if ((*p == '/') || (*p == '\\')) {
+ while ((p[1] == '/') || (p[1] == '\\')) {
+ p++;
+ }
+ if (p[1] != '\0') {
+ *dest++ = '/';
+ }
+ } else {
+ *dest++ = *p;
+ }
+ }
+ length = dest - Tcl_DStringValue(resultPtr);
+ Tcl_DStringSetLength(resultPtr, length);
+ }
+ }
+ break;
+
+ case TCL_PLATFORM_MAC:
+ needsSep = 1;
+ for (i = 0; i < argc; i++) {
+ Tcl_DStringSetLength(&buffer, 0);
+ p = SplitMacPath(argv[i], &buffer);
+ if ((*p != ':') && (*p != '\0')
+ && (strchr(p, ':') != NULL)) {
+ Tcl_DStringSetLength(resultPtr, oldLength);
+ length = strlen(p);
+ Tcl_DStringAppend(resultPtr, p, length);
+ needsSep = 0;
+ p += length+1;
+ }
+
+ /*
+ * Now append the rest of the path elements, skipping
+ * : unless it is the first element of the path, and
+ * watching out for :: et al. so we don't end up with
+ * too many colons in the result.
+ */
+
+ for (; *p != '\0'; p += length+1) {
+ if (p[0] == ':' && p[1] == '\0') {
+ if (Tcl_DStringLength(resultPtr) != oldLength) {
+ p++;
+ } else {
+ needsSep = 0;
+ }
+ } else {
+ c = p[1];
+ if (*p == ':') {
+ if (!needsSep) {
+ p++;
+ }
+ } else {
+ if (needsSep) {
+ Tcl_DStringAppend(resultPtr, ":", 1);
+ }
+ }
+ needsSep = (c == ':') ? 0 : 1;
+ }
+ length = strlen(p);
+ Tcl_DStringAppend(resultPtr, p, length);
+ }
+ }
+ break;
+
+ }
+ Tcl_DStringFree(&buffer);
+ return Tcl_DStringValue(resultPtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_TranslateFileName --
+ *
+ * Converts a file name into a form usable by the native system
+ * interfaces. If the name starts with a tilde, it will 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
+ * name, then an error message is left in interp->result
+ * and the return value is NULL. The result will be stored
+ * in bufferPtr; the caller must call Tcl_DStringFree(bufferPtr)
+ * to free the name if the return value was not NULL.
+ *
+ * Side effects:
+ * Information may be left in bufferPtr.
+ *
+ *---------------------------------------------------------------------- */
+
+char *
+Tcl_TranslateFileName(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 "~<user>" (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. */
+{
+ register char *p;
+
+ /*
+ * Handle tilde substitutions, if needed.
+ */
+
+ if (name[0] == '~') {
+ int argc, length;
+ char **argv;
+ Tcl_DString temp;
+
+ Tcl_SplitPath(name, &argc, &argv);
+
+ /*
+ * Strip the trailing ':' off of a Mac path
+ * before passing the user name to DoTildeSubst.
+ */
+
+ if (tclPlatform == TCL_PLATFORM_MAC) {
+ length = strlen(argv[0]);
+ argv[0][length-1] = '\0';
+ }
+
+ Tcl_DStringInit(&temp);
+ argv[0] = DoTildeSubst(interp, argv[0]+1, &temp);
+ if (argv[0] == NULL) {
+ Tcl_DStringFree(&temp);
+ ckfree((char *)argv);
+ return NULL;
+ }
+ Tcl_DStringInit(bufferPtr);
+ Tcl_JoinPath(argc, argv, bufferPtr);
+ Tcl_DStringFree(&temp);
+ ckfree((char*)argv);
+ } else {
+ Tcl_DStringInit(bufferPtr);
+ Tcl_JoinPath(1, &name, bufferPtr);
+ }
+
+ /*
+ * Convert forward slashes to backslashes in Windows paths because
+ * some system interfaces don't accept forward slashes.
+ */
+
+ if (tclPlatform == TCL_PLATFORM_WINDOWS) {
+ for (p = Tcl_DStringValue(bufferPtr); *p != '\0'; p++) {
+ if (*p == '/') {
+ *p = '\\';
+ }
+ }
+ }
+ return Tcl_DStringValue(bufferPtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclGetExtension --
+ *
+ * This function returns a pointer to the beginning of the
+ * extension part of a file name.
+ *
+ * Results:
+ * Returns a pointer into name which indicates where the extension
+ * starts. If there is no extension, returns NULL.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+char *
+TclGetExtension(name)
+ char *name; /* File name to parse. */
+{
+ char *p, *lastSep;
+
+ /*
+ * First find the last directory separator.
+ */
+
+ lastSep = NULL; /* Needed only to prevent gcc warnings. */
+ switch (tclPlatform) {
+ case TCL_PLATFORM_UNIX:
+ lastSep = strrchr(name, '/');
+ break;
+
+ case TCL_PLATFORM_MAC:
+ if (strchr(name, ':') == NULL) {
+ lastSep = strrchr(name, '/');
+ } else {
+ lastSep = strrchr(name, ':');
+ }
+ break;
+
+ case TCL_PLATFORM_WINDOWS:
+ lastSep = NULL;
+ for (p = name; *p != '\0'; p++) {
+ if (strchr("/\\:", *p) != NULL) {
+ lastSep = p;
+ }
+ }
+ break;
+ }
+ p = strrchr(name, '.');
+ if ((p != NULL) && (lastSep != NULL)
+ && (lastSep > p)) {
+ p = NULL;
+ }
+ return p;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * DoTildeSubst --
+ *
+ * Given a string following a tilde, this routine returns the
+ * corresponding home directory.
+ *
+ * Results:
+ * The result is a pointer to a static string containing the home
+ * directory in native format. If there was an error in processing
+ * the substitution, then an error message is left in interp->result
+ * and the return value is NULL. On success, the results are appended
+ * to resultPtr, and the contents of resultPtr are returned.
+ *
+ * Side effects:
+ * Information may be left in resultPtr.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static char *
+DoTildeSubst(interp, user, resultPtr)
+ Tcl_Interp *interp; /* Interpreter in which to store error
+ * message (if necessary). */
+ char *user; /* Name of user whose home directory should be
+ * substituted, or "" for current user. */
+ Tcl_DString *resultPtr; /* May be used to hold result. Must not hold
+ * anything at the time of the call, and need
+ * not even be initialized. */
+{
+ char *dir;
+
+ if (*user == '\0') {
+ dir = TclGetEnv("HOME");
+ if (dir == NULL) {
+ if (interp) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendResult(interp, "couldn't find HOME environment ",
+ "variable to expand path", (char *) NULL);
+ }
+ return NULL;
+ }
+ Tcl_JoinPath(1, &dir, resultPtr);
+ } else {
+ if (TclGetUserHome(user, resultPtr) == NULL) {
+ if (interp) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendResult(interp, "user \"", user, "\" doesn't exist",
+ (char *) NULL);
+ }
+ return NULL;
+ }
+ }
+ return resultPtr->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, noComplain, firstArg;
+ char c;
+ int result = TCL_OK;
+ Tcl_DString buffer;
+ char *separators, *head, *tail;
+
+ 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) {
+ Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
+ " ?switches? name ?name ...?\"", (char *) NULL);
+ return TCL_ERROR;
+ }
+
+ Tcl_DStringInit(&buffer);
+ separators = NULL; /* Needed only to prevent gcc warnings. */
+ for (i = firstArg; i < argc; i++) {
+ head = tail = "";
+
+ switch (tclPlatform) {
+ case TCL_PLATFORM_UNIX:
+ separators = "/";
+ break;
+ case TCL_PLATFORM_WINDOWS:
+ separators = "/\\:";
+ break;
+ case TCL_PLATFORM_MAC:
+ separators = (strchr(argv[i], ':') == NULL) ? "/" : ":";
+ break;
+ }
+
+ Tcl_DStringSetLength(&buffer, 0);
+
+ /*
+ * Perform tilde substitution, if needed.
+ */
+
+ if (argv[i][0] == '~') {
+ char *p;
+
+ /*
+ * Find the first path separator after the tilde.
+ */
+
+ for (tail = argv[i]; *tail != '\0'; tail++) {
+ if (*tail == '\\') {
+ if (strchr(separators, tail[1]) != NULL) {
+ break;
+ }
+ } else if (strchr(separators, *tail) != NULL) {
+ break;
+ }
+ }
+
+ /*
+ * Determine the home directory for the specified user. Note that
+ * we don't allow special characters in the user name.
+ */
+
+ c = *tail;
+ *tail = '\0';
+ p = strpbrk(argv[i]+1, "\\[]*?{}");
+ if (p == NULL) {
+ head = DoTildeSubst(interp, argv[i]+1, &buffer);
+ } else {
+ if (!noComplain) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendResult(interp, "globbing characters not ",
+ "supported in user names", (char *) NULL);
+ }
+ head = NULL;
+ }
+ *tail = c;
+ if (head == NULL) {
+ if (noComplain) {
+ Tcl_ResetResult(interp);
+ continue;
+ } else {
+ result = TCL_ERROR;
+ goto done;
+ }
+ }
+ if (head != Tcl_DStringValue(&buffer)) {
+ Tcl_DStringAppend(&buffer, head, -1);
+ }
+ } else {
+ tail = argv[i];
+ }
+
+ result = TclDoGlob(interp, separators, &buffer, tail);
+ if (result != TCL_OK) {
+ if (noComplain) {
+ Tcl_ResetResult(interp);
+ continue;
+ } else {
+ goto done;
+ }
+ }
+ }
+
+ 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);
+ result = TCL_ERROR;
+ }
+done:
+ Tcl_DStringFree(&buffer);
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * SkipToChar --
+ *
+ * This function traverses a glob pattern looking for the next
+ * unquoted occurance of the specified character at the same braces
+ * nesting level.
+ *
+ * Results:
+ * Updates stringPtr to point to the matching character, or to
+ * the end of the string if nothing matched. The return value
+ * is 1 if a match was found at the top level, otherwise it is 0.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+SkipToChar(stringPtr, match)
+ char **stringPtr; /* Pointer string to check. */
+ char *match; /* Pointer to character to find. */
+{
+ int quoted, level;
+ register char *p;
+
+ quoted = 0;
+ level = 0;
+
+ for (p = *stringPtr; *p != '\0'; p++) {
+ if (quoted) {
+ quoted = 0;
+ continue;
+ }
+ if ((level == 0) && (*p == *match)) {
+ *stringPtr = p;
+ return 1;
+ }
+ if (*p == '{') {
+ level++;
+ } else if (*p == '}') {
+ level--;
+ } else if (*p == '\\') {
+ quoted = 1;
+ }
+ }
+ *stringPtr = p;
+ return 0;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclDoGlob --
+ *
+ * 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. The directory and
+ * remainder are assumed to be native format paths.
+ *
+ * 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.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclDoGlob(interp, separators, headPtr, tail)
+ Tcl_Interp *interp; /* Interpreter to use for error reporting
+ * (e.g. unmatched brace). */
+ char *separators; /* String containing separator characters
+ * that should be used to identify globbing
+ * boundaries. */
+ Tcl_DString *headPtr; /* Completely expanded prefix. */
+ char *tail; /* The unexpanded remainder of the path. */
+{
+ int level, baseLength, quoted, count;
+ int result = TCL_OK;
+ char *p, *openBrace, *closeBrace, *name, savedChar;
+ char lastChar = 0;
+ int length = Tcl_DStringLength(headPtr);
+
+ if (length > 0) {
+ lastChar = Tcl_DStringValue(headPtr)[length-1];
+ }
+
+ /*
+ * Consume any leading directory separators, leaving tail pointing
+ * just past the last initial separator.
+ */
+
+ count = 0;
+ name = tail;
+ for (; *tail != '\0'; tail++) {
+ if ((*tail == '\\') && (strchr(separators, tail[1]) != NULL)) {
+ tail++;
+ } else if (strchr(separators, *tail) == NULL) {
+ break;
+ }
+ count++;
+ }
+
+ /*
+ * Deal with path separators. On the Mac, we have to watch out
+ * for multiple separators, since they are special in Mac-style
+ * paths.
+ */
+
+ switch (tclPlatform) {
+ case TCL_PLATFORM_MAC:
+ if (*separators == '/') {
+ if (((length == 0) && (count == 0))
+ || ((length > 0) && (lastChar != ':'))) {
+ Tcl_DStringAppend(headPtr, ":", 1);
+ }
+ } else {
+ if (count == 0) {
+ if ((length > 0) && (lastChar != ':')) {
+ Tcl_DStringAppend(headPtr, ":", 1);
+ }
+ } else {
+ if (lastChar == ':') {
+ count--;
+ }
+ while (count-- > 0) {
+ Tcl_DStringAppend(headPtr, ":", 1);
+ }
+ }
+ }
+ break;
+ case TCL_PLATFORM_WINDOWS:
+ /*
+ * If this is a drive relative path, add the colon and the
+ * trailing slash if needed. Otherwise add the slash if
+ * this is the first absolute element, or a later relative
+ * element. Add an extra slash if this is a UNC path.
+ */
+
+ if (*name == ':') {
+ Tcl_DStringAppend(headPtr, ":", 1);
+ if (count > 1) {
+ Tcl_DStringAppend(headPtr, "/", 1);
+ }
+ } else if ((*tail != '\0')
+ && (((length > 0)
+ && (strchr(separators, lastChar) == NULL))
+ || ((length == 0) && (count > 0)))) {
+ Tcl_DStringAppend(headPtr, "/", 1);
+ if ((length == 0) && (count > 1)) {
+ Tcl_DStringAppend(headPtr, "/", 1);
+ }
+ }
+
+ break;
+ case TCL_PLATFORM_UNIX:
+ /*
+ * Add a separator if this is the first absolute element, or
+ * a later relative element.
+ */
+
+ if ((*tail != '\0')
+ && (((length > 0)
+ && (strchr(separators, lastChar) == NULL))
+ || ((length == 0) && (count > 0)))) {
+ Tcl_DStringAppend(headPtr, "/", 1);
+ }
+ break;
+ }
+
+ /*
+ * Look for the first matching pair of braces or the first
+ * directory separator that is not inside a pair of braces.
+ */
+
+ openBrace = closeBrace = NULL;
+ level = 0;
+ quoted = 0;
+ for (p = tail; *p != '\0'; p++) {
+ if (quoted) {
+ quoted = 0;
+ } else if (*p == '\\') {
+ quoted = 1;
+ if (strchr(separators, p[1]) != NULL) {
+ break; /* Quoted directory separator. */
+ }
+ } else if (strchr(separators, *p) != NULL) {
+ break; /* Unquoted directory separator. */
+ } else if (*p == '{') {
+ openBrace = p;
+ p++;
+ if (SkipToChar(&p, "}")) {
+ closeBrace = p; /* Balanced braces. */
+ break;
+ }
+ Tcl_ResetResult(interp);
+ interp->result = "unmatched open-brace in file name";
+ return TCL_ERROR;
+ } else if (*p == '}') {
+ Tcl_ResetResult(interp);
+ interp->result = "unmatched close-brace in file name";
+ return TCL_ERROR;
+ }
+ }
+
+ /*
+ * Substitute the alternate patterns from the braces and recurse.
+ */
+
+ if (openBrace != NULL) {
+ char *element;
+ Tcl_DString newName;
+ Tcl_DStringInit(&newName);
+
+ /*
+ * For each element within in the outermost pair of braces,
+ * append the element and the remainder to the fixed portion
+ * before the first brace and recursively call TclDoGlob.
+ */
+
+ Tcl_DStringAppend(&newName, tail, openBrace-tail);
+ baseLength = Tcl_DStringLength(&newName);
+ length = Tcl_DStringLength(headPtr);
+ *closeBrace = '\0';
+ for (p = openBrace; p != closeBrace; ) {
+ p++;
+ element = p;
+ SkipToChar(&p, ",");
+ Tcl_DStringSetLength(headPtr, length);
+ Tcl_DStringSetLength(&newName, baseLength);
+ Tcl_DStringAppend(&newName, element, p-element);
+ Tcl_DStringAppend(&newName, closeBrace+1, -1);
+ result = TclDoGlob(interp, separators,
+ headPtr, Tcl_DStringValue(&newName));
+ if (result != TCL_OK) {
+ break;
+ }
+ }
+ *closeBrace = '}';
+ Tcl_DStringFree(&newName);
+ return result;
+ }
+
+ /*
+ * At this point, there are no more brace substitutions to perform on
+ * this path component. The variable p is pointing at a quoted or
+ * unquoted directory separator or the end of the string. So we need
+ * to check for special globbing characters in the current pattern.
+ */
+
+ savedChar = *p;
+ *p = '\0';
+
+ if (strpbrk(tail, "*[]?\\") != NULL) {
+ *p = savedChar;
+ /*
+ * Look for matching files in the current directory. The
+ * implementation of this function is platform specific, but may
+ * recursively call TclDoGlob. For each file that matches, it will
+ * add the match onto the interp->result, or call TclDoGlob if there
+ * are more characters to be processed.
+ */
+
+ return TclMatchFiles(interp, separators, headPtr, tail, p);
+ }
+ *p = savedChar;
+ Tcl_DStringAppend(headPtr, tail, p-tail);
+ if (*p != '\0') {
+ return TclDoGlob(interp, separators, headPtr, p);
+ }
+
+ /*
+ * There are no more wildcards in the pattern and no more unprocessed
+ * characters in the tail, so now we can construct the path and verify
+ * the existence of the file.
+ */
+
+ switch (tclPlatform) {
+ case TCL_PLATFORM_MAC:
+ if (strchr(Tcl_DStringValue(headPtr), ':') == NULL) {
+ Tcl_DStringAppend(headPtr, ":", 1);
+ }
+ name = Tcl_DStringValue(headPtr);
+ if (access(name, F_OK) == 0) {
+ if ((name[1] != '\0') && (strchr(name+1, ':') == NULL)) {
+ Tcl_AppendElement(interp, name+1);
+ } else {
+ Tcl_AppendElement(interp, name);
+ }
+ }
+ break;
+ case TCL_PLATFORM_WINDOWS: {
+ int exists;
+ /*
+ * We need to convert slashes to backslashes before checking
+ * for the existence of the file. Once we are done, we need
+ * to convert the slashes back.
+ */
+
+ if (Tcl_DStringLength(headPtr) == 0) {
+ if (((*name == '\\') && (name[1] == '/' || name[1] == '\\'))
+ || (*name == '/')) {
+ Tcl_DStringAppend(headPtr, "\\", 1);
+ } else {
+ Tcl_DStringAppend(headPtr, ".", 1);
+ }
+ } else {
+ for (p = Tcl_DStringValue(headPtr); *p != '\0'; p++) {
+ if (*p == '/') {
+ *p = '\\';
+ }
+ }
+ }
+ name = Tcl_DStringValue(headPtr);
+ exists = (access(name, F_OK) == 0);
+ for (p = name; *p != '\0'; p++) {
+ if (*p == '\\') {
+ *p = '/';
+ }
+ }
+ if (exists) {
+ Tcl_AppendElement(interp, name);
+ }
+ break;
+ }
+ case TCL_PLATFORM_UNIX:
+ if (Tcl_DStringLength(headPtr) == 0) {
+ if ((*name == '\\' && name[1] == '/') || (*name == '/')) {
+ Tcl_DStringAppend(headPtr, "/", 1);
+ } else {
+ Tcl_DStringAppend(headPtr, ".", 1);
+ }
+ }
+ name = Tcl_DStringValue(headPtr);
+ if (access(name, F_OK) == 0) {
+ Tcl_AppendElement(interp, name);
+ }
+ break;
+ }
+
+ return TCL_OK;
+}
diff --git a/contrib/tcl/generic/tclGet.c b/contrib/tcl/generic/tclGet.c
new file mode 100644
index 000000000000..9e208b962b04
--- /dev/null
+++ b/contrib/tcl/generic/tclGet.c
@@ -0,0 +1,232 @@
+/*
+ * 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.
+ *
+ * SCCS: @(#) tclGet.c 1.24 96/02/15 11:42:47
+ */
+
+#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 = -(int)strtoul(p, &end, 0);
+ } else if (*p == '+') {
+ p++;
+ i = strtoul(p, &end, 0);
+ } else {
+ i = strtoul(p, &end, 0);
+ }
+ if (end == p) {
+ badInteger:
+ if (interp != (Tcl_Interp *) NULL) {
+ Tcl_AppendResult(interp, "expected integer but got \"", string,
+ "\"", (char *) NULL);
+ }
+ return TCL_ERROR;
+ }
+ if (errno == ERANGE) {
+ if (interp != (Tcl_Interp *) NULL) {
+ 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:
+ if (interp != (Tcl_Interp *) NULL) {
+ Tcl_AppendResult(interp,
+ "expected floating-point number but got \"",
+ string, "\"", (char *) NULL);
+ }
+ return TCL_ERROR;
+ }
+ if (errno != 0) {
+ if (interp != (Tcl_Interp *) NULL) {
+ 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;
+ char lowerCase[10], c;
+ 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 += (char) ('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:
+ if (interp != (Tcl_Interp *) NULL) {
+ Tcl_AppendResult(interp, "expected boolean value but got \"",
+ string, "\"", (char *) NULL);
+ }
+ return TCL_ERROR;
+ }
+ return TCL_OK;
+}
diff --git a/contrib/tcl/generic/tclGetDate.y b/contrib/tcl/generic/tclGetDate.y
new file mode 100644
index 000000000000..89a678e168e6
--- /dev/null
+++ b/contrib/tcl/generic/tclGetDate.y
@@ -0,0 +1,937 @@
+/*
+ * tclGetdate.y --
+ *
+ * Contains yacc grammar for parsing date and time strings
+ * based on getdate.y.
+ *
+ * Copyright (c) 1992-1995 Karl Lehenbauer and Mark Diekhans.
+ * Copyright (c) 1995-1996 Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * SCCS: @(#) tclGetDate.y 1.25 96/02/15 20:04:06
+ */
+
+%{
+/*
+ * tclGetdate.c --
+ *
+ * This file is generated from a yacc grammar defined in
+ * the file tclGetdate.y
+ *
+ * Copyright (c) 1992-1995 Karl Lehenbauer and Mark Diekhans.
+ * Copyright (c) 1995-1996 Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * SCCSID
+ */
+
+#include "tclInt.h"
+#include "tclPort.h"
+
+#ifdef MAC_TCL
+# define EPOCH 1904
+# define START_OF_TIME 1904
+# define END_OF_TIME 2039
+#else
+# define EPOCH 1970
+# define START_OF_TIME 1902
+# define END_OF_TIME 2037
+
+extern struct tm *localtime();
+#endif
+
+#define HOUR(x) ((int) (60 * x))
+#define SECSPERDAY (24L * 60L * 60L)
+
+
+/*
+ * An entry in the lexical lookup table.
+ */
+typedef struct _TABLE {
+ char *name;
+ int type;
+ time_t value;
+} TABLE;
+
+
+/*
+ * Daylight-savings mode: on, off, or not yet known.
+ */
+typedef enum _DSTMODE {
+ DSTon, DSToff, DSTmaybe
+} DSTMODE;
+
+/*
+ * Meridian: am, pm, or 24-hour style.
+ */
+typedef enum _MERIDIAN {
+ MERam, MERpm, MER24
+} MERIDIAN;
+
+
+/*
+ * Global variables. We could get rid of most of these by using a good
+ * union as the yacc stack. (This routine was originally written before
+ * yacc had the %union construct.) Maybe someday; right now we only use
+ * the %union very rarely.
+ */
+static char *yyInput;
+static DSTMODE yyDSTmode;
+static time_t yyDayOrdinal;
+static time_t yyDayNumber;
+static int yyHaveDate;
+static int yyHaveDay;
+static int yyHaveRel;
+static int yyHaveTime;
+static int yyHaveZone;
+static time_t yyTimezone;
+static time_t yyDay;
+static time_t yyHour;
+static time_t yyMinutes;
+static time_t yyMonth;
+static time_t yySeconds;
+static time_t yyYear;
+static MERIDIAN yyMeridian;
+static time_t yyRelMonth;
+static time_t yyRelSeconds;
+
+
+/*
+ * Prototypes of internal functions.
+ */
+static void
+yyerror _ANSI_ARGS_((char *s));
+
+static time_t
+ToSeconds _ANSI_ARGS_((time_t Hours,
+ time_t Minutes,
+ time_t Seconds,
+ MERIDIAN Meridian));
+
+static int
+Convert _ANSI_ARGS_((time_t Month,
+ time_t Day,
+ time_t Year,
+ time_t Hours,
+ time_t Minutes,
+ time_t Seconds,
+ MERIDIAN Meridia,
+ DSTMODE DSTmode,
+ time_t *TimePtr));
+
+static time_t
+DSTcorrect _ANSI_ARGS_((time_t Start,
+ time_t Future));
+
+static time_t
+RelativeDate _ANSI_ARGS_((time_t Start,
+ time_t DayOrdinal,
+ time_t DayNumber));
+
+static int
+RelativeMonth _ANSI_ARGS_((time_t Start,
+ time_t RelMonth,
+ time_t *TimePtr));
+static int
+LookupWord _ANSI_ARGS_((char *buff));
+
+static int
+yylex _ANSI_ARGS_((void));
+
+int
+yyparse _ANSI_ARGS_((void));
+%}
+
+%union {
+ time_t Number;
+ enum _MERIDIAN Meridian;
+}
+
+%token tAGO tDAY tDAYZONE tID tMERIDIAN tMINUTE_UNIT tMONTH tMONTH_UNIT
+%token tSEC_UNIT tSNUMBER tUNUMBER tZONE tEPOCH tDST
+
+%type <Number> tDAY tDAYZONE tMINUTE_UNIT tMONTH tMONTH_UNIT tDST
+%type <Number> tSEC_UNIT tSNUMBER tUNUMBER tZONE
+%type <Meridian> tMERIDIAN o_merid
+
+%%
+
+spec : /* NULL */
+ | spec item
+ ;
+
+item : time {
+ yyHaveTime++;
+ }
+ | zone {
+ yyHaveZone++;
+ }
+ | date {
+ yyHaveDate++;
+ }
+ | day {
+ yyHaveDay++;
+ }
+ | rel {
+ yyHaveRel++;
+ }
+ | number
+ ;
+
+time : tUNUMBER tMERIDIAN {
+ yyHour = $1;
+ yyMinutes = 0;
+ yySeconds = 0;
+ yyMeridian = $2;
+ }
+ | tUNUMBER ':' tUNUMBER o_merid {
+ yyHour = $1;
+ yyMinutes = $3;
+ yySeconds = 0;
+ yyMeridian = $4;
+ }
+ | tUNUMBER ':' tUNUMBER tSNUMBER {
+ yyHour = $1;
+ yyMinutes = $3;
+ yyMeridian = MER24;
+ yyDSTmode = DSToff;
+ yyTimezone = - ($4 % 100 + ($4 / 100) * 60);
+ }
+ | tUNUMBER ':' tUNUMBER ':' tUNUMBER o_merid {
+ yyHour = $1;
+ yyMinutes = $3;
+ yySeconds = $5;
+ yyMeridian = $6;
+ }
+ | tUNUMBER ':' tUNUMBER ':' tUNUMBER tSNUMBER {
+ yyHour = $1;
+ yyMinutes = $3;
+ yySeconds = $5;
+ yyMeridian = MER24;
+ yyDSTmode = DSToff;
+ yyTimezone = - ($6 % 100 + ($6 / 100) * 60);
+ }
+ ;
+
+zone : tZONE tDST {
+ yyTimezone = $1;
+ yyDSTmode = DSTon;
+ }
+ | tZONE {
+ yyTimezone = $1;
+ yyDSTmode = DSToff;
+ }
+ | tDAYZONE {
+ yyTimezone = $1;
+ yyDSTmode = DSTon;
+ }
+ ;
+
+day : tDAY {
+ yyDayOrdinal = 1;
+ yyDayNumber = $1;
+ }
+ | tDAY ',' {
+ yyDayOrdinal = 1;
+ yyDayNumber = $1;
+ }
+ | tUNUMBER tDAY {
+ yyDayOrdinal = $1;
+ yyDayNumber = $2;
+ }
+ ;
+
+date : tUNUMBER '/' tUNUMBER {
+ yyMonth = $1;
+ yyDay = $3;
+ }
+ | tUNUMBER '/' tUNUMBER '/' tUNUMBER {
+ yyMonth = $1;
+ yyDay = $3;
+ yyYear = $5;
+ }
+ | tMONTH tUNUMBER {
+ yyMonth = $1;
+ yyDay = $2;
+ }