diff options
Diffstat (limited to 'contrib/tcl/generic')
43 files changed, 46790 insertions, 0 deletions
diff --git a/contrib/tcl/generic/README b/contrib/tcl/generic/README new file mode 100644 index 0000000000000..4b3aa4fcf4cab --- /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 0000000000000..4ad98fd06573d --- /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 0000000000000..2482cd3ed8820 --- /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 0000000000000..52e5a51e2d52a --- /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; ®dummy = don't. */ + long regsize; /* Code size. */ +}; + +static char regdummy; + +/* + * The first byte of the regexp internal "program" is actually this magic + * number; the start node begins in the second byte. + */ +#define MAGIC 0234 + + +/* + * Forward declarations for TclRegComp()'s friends. + */ + +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 = ®dummy; + regc(MAGIC, rcstate); + if (reg(0, &flags, rcstate) == NULL) + return(NULL); + + /* Small enough for pointer-storage convention? */ + if (rcstate->regsize >= 32767L) /* Probably could be 65535L. */ + FAIL("regexp too big"); + + /* Allocate space. */ + r = (regexp *)ckalloc(sizeof(regexp) + (unsigned)rcstate->regsize); + if (r == NULL) + FAIL("out of space"); + + /* Second pass: emit code. */ + rcstate->regparse = exp; + rcstate->regnpar = 1; + rcstate->regcode = r->program; + regc(MAGIC, rcstate); + if (reg(0, &flags, rcstate) == NULL) + return(NULL); + + /* Dig out information for optimizations. */ + r->regstart = '\0'; /* Worst-case defaults. */ + r->reganch = 0; + r->regmust = NULL; + r->regmlen = 0; + scan = r->program+1; /* First BRANCH. */ + if (OP(regnext(scan)) == END) { /* Only one top-level choice. */ + scan = OPERAND(scan); + + /* Starting-point info. */ + if (OP(scan) == EXACTLY) + r->regstart = *OPERAND(scan); + else if (OP(scan) == BOL) + r->reganch++; + + /* + * If there's something expensive in the r.e., find the + * longest literal string that must appear and make it the + * regmust. Resolve ties in favor of later strings, since + * the regstart check works with the beginning of the r.e. + * and avoiding duplication strengthens checking. Not a + * strong reason, but sufficient in the absence of others. + */ + if (flags&SPSTART) { + longest = NULL; + len = 0; + for (; scan != NULL; scan = regnext(scan)) + if (OP(scan) == EXACTLY && ((int) strlen(OPERAND(scan))) >= len) { + longest = OPERAND(scan); + len = strlen(OPERAND(scan)); + } + r->regmust = longest; + r->regmlen = len; + } + } + + return(r); +} + +/* + - reg - regular expression, i.e. main body or parenthesized thing + * + * Caller must absorb opening parenthesis. + * + * Combining parenthesis handling with the base level of regular expression + * is a trifle forced, but the need to tie the tails of the branches to what + * follows makes it hard to avoid. + */ +static char * +reg(paren, flagp, rcstate) +int paren; /* Parenthesized? */ +int *flagp; +struct regcomp_state *rcstate; +{ + register char *ret; + register char *br; + register char *ender; + register int parno = 0; + int flags; + + *flagp = HASWIDTH; /* Tentatively. */ + + /* Make an OPEN node, if parenthesized. */ + if (paren) { + if (rcstate->regnpar >= NSUBEXP) + FAIL("too many ()"); + parno = rcstate->regnpar; + rcstate->regnpar++; + ret = regnode(OPEN+parno,rcstate); + } else + ret = NULL; + + /* Pick up the branches, linking them together. */ + br = regbranch(&flags,rcstate); + if (br == NULL) + return(NULL); + if (ret != NULL) + regtail(ret, br); /* OPEN -> first. */ + else + ret = br; + if (!(flags&HASWIDTH)) + *flagp &= ~HASWIDTH; + *flagp |= flags&SPSTART; + while (*rcstate->regparse == '|') { + rcstate->regparse++; + br = regbranch(&flags,rcstate); + if (br == NULL) + return(NULL); + regtail(ret, br); /* BRANCH -> BRANCH. */ + if (!(flags&HASWIDTH)) + *flagp &= ~HASWIDTH; + *flagp |= flags&SPSTART; + } + + /* Make a closing node, and hook it on the end. */ + ender = regnode((paren) ? CLOSE+parno : END,rcstate); + regtail(ret, ender); + + /* Hook the tails of the branches to the closing node. */ + for (br = ret; br != NULL; br = regnext(br)) + regoptail(br, ender); + + /* Check for proper termination. */ + if (paren && *rcstate->regparse++ != ')') { + FAIL("unmatched ()"); + } else if (!paren && *rcstate->regparse != '\0') { + if (*rcstate->regparse == ')') { + FAIL("unmatched ()"); + } else + FAIL("junk on end"); /* "Can't happen". */ + /* NOTREACHED */ + } + + return(ret); +} + +/* + - regbranch - one alternative of an | operator + * + * Implements the concatenation operator. + */ +static char * +regbranch(flagp, rcstate) +int *flagp; +struct regcomp_state *rcstate; +{ + register char *ret; + register char *chain; + register char *latest; + int flags; + + *flagp = WORST; /* Tentatively. */ + + ret = regnode(BRANCH,rcstate); + chain = NULL; + while (*rcstate->regparse != '\0' && *rcstate->regparse != '|' && + *rcstate->regparse != ')') { + latest = regpiece(&flags, rcstate); + if (latest == NULL) + return(NULL); + *flagp |= flags&HASWIDTH; + if (chain == NULL) /* First piece. */ + *flagp |= flags&SPSTART; + else + regtail(chain, latest); + chain = latest; + } + if (chain == NULL) /* Loop ran zero times. */ + (void) regnode(NOTHING,rcstate); + + return(ret); +} + +/* + - regpiece - something followed by possible [*+?] + * + * Note that the branching code sequences used for ? and the general cases + * of * and + are somewhat optimized: they use the same NOTHING node as + * both the endmarker for their branch list and the body of the last branch. + * It might seem that this node could be dispensed with entirely, but the + * endmarker role is not redundant. + */ +static char * +regpiece(flagp, rcstate) +int *flagp; +struct regcomp_state *rcstate; +{ + register char *ret; + register char op; + register char *next; + int flags; + + ret = regatom(&flags,rcstate); + if (ret == NULL) + return(NULL); + + op = *rcstate->regparse; + if (!ISMULT(op)) { + *flagp = flags; + return(ret); + } + + if (!(flags&HASWIDTH) && op != '?') + FAIL("*+ operand could be empty"); + *flagp = (op != '+') ? (WORST|SPSTART) : (WORST|HASWIDTH); + + if (op == '*' && (flags&SIMPLE)) + reginsert(STAR, ret, rcstate); + else if (op == '*') { + /* Emit x* as (x&|), where & means "self". */ + reginsert(BRANCH, ret, rcstate); /* Either x */ + regoptail(ret, regnode(BACK,rcstate)); /* and loop */ + regoptail(ret, ret); /* back */ + regtail(ret, regnode(BRANCH,rcstate)); /* or */ + regtail(ret, regnode(NOTHING,rcstate)); /* null. */ + } else if (op == '+' && (flags&SIMPLE)) + reginsert(PLUS, ret, rcstate); + else if (op == '+') { + /* Emit x+ as x(&|), where & means "self". */ + next = regnode(BRANCH,rcstate); /* Either */ + regtail(ret, next); + regtail(regnode(BACK,rcstate), ret); /* loop back */ + regtail(next, regnode(BRANCH,rcstate)); /* or */ + regtail(ret, regnode(NOTHING,rcstate)); /* null. */ + } else if (op == '?') { + /* Emit x? as (x|) */ + reginsert(BRANCH, ret, rcstate); /* Either x */ + regtail(ret, regnode(BRANCH,rcstate)); /* or */ + next = regnode(NOTHING,rcstate); /* null. */ + regtail(ret, next); + regoptail(ret, next); + } + rcstate->regparse++; + if (ISMULT(*rcstate->regparse)) + FAIL("nested *?+"); + + return(ret); +} + +/* + - regatom - the lowest level + * + * Optimization: gobbles an entire sequence of ordinary characters so that + * it can turn them into a single node, which is smaller to store and + * faster to run. Backslashed characters are exceptions, each becoming a + * separate node; the code is simpler that way and it's not worth fixing. + */ +static char * +regatom(flagp, rcstate) +int *flagp; +struct regcomp_state *rcstate; +{ + register char *ret; + int flags; + + *flagp = WORST; /* Tentatively. */ + + switch (*rcstate->regparse++) { + case '^': + ret = regnode(BOL,rcstate); + break; + case '$': + ret = regnode(EOL,rcstate); + break; + case '.': + ret = regnode(ANY,rcstate); + *flagp |= HASWIDTH|SIMPLE; + break; + case '[': { + register int clss; + register int classend; + + if (*rcstate->regparse == '^') { /* Complement of range. */ + ret = regnode(ANYBUT,rcstate); + rcstate->regparse++; + } else + ret = regnode(ANYOF,rcstate); + if (*rcstate->regparse == ']' || *rcstate->regparse == '-') + regc(*rcstate->regparse++,rcstate); + while (*rcstate->regparse != '\0' && *rcstate->regparse != ']') { + if (*rcstate->regparse == '-') { + rcstate->regparse++; + if (*rcstate->regparse == ']' || *rcstate->regparse == '\0') + regc('-',rcstate); + else { + clss = UCHARAT(rcstate->regparse-2)+1; + classend = UCHARAT(rcstate->regparse); + if (clss > classend+1) + FAIL("invalid [] range"); + for (; clss <= classend; clss++) + regc((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 == ®dummy) { + 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 != ®dummy) + *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 == ®dummy) { + rcstate->regsize += 3; + return; + } + + src = rcstate->regcode; + rcstate->regcode += 3; + dst = rcstate->regcode; + while (src > opnd) + *--dst = *--src; + + place = opnd; /* Op node, where operand used to be. */ + *place++ = (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 == ®dummy) + return; + + /* Find last node. */ + scan = p; + for (;;) { + temp = regnext(scan); + if (temp == NULL) + break; + scan = temp; + } + + if (OP(scan) == BACK) + offset = scan - val; + else + offset = val - scan; + *(scan+1) = (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 == ®dummy || OP(p) != BRANCH) + return; + regtail(OPERAND(p), val); +} + +/* + * TclRegExec and friends + */ + +/* + * Global work variables for TclRegExec(). + */ +struct regexec_state { + char *reginput; /* String-input pointer. */ + char *regbol; /* Beginning of input, for ^ check. */ + char **regstartp; /* Pointer to startp array. */ + char **regendp; /* Ditto for endp. */ +}; + +/* + * Forwards. + */ +static int regtry _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 == ®dummy) + return(NULL); + + offset = NEXT(p); + if (offset == 0) + return(NULL); + + if (OP(p) == BACK) + return(p-offset); + else + return(p+offset); +} + +#ifdef DEBUG + +static char *regprop(); + +/* + - regdump - dump a regexp onto stdout in vaguely comprehensible form + */ +void +regdump(r) +regexp *r; +{ + register char *s; + register char op = EXACTLY; /* Arbitrary non-END op. */ + register char *next; + + + s = r->program + 1; + while (op != END) { /* While that wasn't END last time... */ + op = OP(s); + printf("%2d%s", s-r->program, regprop(s)); /* Where, what. */ + next = regnext(s); + if (next == NULL) /* Next ptr. */ + printf("(0)"); + else + printf("(%d)", (s-r->program)+(next-s)); + s += 3; + if (op == ANYOF || op == ANYBUT || op == EXACTLY) { + /* Literal string, where present. */ + while (*s != '\0') { + putchar(*s); + s++; + } + s++; + } + putchar('\n'); + } + + /* Header fields of interest. */ + if (r->regstart != '\0') + printf("start `%c' ", r->regstart); + if (r->reganch) + printf("anchored "); + if (r->regmust != NULL) + printf("must have \"%s\"", r->regmust); + printf("\n"); +} + +/* + - regprop - printable representation of opcode + */ +static char * +regprop(op) +char *op; +{ + register char *p; + static char buf[50]; + + (void) strcpy(buf, ":"); + + switch (OP(op)) { + case BOL: + p = "BOL"; + break; + case EOL: + p = "EOL"; + break; + case ANY: + p = "ANY"; + break; + case ANYOF: + p = "ANYOF"; + break; + case ANYBUT: + p = "ANYBUT"; + break; + case BRANCH: + p = "BRANCH"; + break; + case EXACTLY: + p = "EXACTLY"; + break; + case NOTHING: + p = "NOTHING"; + break; + case BACK: + p = "BACK"; + break; + case END: + p = "END"; + break; + case OPEN+1: + case OPEN+2: + case OPEN+3: + case OPEN+4: + case OPEN+5: + case OPEN+6: + case OPEN+7: + case OPEN+8: + case OPEN+9: + sprintf(buf+strlen(buf), "OPEN%d", OP(op)-OPEN); + p = NULL; + break; + case CLOSE+1: + case CLOSE+2: + case CLOSE+3: + case CLOSE+4: + case CLOSE+5: + case CLOSE+6: + case CLOSE+7: + case CLOSE+8: + case CLOSE+9: + sprintf(buf+strlen(buf), "CLOSE%d", OP(op)-CLOSE); + p = NULL; + break; + case STAR: + p = "STAR"; + break; + case PLUS: + p = "PLUS"; + break; + default: + 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 0000000000000..b37665f946888 --- /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 0000000000000..905b664a1587e --- /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 0000000000000..e081402186c95 --- /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 0000000000000..e8f3b37ff4260 --- /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 0000000000000..3fb4abdd45045 --- /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 0000000000000..526a11181ac73 --- /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 0000000000000..9998e19a97ee7 --- /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 0000000000000..faf9eed47b650 --- /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 0000000000000..b39d817e9eaa9 --- /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 0000000000000..4b92cc29c55a5 --- /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 0000000000000..3c9f7d249ef11 --- /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 0000000000000..13d020fa49c2f --- /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 0000000000000..19875c5c47733 --- /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 0000000000000..90beb116d1167 --- /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 0000000000000..9e208b962b043 --- /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 0000000000000..89a678e168e60 --- /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; + } + | tMONTH tUNUMBER ',' tUNUMBER { + yyMonth = $1; + yyDay = $2; + yyYear = $4; + } + | tUNUMBER tMONTH { + yyMonth = $2; + yyDay = $1; + } + | tEPOCH { + yyMonth = 1; + yyDay = 1; + yyYear = EPOCH; + } + | tUNUMBER tMONTH tUNUMBER { + yyMonth = $2; + yyDay = $1; + yyYear = $3; + } + ; + +rel : relunit tAGO { + yyRelSeconds = -yyRelSeconds; + yyRelMonth = -yyRelMonth; + } + | relunit + ; + +relunit : tUNUMBER tMINUTE_UNIT { + yyRelSeconds += $1 * $2 * 60L; + } + | tSNUMBER tMINUTE_UNIT { + yyRelSeconds += $1 * $2 * 60L; + } + | tMINUTE_UNIT { + yyRelSeconds += $1 * 60L; + } + | tSNUMBER tSEC_UNIT { + yyRelSeconds += $1; + } + | tUNUMBER tSEC_UNIT { + yyRelSeconds += $1; + } + | tSEC_UNIT { + yyRelSeconds++; + } + | tSNUMBER tMONTH_UNIT { + yyRelMonth += $1 * $2; + } + | tUNUMBER tMONTH_UNIT { + yyRelMonth += $1 * $2; + } + | tMONTH_UNIT { + yyRelMonth += $1; + } + ; + +number : tUNUMBER { + if (yyHaveTime && yyHaveDate && !yyHaveRel) + yyYear = $1; + else { + yyHaveTime++; + if ($1 < 100) { + yyHour = $1; + yyMinutes = 0; + } + else { + yyHour = $1 / 100; + yyMinutes = $1 % 100; + } + yySeconds = 0; + yyMeridian = MER24; + } + } + ; + +o_merid : /* NULL */ { + $$ = MER24; + } + | tMERIDIAN { + $$ = $1; + } + ; + +%% + +/* + * 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 +yyerror(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 += yyTimezone * 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) { + yylval.Meridian = MERam; + return tMERIDIAN; + } + if (strcmp(buff, "pm") == 0 || strcmp(buff, "p.m.") == 0) { + yylval.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) { + yylval.Number = tp->value; + return tp->type; + } + } else if (strcmp(buff, tp->name) == 0) { + yylval.Number = tp->value; + return tp->type; + } + } + + for (tp = TimezoneTable; tp->name; tp++) { + if (strcmp(buff, tp->name) == 0) { + yylval.Number = tp->value; + return tp->type; + } + } + + for (tp = UnitsTable; tp->name; tp++) { + if (strcmp(buff, tp->name) == 0) { + yylval.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) { + yylval.Number = tp->value; + return tp->type; + } + } + } + + for (tp = OtherTable; tp->name; tp++) { + if (strcmp(buff, tp->name) == 0) { + yylval.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) { + yylval.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) { + yylval.Number = tp->value; + return tp->type; + } + } + + return tID; +} + + +static int +yylex() +{ + register char c; + register char *p; + char buff[20]; + int Count; + int sign; + + for ( ; ; ) { + while (isspace((unsigned char) (*yyInput))) { + yyInput++; + } + + if (isdigit(c = *yyInput) || c == '-' || c == '+') { + if (c == '-' || c == '+') { + sign = c == '-' ? -1 : 1; + if (!isdigit(*++yyInput)) { + /* + * skip the '-' sign + */ + continue; + } + } else { + sign = 0; + } + for (yylval.Number = 0; isdigit(c = *yyInput++); ) { + yylval.Number = 10 * yylval.Number + c - '0'; + } + yyInput--; + if (sign < 0) { + yylval.Number = -yylval.Number; + } + return sign ? tSNUMBER : tUNUMBER; + } + if (isalpha(c)) { + for (p = buff; isalpha(c = *yyInput++) || c == '.'; ) { + if (p < &buff[sizeof buff - 1]) { + *p++ = c; + } + } + *p = '\0'; + yyInput--; + return LookupWord(buff); + } + if (c != '(') { + return *yyInput++; + } + Count = 0; + do { + c = *yyInput++; + 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; + + yyInput = p; + tm = localtime((time_t *) &now); + yyYear = tm->tm_year; + yyMonth = tm->tm_mon + 1; + yyDay = tm->tm_mday; + yyTimezone = zone; + if (zone == -50000) { + yyDSTmode = DSToff; /* assume GMT */ + yyTimezone = 0; + } else { + yyDSTmode = DSTmaybe; + } + yyHour = 0; + yyMinutes = 0; + yySeconds = 0; + yyMeridian = MER24; + yyRelSeconds = 0; + yyRelMonth = 0; + yyHaveDate = 0; + yyHaveDay = 0; + yyHaveRel = 0; + yyHaveTime = 0; + yyHaveZone = 0; + + if (yyparse() || yyHaveTime > 1 || yyHaveZone > 1 || yyHaveDate > 1 || + yyHaveDay > 1) { + return -1; + } + + if (yyHaveDate || yyHaveTime || yyHaveDay) { + if (Convert(yyMonth, yyDay, yyYear, yyHour, yyMinutes, yySeconds, + yyMeridian, yyDSTmode, &Start) < 0) + return -1; + } + else { + Start = now; + if (!yyHaveRel) + Start -= ((tm->tm_hour * 60L) + tm->tm_min * 60L) + tm->tm_sec; + } + + Start += yyRelSeconds; + if (RelativeMonth(Start, yyRelMonth, &Time) < 0) { + return -1; + } + Start += Time; + + if (yyHaveDay && !yyHaveDate) { + tod = RelativeDate(Start, yyDayOrdinal, yyDayNumber); + Start += tod; + } + + *timePtr = Start; + return 0; +} diff --git a/contrib/tcl/generic/tclHash.c b/contrib/tcl/generic/tclHash.c new file mode 100644 index 0000000000000..41de0b258bb73 --- /dev/null +++ b/contrib/tcl/generic/tclHash.c @@ -0,0 +1,921 @@ +/* + * tclHash.c -- + * + * Implementation of in-memory hash tables for Tcl and Tcl-based + * applications. + * + * Copyright (c) 1991-1993 The Regents of the University of California. + * Copyright (c) 1994 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclHash.c 1.15 96/02/15 11:50:23 + */ + +#include "tclInt.h" + +/* + * When there are this many entries per bucket, on average, rebuild + * the hash table to make it larger. + */ + +#define REBUILD_MULTIPLIER 3 + + +/* + * The following macro takes a preliminary integer hash value and + * produces an index into a hash tables bucket list. The idea is + * to make it so that preliminary values that are arbitrarily similar + * will end up in different buckets. The hash function was taken + * from a random-number generator. + */ + +#define RANDOM_INDEX(tablePtr, i) \ + (((((long) (i))*1103515245) >> (tablePtr)->downShift) & (tablePtr)->mask) + +/* + * Procedure prototypes for static procedures in this file: + */ + +static Tcl_HashEntry * ArrayFind _ANSI_ARGS_((Tcl_HashTable *tablePtr, + char *key)); +static Tcl_HashEntry * ArrayCreate _ANSI_ARGS_((Tcl_HashTable *tablePtr, + char *key, int *newPtr)); +static Tcl_HashEntry * BogusFind _ANSI_ARGS_((Tcl_HashTable *tablePtr, + char *key)); +static Tcl_HashEntry * BogusCreate _ANSI_ARGS_((Tcl_HashTable *tablePtr, + char *key, int *newPtr)); +static unsigned int HashString _ANSI_ARGS_((char *string)); +static void RebuildTable _ANSI_ARGS_((Tcl_HashTable *tablePtr)); +static Tcl_HashEntry * StringFind _ANSI_ARGS_((Tcl_HashTable *tablePtr, + char *key)); +static Tcl_HashEntry * StringCreate _ANSI_ARGS_((Tcl_HashTable *tablePtr, + char *key, int *newPtr)); +static Tcl_HashEntry * OneWordFind _ANSI_ARGS_((Tcl_HashTable *tablePtr, + char *key)); +static Tcl_HashEntry * OneWordCreate _ANSI_ARGS_((Tcl_HashTable *tablePtr, + char *key, int *newPtr)); + +/* + *---------------------------------------------------------------------- + * + * Tcl_InitHashTable -- + * + * Given storage for a hash table, set up the fields to prepare + * the hash table for use. + * + * Results: + * None. + * + * Side effects: + * TablePtr is now ready to be passed to Tcl_FindHashEntry and + * Tcl_CreateHashEntry. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_InitHashTable(tablePtr, keyType) + register Tcl_HashTable *tablePtr; /* Pointer to table record, which + * is supplied by the caller. */ + int keyType; /* Type of keys to use in table: + * TCL_STRING_KEYS, TCL_ONE_WORD_KEYS, + * or an integer >= 2. */ +{ + tablePtr->buckets = tablePtr->staticBuckets; + tablePtr->staticBuckets[0] = tablePtr->staticBuckets[1] = 0; + tablePtr->staticBuckets[2] = tablePtr->staticBuckets[3] = 0; + tablePtr->numBuckets = TCL_SMALL_HASH_TABLE; + tablePtr->numEntries = 0; + tablePtr->rebuildSize = TCL_SMALL_HASH_TABLE*REBUILD_MULTIPLIER; + tablePtr->downShift = 28; + tablePtr->mask = 3; + tablePtr->keyType = keyType; + if (keyType == TCL_STRING_KEYS) { + tablePtr->findProc = StringFind; + tablePtr->createProc = StringCreate; + } else if (keyType == TCL_ONE_WORD_KEYS) { + tablePtr->findProc = OneWordFind; + tablePtr->createProc = OneWordCreate; + } else { + tablePtr->findProc = ArrayFind; + tablePtr->createProc = ArrayCreate; + }; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DeleteHashEntry -- + * + * Remove a single entry from a hash table. + * + * Results: + * None. + * + * Side effects: + * The entry given by entryPtr is deleted from its table and + * should never again be used by the caller. It is up to the + * caller to free the clientData field of the entry, if that + * is relevant. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DeleteHashEntry(entryPtr) + Tcl_HashEntry *entryPtr; +{ + register Tcl_HashEntry *prevPtr; + + if (*entryPtr->bucketPtr == entryPtr) { + *entryPtr->bucketPtr = entryPtr->nextPtr; + } else { + for (prevPtr = *entryPtr->bucketPtr; ; prevPtr = prevPtr->nextPtr) { + if (prevPtr == NULL) { + panic("malformed bucket chain in Tcl_DeleteHashEntry"); + } + if (prevPtr->nextPtr == entryPtr) { + prevPtr->nextPtr = entryPtr->nextPtr; + break; + } + } + } + entryPtr->tablePtr->numEntries--; + ckfree((char *) entryPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DeleteHashTable -- + * + * Free up everything associated with a hash table except for + * the record for the table itself. + * + * Results: + * None. + * + * Side effects: + * The hash table is no longer useable. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DeleteHashTable(tablePtr) + register Tcl_HashTable *tablePtr; /* Table to delete. */ +{ + register Tcl_HashEntry *hPtr, *nextPtr; + int i; + + /* + * Free up all the entries in the table. + */ + + for (i = 0; i < tablePtr->numBuckets; i++) { + hPtr = tablePtr->buckets[i]; + while (hPtr != NULL) { + nextPtr = hPtr->nextPtr; + ckfree((char *) hPtr); + hPtr = nextPtr; + } + } + + /* + * Free up the bucket array, if it was dynamically allocated. + */ + + if (tablePtr->buckets != tablePtr->staticBuckets) { + ckfree((char *) tablePtr->buckets); + } + + /* + * Arrange for panics if the table is used again without + * re-initialization. + */ + + tablePtr->findProc = BogusFind; + tablePtr->createProc = BogusCreate; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FirstHashEntry -- + * + * Locate the first entry in a hash table and set up a record + * that can be used to step through all the remaining entries + * of the table. + * + * Results: + * The return value is a pointer to the first entry in tablePtr, + * or NULL if tablePtr has no entries in it. The memory at + * *searchPtr is initialized so that subsequent calls to + * Tcl_NextHashEntry will return all of the entries in the table, + * one at a time. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_HashEntry * +Tcl_FirstHashEntry(tablePtr, searchPtr) + Tcl_HashTable *tablePtr; /* Table to search. */ + Tcl_HashSearch *searchPtr; /* Place to store information about + * progress through the table. */ +{ + searchPtr->tablePtr = tablePtr; + searchPtr->nextIndex = 0; + searchPtr->nextEntryPtr = NULL; + return Tcl_NextHashEntry(searchPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_NextHashEntry -- + * + * Once a hash table enumeration has been initiated by calling + * Tcl_FirstHashEntry, this procedure may be called to return + * successive elements of the table. + * + * Results: + * The return value is the next entry in the hash table being + * enumerated, or NULL if the end of the table is reached. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_HashEntry * +Tcl_NextHashEntry(searchPtr) + register Tcl_HashSearch *searchPtr; /* Place to store information about + * progress through the table. Must + * have been initialized by calling + * Tcl_FirstHashEntry. */ +{ + Tcl_HashEntry *hPtr; + + while (searchPtr->nextEntryPtr == NULL) { + if (searchPtr->nextIndex >= searchPtr->tablePtr->numBuckets) { + return NULL; + } + searchPtr->nextEntryPtr = + searchPtr->tablePtr->buckets[searchPtr->nextIndex]; + searchPtr->nextIndex++; + } + hPtr = searchPtr->nextEntryPtr; + searchPtr->nextEntryPtr = hPtr->nextPtr; + return hPtr; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_HashStats -- + * + * Return statistics describing the layout of the hash table + * in its hash buckets. + * + * Results: + * The return value is a malloc-ed string containing information + * about tablePtr. It is the caller's responsibility to free + * this string. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_HashStats(tablePtr) + Tcl_HashTable *tablePtr; /* Table for which to produce stats. */ +{ +#define NUM_COUNTERS 10 + int count[NUM_COUNTERS], overflow, i, j; + double average, tmp; + register Tcl_HashEntry *hPtr; + char *result, *p; + + /* + * Compute a histogram of bucket usage. + */ + + for (i = 0; i < NUM_COUNTERS; i++) { + count[i] = 0; + } + overflow = 0; + average = 0.0; + for (i = 0; i < tablePtr->numBuckets; i++) { + j = 0; + for (hPtr = tablePtr->buckets[i]; hPtr != NULL; hPtr = hPtr->nextPtr) { + j++; + } + if (j < NUM_COUNTERS) { + count[j]++; + } else { + overflow++; + } + tmp = j; + average += (tmp+1.0)*(tmp/tablePtr->numEntries)/2.0; + } + + /* + * Print out the histogram and a few other pieces of information. + */ + + result = (char *) ckalloc((unsigned) ((NUM_COUNTERS*60) + 300)); + sprintf(result, "%d entries in table, %d buckets\n", + tablePtr->numEntries, tablePtr->numBuckets); + p = result + strlen(result); + for (i = 0; i < NUM_COUNTERS; i++) { + sprintf(p, "number of buckets with %d entries: %d\n", + i, count[i]); + p += strlen(p); + } + sprintf(p, "number of buckets with %d or more entries: %d\n", + NUM_COUNTERS, overflow); + p += strlen(p); + sprintf(p, "average search distance for entry: %.1f", average); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * HashString -- + * + * Compute a one-word summary of a text string, which can be + * used to generate a hash index. + * + * Results: + * The return value is a one-word summary of the information in + * string. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static unsigned int +HashString(string) + register char *string; /* String from which to compute hash value. */ +{ + register unsigned int result; + register int c; + + /* + * I tried a zillion different hash functions and asked many other + * people for advice. Many people had their own favorite functions, + * all different, but no-one had much idea why they were good ones. + * I chose the one below (multiply by 9 and add new character) + * because of the following reasons: + * + * 1. Multiplying by 10 is perfect for keys that are decimal strings, + * and multiplying by 9 is just about as good. + * 2. Times-9 is (shift-left-3) plus (old). This means that each + * character's bits hang around in the low-order bits of the + * hash value for ever, plus they spread fairly rapidly up to + * the high-order bits to fill out the hash value. This seems + * works well both for decimal and non-decimal strings. + */ + + result = 0; + while (1) { + c = *string; + string++; + if (c == 0) { + break; + } + result += (result<<3) + c; + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * StringFind -- + * + * Given a hash table with string keys, and a string key, find + * the entry with a matching key. + * + * Results: + * The return value is a token for the matching entry in the + * hash table, or NULL if there was no matching entry. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static Tcl_HashEntry * +StringFind(tablePtr, key) + Tcl_HashTable *tablePtr; /* Table in which to lookup entry. */ + char *key; /* Key to use to find matching entry. */ +{ + register Tcl_HashEntry *hPtr; + register char *p1, *p2; + int index; + + index = HashString(key) & tablePtr->mask; + + /* + * Search all of the entries in the appropriate bucket. + */ + + for (hPtr = tablePtr->buckets[index]; hPtr != NULL; + hPtr = hPtr->nextPtr) { + for (p1 = key, p2 = hPtr->key.string; ; p1++, p2++) { + if (*p1 != *p2) { + break; + } + if (*p1 == '\0') { + return hPtr; + } + } + } + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * StringCreate -- + * + * Given a hash table with string keys, and a string key, find + * the entry with a matching key. If there is no matching entry, + * then create a new entry that does match. + * + * Results: + * The return value is a pointer to the matching entry. If this + * is a newly-created entry, then *newPtr will be set to a non-zero + * value; otherwise *newPtr will be set to 0. If this is a new + * entry the value stored in the entry will initially be 0. + * + * Side effects: + * A new entry may be added to the hash table. + * + *---------------------------------------------------------------------- + */ + +static Tcl_HashEntry * +StringCreate(tablePtr, key, newPtr) + Tcl_HashTable *tablePtr; /* Table in which to lookup entry. */ + char *key; /* Key to use to find or create matching + * entry. */ + int *newPtr; /* Store info here telling whether a new + * entry was created. */ +{ + register Tcl_HashEntry *hPtr; + register char *p1, *p2; + int index; + + index = HashString(key) & tablePtr->mask; + + /* + * Search all of the entries in this bucket. + */ + + for (hPtr = tablePtr->buckets[index]; hPtr != NULL; + hPtr = hPtr->nextPtr) { + for (p1 = key, p2 = hPtr->key.string; ; p1++, p2++) { + if (*p1 != *p2) { + break; + } + if (*p1 == '\0') { + *newPtr = 0; + return hPtr; + } + } + } + + /* + * Entry not found. Add a new one to the bucket. + */ + + *newPtr = 1; + hPtr = (Tcl_HashEntry *) ckalloc((unsigned) + (sizeof(Tcl_HashEntry) + strlen(key) - (sizeof(hPtr->key) -1))); + hPtr->tablePtr = tablePtr; + hPtr->bucketPtr = &(tablePtr->buckets[index]); + hPtr->nextPtr = *hPtr->bucketPtr; + hPtr->clientData = 0; + strcpy(hPtr->key.string, key); + *hPtr->bucketPtr = hPtr; + tablePtr->numEntries++; + + /* + * If the table has exceeded a decent size, rebuild it with many + * more buckets. + */ + + if (tablePtr->numEntries >= tablePtr->rebuildSize) { + RebuildTable(tablePtr); + } + return hPtr; +} + +/* + *---------------------------------------------------------------------- + * + * OneWordFind -- + * + * Given a hash table with one-word keys, and a one-word key, find + * the entry with a matching key. + * + * Results: + * The return value is a token for the matching entry in the + * hash table, or NULL if there was no matching entry. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static Tcl_HashEntry * +OneWordFind(tablePtr, key) + Tcl_HashTable *tablePtr; /* Table in which to lookup entry. */ + register char *key; /* Key to use to find matching entry. */ +{ + register Tcl_HashEntry *hPtr; + int index; + + index = RANDOM_INDEX(tablePtr, key); + + /* + * Search all of the entries in the appropriate bucket. + */ + + for (hPtr = tablePtr->buckets[index]; hPtr != NULL; + hPtr = hPtr->nextPtr) { + if (hPtr->key.oneWordValue == key) { + return hPtr; + } + } + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * OneWordCreate -- + * + * Given a hash table with one-word keys, and a one-word key, find + * the entry with a matching key. If there is no matching entry, + * then create a new entry that does match. + * + * Results: + * The return value is a pointer to the matching entry. If this + * is a newly-created entry, then *newPtr will be set to a non-zero + * value; otherwise *newPtr will be set to 0. If this is a new + * entry the value stored in the entry will initially be 0. + * + * Side effects: + * A new entry may be added to the hash table. + * + *---------------------------------------------------------------------- + */ + +static Tcl_HashEntry * +OneWordCreate(tablePtr, key, newPtr) + Tcl_HashTable *tablePtr; /* Table in which to lookup entry. */ + register char *key; /* Key to use to find or create matching + * entry. */ + int *newPtr; /* Store info here telling whether a new + * entry was created. */ +{ + register Tcl_HashEntry *hPtr; + int index; + + index = RANDOM_INDEX(tablePtr, key); + + /* + * Search all of the entries in this bucket. + */ + + for (hPtr = tablePtr->buckets[index]; hPtr != NULL; + hPtr = hPtr->nextPtr) { + if (hPtr->key.oneWordValue == key) { + *newPtr = 0; + return hPtr; + } + } + + /* + * Entry not found. Add a new one to the bucket. + */ + + *newPtr = 1; + hPtr = (Tcl_HashEntry *) ckalloc(sizeof(Tcl_HashEntry)); + hPtr->tablePtr = tablePtr; + hPtr->bucketPtr = &(tablePtr->buckets[index]); + hPtr->nextPtr = *hPtr->bucketPtr; + hPtr->clientData = 0; + hPtr->key.oneWordValue = key; + *hPtr->bucketPtr = hPtr; + tablePtr->numEntries++; + + /* + * If the table has exceeded a decent size, rebuild it with many + * more buckets. + */ + + if (tablePtr->numEntries >= tablePtr->rebuildSize) { + RebuildTable(tablePtr); + } + return hPtr; +} + +/* + *---------------------------------------------------------------------- + * + * ArrayFind -- + * + * Given a hash table with array-of-int keys, and a key, find + * the entry with a matching key. + * + * Results: + * The return value is a token for the matching entry in the + * hash table, or NULL if there was no matching entry. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static Tcl_HashEntry * +ArrayFind(tablePtr, key) + Tcl_HashTable *tablePtr; /* Table in which to lookup entry. */ + char *key; /* Key to use to find matching entry. */ +{ + register Tcl_HashEntry *hPtr; + int *arrayPtr = (int *) key; + register int *iPtr1, *iPtr2; + int index, count; + + for (index = 0, count = tablePtr->keyType, iPtr1 = arrayPtr; + count > 0; count--, iPtr1++) { + index += *iPtr1; + } + index = RANDOM_INDEX(tablePtr, index); + + /* + * Search all of the entries in the appropriate bucket. + */ + + for (hPtr = tablePtr->buckets[index]; hPtr != NULL; + hPtr = hPtr->nextPtr) { + for (iPtr1 = arrayPtr, iPtr2 = hPtr->key.words, + count = tablePtr->keyType; ; count--, iPtr1++, iPtr2++) { + if (count == 0) { + return hPtr; + } + if (*iPtr1 != *iPtr2) { + break; + } + } + } + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * ArrayCreate -- + * + * Given a hash table with one-word keys, and a one-word key, find + * the entry with a matching key. If there is no matching entry, + * then create a new entry that does match. + * + * Results: + * The return value is a pointer to the matching entry. If this + * is a newly-created entry, then *newPtr will be set to a non-zero + * value; otherwise *newPtr will be set to 0. If this is a new + * entry the value stored in the entry will initially be 0. + * + * Side effects: + * A new entry may be added to the hash table. + * + *---------------------------------------------------------------------- + */ + +static Tcl_HashEntry * +ArrayCreate(tablePtr, key, newPtr) + Tcl_HashTable *tablePtr; /* Table in which to lookup entry. */ + register char *key; /* Key to use to find or create matching + * entry. */ + int *newPtr; /* Store info here telling whether a new + * entry was created. */ +{ + register Tcl_HashEntry *hPtr; + int *arrayPtr = (int *) key; + register int *iPtr1, *iPtr2; + int index, count; + + for (index = 0, count = tablePtr->keyType, iPtr1 = arrayPtr; + count > 0; count--, iPtr1++) { + index += *iPtr1; + } + index = RANDOM_INDEX(tablePtr, index); + + /* + * Search all of the entries in the appropriate bucket. + */ + + for (hPtr = tablePtr->buckets[index]; hPtr != NULL; + hPtr = hPtr->nextPtr) { + for (iPtr1 = arrayPtr, iPtr2 = hPtr->key.words, + count = tablePtr->keyType; ; count--, iPtr1++, iPtr2++) { + if (count == 0) { + *newPtr = 0; + return hPtr; + } + if (*iPtr1 != *iPtr2) { + break; + } + } + } + + /* + * Entry not found. Add a new one to the bucket. + */ + + *newPtr = 1; + hPtr = (Tcl_HashEntry *) ckalloc((unsigned) (sizeof(Tcl_HashEntry) + + (tablePtr->keyType*sizeof(int)) - 4)); + hPtr->tablePtr = tablePtr; + hPtr->bucketPtr = &(tablePtr->buckets[index]); + hPtr->nextPtr = *hPtr->bucketPtr; + hPtr->clientData = 0; + for (iPtr1 = arrayPtr, iPtr2 = hPtr->key.words, count = tablePtr->keyType; + count > 0; count--, iPtr1++, iPtr2++) { + *iPtr2 = *iPtr1; + } + *hPtr->bucketPtr = hPtr; + tablePtr->numEntries++; + + /* + * If the table has exceeded a decent size, rebuild it with many + * more buckets. + */ + + if (tablePtr->numEntries >= tablePtr->rebuildSize) { + RebuildTable(tablePtr); + } + return hPtr; +} + +/* + *---------------------------------------------------------------------- + * + * BogusFind -- + * + * This procedure is invoked when an Tcl_FindHashEntry is called + * on a table that has been deleted. + * + * Results: + * If panic returns (which it shouldn't) this procedure returns + * NULL. + * + * Side effects: + * Generates a panic. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static Tcl_HashEntry * +BogusFind(tablePtr, key) + Tcl_HashTable *tablePtr; /* Table in which to lookup entry. */ + char *key; /* Key to use to find matching entry. */ +{ + panic("called Tcl_FindHashEntry on deleted table"); + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * BogusCreate -- + * + * This procedure is invoked when an Tcl_CreateHashEntry is called + * on a table that has been deleted. + * + * Results: + * If panic returns (which it shouldn't) this procedure returns + * NULL. + * + * Side effects: + * Generates a panic. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static Tcl_HashEntry * +BogusCreate(tablePtr, key, newPtr) + Tcl_HashTable *tablePtr; /* Table in which to lookup entry. */ + char *key; /* Key to use to find or create matching + * entry. */ + int *newPtr; /* Store info here telling whether a new + * entry was created. */ +{ + panic("called Tcl_CreateHashEntry on deleted table"); + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * RebuildTable -- + * + * This procedure is invoked when the ratio of entries to hash + * buckets becomes too large. It creates a new table with a + * larger bucket array and moves all of the entries into the + * new table. + * + * Results: + * None. + * + * Side effects: + * Memory gets reallocated and entries get re-hashed to new + * buckets. + * + *---------------------------------------------------------------------- + */ + +static void +RebuildTable(tablePtr) + register Tcl_HashTable *tablePtr; /* Table to enlarge. */ +{ + int oldSize, count, index; + Tcl_HashEntry **oldBuckets; + register Tcl_HashEntry **oldChainPtr, **newChainPtr; + register Tcl_HashEntry *hPtr; + + oldSize = tablePtr->numBuckets; + oldBuckets = tablePtr->buckets; + + /* + * Allocate and initialize the new bucket array, and set up + * hashing constants for new array size. + */ + + tablePtr->numBuckets *= 4; + tablePtr->buckets = (Tcl_HashEntry **) ckalloc((unsigned) + (tablePtr->numBuckets * sizeof(Tcl_HashEntry *))); + for (count = tablePtr->numBuckets, newChainPtr = tablePtr->buckets; + count > 0; count--, newChainPtr++) { + *newChainPtr = NULL; + } + tablePtr->rebuildSize *= 4; + tablePtr->downShift -= 2; + tablePtr->mask = (tablePtr->mask << 2) + 3; + + /* + * Rehash all of the existing entries into the new bucket array. + */ + + for (oldChainPtr = oldBuckets; oldSize > 0; oldSize--, oldChainPtr++) { + for (hPtr = *oldChainPtr; hPtr != NULL; hPtr = *oldChainPtr) { + *oldChainPtr = hPtr->nextPtr; + if (tablePtr->keyType == TCL_STRING_KEYS) { + index = HashString(hPtr->key.string) & tablePtr->mask; + } else if (tablePtr->keyType == TCL_ONE_WORD_KEYS) { + index = RANDOM_INDEX(tablePtr, hPtr->key.oneWordValue); + } else { + register int *iPtr; + int count; + + for (index = 0, count = tablePtr->keyType, + iPtr = hPtr->key.words; count > 0; count--, iPtr++) { + index += *iPtr; + } + index = RANDOM_INDEX(tablePtr, index); + } + hPtr->bucketPtr = &(tablePtr->buckets[index]); + hPtr->nextPtr = *hPtr->bucketPtr; + *hPtr->bucketPtr = hPtr; + } + } + + /* + * Free up the old bucket array, if it was dynamically allocated. + */ + + if (oldBuckets != tablePtr->staticBuckets) { + ckfree((char *) oldBuckets); + } +} diff --git a/contrib/tcl/generic/tclHistory.c b/contrib/tcl/generic/tclHistory.c new file mode 100644 index 0000000000000..c0cfd1f26d569 --- /dev/null +++ b/contrib/tcl/generic/tclHistory.c @@ -0,0 +1,1096 @@ +/* + * tclHistory.c -- + * + * This module implements history as an optional addition to Tcl. + * It can be called to record commands ("events") before they are + * executed, and it provides a command that may be used to perform + * history substitutions. + * + * Copyright (c) 1990-1993 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclHistory.c 1.40 96/02/15 11:50:24 + */ + +#include "tclInt.h" +#include "tclPort.h" + +/* + * This history stuff is mostly straightforward, except for one thing + * that makes everything very complicated. Suppose that the following + * commands get executed: + * echo foo + * history redo + * It's important that the history event recorded for the second command + * be "echo foo", not "history redo". Otherwise, if another "history redo" + * command is typed, it will result in infinite recursions on the + * "history redo" command. Thus, the actual recorded history must be + * echo foo + * echo foo + * To do this, the history command revises recorded history as part of + * its execution. In the example above, when "history redo" starts + * execution, the current event is "history redo", but the history + * command arranges for the current event to be changed to "echo foo". + * + * There are three additional complications. The first is that history + * substitution may only be part of a command, as in the following + * command sequence: + * echo foo bar + * echo [history word 3] + * In this case, the second event should be recorded as "echo bar". Only + * part of the recorded event is to be modified. Fortunately, Tcl_Eval + * helps with this by recording (in the evalFirst and evalLast fields of + * the intepreter) the location of the command being executed, so the + * history module can replace exactly the range of bytes corresponding + * to the history substitution command. + * + * The second complication is that there are two ways to revise history: + * replace a command, and replace the result of a command. Consider the + * two examples below: + * format {result is %d} $num | format {result is %d} $num + * print [history redo] | print [history word 3] + * Recorded history for these two cases should be as follows: + * format {result is %d} $num | format {result is %d} $num + * print [format {result is %d} $num] | print $num + * In the left case, the history command was replaced with another command + * to be executed (the brackets were retained), but in the case on the + * right the result of executing the history command was replaced (i.e. + * brackets were replaced too). + * + * The third complication is that there could potentially be many + * history substitutions within a single command, as in: + * echo [history word 3] [history word 2] + * There could even be nested history substitutions, as in: + * history subs abc [history word 2] + * If history revisions were made immediately during each "history" command + * invocations, it would be very difficult to produce the correct cumulative + * effect from several substitutions in the same command. To get around + * this problem, the actual history revision isn't made during the execution + * of the "history" command. Information about the changes is just recorded, + * in xxx records, and the actual changes are made during the next call to + * Tcl_RecordHistory (when we know that execution of the previous command + * has finished). + */ + +/* + * Default space allocation for command strings: + */ + +#define INITIAL_CMD_SIZE 40 + +/* + * Forward declarations for procedures defined later in this file: + */ + +static void DoRevs _ANSI_ARGS_((Interp *iPtr)); +static HistoryEvent * GetEvent _ANSI_ARGS_((Interp *iPtr, char *string)); +static char * GetWords _ANSI_ARGS_((Interp *iPtr, char *command, + char *words)); +static void InitHistory _ANSI_ARGS_((Interp *iPtr)); +static void InsertRev _ANSI_ARGS_((Interp *iPtr, + HistoryRev *revPtr)); +static void MakeSpace _ANSI_ARGS_((HistoryEvent *hPtr, int size)); +static void RevCommand _ANSI_ARGS_((Interp *iPtr, char *string)); +static void RevResult _ANSI_ARGS_((Interp *iPtr, char *string)); +static int SubsAndEval _ANSI_ARGS_((Interp *iPtr, char *cmd, + char *old, char *new)); + +/* + *---------------------------------------------------------------------- + * + * InitHistory -- + * + * Initialize history-related state in an interpreter. + * + * Results: + * None. + * + * Side effects: + * History info is initialized in iPtr. + * + *---------------------------------------------------------------------- + */ + +static void +InitHistory(iPtr) + register Interp *iPtr; /* Interpreter to initialize. */ +{ + int i; + + if (iPtr->numEvents != 0) { + return; + } + iPtr->numEvents = 20; + iPtr->events = (HistoryEvent *) + ckalloc((unsigned) (iPtr->numEvents * sizeof(HistoryEvent))); + for (i = 0; i < iPtr->numEvents; i++) { + iPtr->events[i].command = (char *) ckalloc(INITIAL_CMD_SIZE); + *iPtr->events[i].command = 0; + iPtr->events[i].bytesAvl = INITIAL_CMD_SIZE; + } + iPtr->curEvent = 0; + iPtr->curEventNum = 0; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_RecordAndEval -- + * + * This procedure adds its command argument to the current list of + * recorded events and then executes the command by calling + * Tcl_Eval. + * + * Results: + * The return value is a standard Tcl return value, the result of + * executing cmd. + * + * Side effects: + * The command is recorded and executed. In addition, pending history + * revisions are carried out, and information is set up to enable + * Tcl_Eval to identify history command ranges. This procedure also + * initializes history information for the interpreter, if it hasn't + * already been initialized. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_RecordAndEval(interp, cmd, flags) + Tcl_Interp *interp; /* Token for interpreter in which command + * will be executed. */ + char *cmd; /* Command to record. */ + int flags; /* Additional flags. TCL_NO_EVAL means + * only record: don't execute command. + * TCL_EVAL_GLOBAL means use Tcl_GlobalEval + * instead of Tcl_Eval. */ +{ + register Interp *iPtr = (Interp *) interp; + register HistoryEvent *eventPtr; + int length, result; + + if (iPtr->numEvents == 0) { + InitHistory(iPtr); + } + DoRevs(iPtr); + + /* + * Don't record empty commands. + */ + + while (isspace(UCHAR(*cmd))) { + cmd++; + } + if (*cmd == '\0') { + Tcl_ResetResult(interp); + return TCL_OK; + } + + iPtr->curEventNum++; + iPtr->curEvent++; + if (iPtr->curEvent >= iPtr->numEvents) { + iPtr->curEvent = 0; + } + eventPtr = &iPtr->events[iPtr->curEvent]; + + /* + * Chop off trailing newlines before recording the command. + */ + + length = strlen(cmd); + while (cmd[length-1] == '\n') { + length--; + } + MakeSpace(eventPtr, length + 1); + strncpy(eventPtr->command, cmd, (size_t) length); + eventPtr->command[length] = 0; + + /* + * Execute the command. Note: history revision isn't possible after + * a nested call to this procedure, because the event at the top of + * the history list no longer corresponds to what's going on when + * a nested call here returns. Thus, must leave history revision + * disabled when we return. + */ + + result = TCL_OK; + if (!(flags & TCL_NO_EVAL)) { + iPtr->historyFirst = cmd; + iPtr->revDisables = 0; + iPtr->evalFlags = (flags & ~TCL_EVAL_GLOBAL) | TCL_RECORD_BOUNDS; + if (flags & TCL_EVAL_GLOBAL) { + result = Tcl_GlobalEval(interp, cmd); + } else { + result = Tcl_Eval(interp, cmd); + } + } + iPtr->revDisables = 1; + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_HistoryCmd -- + * + * This procedure is invoked to process the "history" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_HistoryCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + register Interp *iPtr = (Interp *) interp; + register HistoryEvent *eventPtr; + size_t length; + int c; + + if (iPtr->numEvents == 0) { + InitHistory(iPtr); + } + + /* + * If no arguments, treat the same as "history info". + */ + + if (argc == 1) { + goto infoCmd; + } + + c = argv[1][0]; + length = strlen(argv[1]); + + if ((c == 'a') && (strncmp(argv[1], "add", length)) == 0) { + if ((argc != 3) && (argc != 4)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " add event ?exec?\"", (char *) NULL); + return TCL_ERROR; + } + if (argc == 4) { + if (strncmp(argv[3], "exec", strlen(argv[3])) != 0) { + Tcl_AppendResult(interp, "bad argument \"", argv[3], + "\": should be \"exec\"", (char *) NULL); + return TCL_ERROR; + } + return Tcl_RecordAndEval(interp, argv[2], 0); + } + return Tcl_RecordAndEval(interp, argv[2], TCL_NO_EVAL); + } else if ((c == 'c') && (strncmp(argv[1], "change", length)) == 0) { + if ((argc != 3) && (argc != 4)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " change newValue ?event?\"", (char *) NULL); + return TCL_ERROR; + } + if (argc == 3) { + eventPtr = &iPtr->events[iPtr->curEvent]; + iPtr->revDisables += 1; + while (iPtr->revPtr != NULL) { + HistoryRev *nextPtr; + + ckfree(iPtr->revPtr->newBytes); + nextPtr = iPtr->revPtr->nextPtr; + ckfree((char *) iPtr->revPtr); + iPtr->revPtr = nextPtr; + } + } else { + eventPtr = GetEvent(iPtr, argv[3]); + if (eventPtr == NULL) { + return TCL_ERROR; + } + } + MakeSpace(eventPtr, (int) strlen(argv[2]) + 1); + strcpy(eventPtr->command, argv[2]); + return TCL_OK; + } else if ((c == 'e') && (strncmp(argv[1], "event", length)) == 0) { + if (argc > 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " event ?event?\"", (char *) NULL); + return TCL_ERROR; + } + eventPtr = GetEvent(iPtr, argc==2 ? "-1" : argv[2]); + if (eventPtr == NULL) { + return TCL_ERROR; + } + RevResult(iPtr, eventPtr->command); + Tcl_SetResult(interp, eventPtr->command, TCL_VOLATILE); + return TCL_OK; + } else if ((c == 'i') && (strncmp(argv[1], "info", length)) == 0) { + int count, indx, i; + char *newline; + + if ((argc != 2) && (argc != 3)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " info ?count?\"", (char *) NULL); + return TCL_ERROR; + } + infoCmd: + if (argc == 3) { + if (Tcl_GetInt(interp, argv[2], &count) != TCL_OK) { + return TCL_ERROR; + } + if (count > iPtr->numEvents) { + count = iPtr->numEvents; + } + } else { + count = iPtr->numEvents; + } + newline = ""; + for (i = 0, indx = iPtr->curEvent + 1 + iPtr->numEvents - count; + i < count; i++, indx++) { + char *cur, *next, savedChar; + char serial[20]; + + if (indx >= iPtr->numEvents) { + indx -= iPtr->numEvents; + } + cur = iPtr->events[indx].command; + if (*cur == '\0') { + continue; /* No command recorded here. */ + } + sprintf(serial, "%6d ", iPtr->curEventNum + 1 - (count - i)); + Tcl_AppendResult(interp, newline, serial, (char *) NULL); + newline = "\n"; + + /* + * Tricky formatting here: for multi-line commands, indent + * the continuation lines. + */ + + while (1) { + next = strchr(cur, '\n'); + if (next == NULL) { + break; + } + next++; + savedChar = *next; + *next = 0; + Tcl_AppendResult(interp, cur, "\t", (char *) NULL); + *next = savedChar; + cur = next; + } + Tcl_AppendResult(interp, cur, (char *) NULL); + } + return TCL_OK; + } else if ((c == 'k') && (strncmp(argv[1], "keep", length)) == 0) { + int count, i, src; + HistoryEvent *events; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " keep number\"", (char *) NULL); + return TCL_ERROR; + } + if (Tcl_GetInt(interp, argv[2], &count) != TCL_OK) { + return TCL_ERROR; + } + if ((count <= 0) || (count > 1000)) { + Tcl_AppendResult(interp, "illegal keep count \"", argv[2], + "\"", (char *) NULL); + return TCL_ERROR; + } + + /* + * Create a new history array and copy as much existing history + * as possible from the old array. + */ + + events = (HistoryEvent *) + ckalloc((unsigned) (count * sizeof(HistoryEvent))); + if (count < iPtr->numEvents) { + src = iPtr->curEvent + 1 - count; + if (src < 0) { + src += iPtr->numEvents; + } + } else { + src = iPtr->curEvent + 1; + } + for (i = 0; i < count; i++, src++) { + if (src >= iPtr->numEvents) { + src = 0; + } + if (i < iPtr->numEvents) { + events[i] = iPtr->events[src]; + iPtr->events[src].command = NULL; + } else { + events[i].command = (char *) ckalloc(INITIAL_CMD_SIZE); + events[i].command[0] = 0; + events[i].bytesAvl = INITIAL_CMD_SIZE; + } + } + + /* + * Throw away everything left in the old history array, and + * substitute the new one for the old one. + */ + + for (i = 0; i < iPtr->numEvents; i++) { + if (iPtr->events[i].command != NULL) { + ckfree(iPtr->events[i].command); + } + } + ckfree((char *) iPtr->events); + iPtr->events = events; + if (count < iPtr->numEvents) { + iPtr->curEvent = count-1; + } else { + iPtr->curEvent = iPtr->numEvents-1; + } + iPtr->numEvents = count; + return TCL_OK; + } else if ((c == 'n') && (strncmp(argv[1], "nextid", length)) == 0) { + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " nextid\"", (char *) NULL); + return TCL_ERROR; + } + sprintf(iPtr->result, "%d", iPtr->curEventNum+1); + return TCL_OK; + } else if ((c == 'r') && (strncmp(argv[1], "redo", length)) == 0) { + if (argc > 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " redo ?event?\"", (char *) NULL); + return TCL_ERROR; + } + eventPtr = GetEvent(iPtr, argc==2 ? "-1" : argv[2]); + if (eventPtr == NULL) { + return TCL_ERROR; + } + RevCommand(iPtr, eventPtr->command); + return Tcl_Eval(interp, eventPtr->command); + } else if ((c == 's') && (strncmp(argv[1], "substitute", length)) == 0) { + if ((argc > 5) || (argc < 4)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " substitute old new ?event?\"", (char *) NULL); + return TCL_ERROR; + } + eventPtr = GetEvent(iPtr, argc==4 ? "-1" : argv[4]); + if (eventPtr == NULL) { + return TCL_ERROR; + } + return SubsAndEval(iPtr, eventPtr->command, argv[2], argv[3]); + } else if ((c == 'w') && (strncmp(argv[1], "words", length)) == 0) { + char *words; + + if ((argc != 3) && (argc != 4)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " words num-num/pat ?event?\"", (char *) NULL); + return TCL_ERROR; + } + eventPtr = GetEvent(iPtr, argc==3 ? "-1" : argv[3]); + if (eventPtr == NULL) { + return TCL_ERROR; + } + words = GetWords(iPtr, eventPtr->command, argv[2]); + if (words == NULL) { + return TCL_ERROR; + } + RevResult(iPtr, words); + iPtr->result = words; + iPtr->freeProc = TCL_DYNAMIC; + return TCL_OK; + } + + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be add, change, event, info, keep, nextid, ", + "redo, substitute, or words", (char *) NULL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * MakeSpace -- + * + * Given a history event, make sure it has enough space for + * a string of a given length (enlarge the string area if + * necessary). + * + * Results: + * None. + * + * Side effects: + * More memory may get allocated. + * + *---------------------------------------------------------------------- + */ + +static void +MakeSpace(hPtr, size) + HistoryEvent *hPtr; + int size; /* # of bytes needed in hPtr. */ +{ + if (hPtr->bytesAvl < size) { + ckfree(hPtr->command); + hPtr->command = (char *) ckalloc((unsigned) size); + hPtr->bytesAvl = size; + } +} + +/* + *---------------------------------------------------------------------- + * + * InsertRev -- + * + * Add a new revision to the list of those pending for iPtr. + * Do it in a way that keeps the revision list sorted in + * increasing order of firstIndex. Also, eliminate revisions + * that are subsets of other revisions. + * + * Results: + * None. + * + * Side effects: + * RevPtr is added to iPtr's revision list. + * + *---------------------------------------------------------------------- + */ + +static void +InsertRev(iPtr, revPtr) + Interp *iPtr; /* Interpreter to use. */ + register HistoryRev *revPtr; /* Revision to add to iPtr's list. */ +{ + register HistoryRev *curPtr; + register HistoryRev *prevPtr; + + for (curPtr = iPtr->revPtr, prevPtr = NULL; curPtr != NULL; + prevPtr = curPtr, curPtr = curPtr->nextPtr) { + /* + * If this revision includes the new one (or vice versa) then + * just eliminate the one that is a subset of the other. + */ + + if ((revPtr->firstIndex <= curPtr->firstIndex) + && (revPtr->lastIndex >= curPtr->firstIndex)) { + curPtr->firstIndex = revPtr->firstIndex; + curPtr->lastIndex = revPtr->lastIndex; + curPtr->newSize = revPtr->newSize; + ckfree(curPtr->newBytes); + curPtr->newBytes = revPtr->newBytes; + ckfree((char *) revPtr); + return; + } + if ((revPtr->firstIndex >= curPtr->firstIndex) + && (revPtr->lastIndex <= curPtr->lastIndex)) { + ckfree(revPtr->newBytes); + ckfree((char *) revPtr); + return; + } + + if (revPtr->firstIndex < curPtr->firstIndex) { + break; + } + } + + /* + * Insert revPtr just after prevPtr. + */ + + if (prevPtr == NULL) { + revPtr->nextPtr = iPtr->revPtr; + iPtr->revPtr = revPtr; + } else { + revPtr->nextPtr = prevPtr->nextPtr; + prevPtr->nextPtr = revPtr; + } +} + +/* + *---------------------------------------------------------------------- + * + * RevCommand -- + * + * This procedure is invoked by the "history" command to record + * a command revision. See the comments at the beginning of the + * file for more information about revisions. + * + * Results: + * None. + * + * Side effects: + * Revision information is recorded. + * + *---------------------------------------------------------------------- + */ + +static void +RevCommand(iPtr, string) + register Interp *iPtr; /* Interpreter in which to perform the + * substitution. */ + char *string; /* String to substitute. */ +{ + register HistoryRev *revPtr; + + if ((iPtr->evalFirst == NULL) || (iPtr->revDisables > 0)) { + return; + } + revPtr = (HistoryRev *) ckalloc(sizeof(HistoryRev)); + revPtr->firstIndex = iPtr->evalFirst - iPtr->historyFirst; + revPtr->lastIndex = iPtr->evalLast - iPtr->historyFirst; + revPtr->newSize = strlen(string); + revPtr->newBytes = (char *) ckalloc((unsigned) (revPtr->newSize+1)); + strcpy(revPtr->newBytes, string); + InsertRev(iPtr, revPtr); +} + +/* + *---------------------------------------------------------------------- + * + * RevResult -- + * + * This procedure is invoked by the "history" command to record + * a result revision. See the comments at the beginning of the + * file for more information about revisions. + * + * Results: + * None. + * + * Side effects: + * Revision information is recorded. + * + *---------------------------------------------------------------------- + */ + +static void +RevResult(iPtr, string) + register Interp *iPtr; /* Interpreter in which to perform the + * substitution. */ + char *string; /* String to substitute. */ +{ + register HistoryRev *revPtr; + char *evalFirst, *evalLast; + char *argv[2]; + + if ((iPtr->evalFirst == NULL) || (iPtr->revDisables > 0)) { + return; + } + + /* + * Expand the replacement range to include the brackets that surround + * the command. If there aren't any brackets (i.e. this command was + * invoked at top-level) then don't do any revision. Also, if there + * are several commands in brackets, of which this is just one, + * then don't do any revision. + */ + + evalFirst = iPtr->evalFirst; + evalLast = iPtr->evalLast + 1; + while (1) { + if (evalFirst == iPtr->historyFirst) { + return; + } + evalFirst--; + if (*evalFirst == '[') { + break; + } + if (!isspace(UCHAR(*evalFirst))) { + return; + } + } + if (*evalLast != ']') { + return; + } + + revPtr = (HistoryRev *) ckalloc(sizeof(HistoryRev)); + revPtr->firstIndex = evalFirst - iPtr->historyFirst; + revPtr->lastIndex = evalLast - iPtr->historyFirst; + argv[0] = string; + revPtr->newBytes = Tcl_Merge(1, argv); + revPtr->newSize = strlen(revPtr->newBytes); + InsertRev(iPtr, revPtr); +} + +/* + *---------------------------------------------------------------------- + * + * DoRevs -- + * + * This procedure is called to apply the history revisions that + * have been recorded in iPtr. + * + * Results: + * None. + * + * Side effects: + * The most recent entry in the history for iPtr may be modified. + * + *---------------------------------------------------------------------- + */ + +static void +DoRevs(iPtr) + register Interp *iPtr; /* Interpreter whose history is to + * be modified. */ +{ + register HistoryRev *revPtr; + register HistoryEvent *eventPtr; + char *newCommand, *p; + unsigned int size; + int bytesSeen, count; + + if (iPtr->revPtr == NULL) { + return; + } + + /* + * The revision is done in two passes. The first pass computes the + * amount of space needed for the revised event, and the second pass + * pieces together the new event and frees up the revisions. + */ + + eventPtr = &iPtr->events[iPtr->curEvent]; + size = strlen(eventPtr->command) + 1; + for (revPtr = iPtr->revPtr; revPtr != NULL; revPtr = revPtr->nextPtr) { + size -= revPtr->lastIndex + 1 - revPtr->firstIndex; + size += revPtr->newSize; + } + + newCommand = (char *) ckalloc(size); + p = newCommand; + bytesSeen = 0; + for (revPtr = iPtr->revPtr; revPtr != NULL; ) { + HistoryRev *nextPtr = revPtr->nextPtr; + + count = revPtr->firstIndex - bytesSeen; + if (count > 0) { + strncpy(p, eventPtr->command + bytesSeen, (size_t) count); + p += count; + } + strncpy(p, revPtr->newBytes, (size_t) revPtr->newSize); + p += revPtr->newSize; + bytesSeen = revPtr->lastIndex+1; + ckfree(revPtr->newBytes); + ckfree((char *) revPtr); + revPtr = nextPtr; + } + strcpy(p, eventPtr->command + bytesSeen); + + /* + * Replace the command in the event. + */ + + ckfree(eventPtr->command); + eventPtr->command = newCommand; + eventPtr->bytesAvl = size; + iPtr->revPtr = NULL; +} + +/* + *---------------------------------------------------------------------- + * + * GetEvent -- + * + * Given a textual description of an event (see the manual page + * for legal values) find the corresponding event and return its + * command string. + * + * Results: + * The return value is a pointer to the event named by "string". + * If no such event exists, then NULL is returned and an error + * message is left in iPtr. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static HistoryEvent * +GetEvent(iPtr, string) + register Interp *iPtr; /* Interpreter in which to look. */ + char *string; /* Description of event. */ +{ + int eventNum, index; + register HistoryEvent *eventPtr; + int length; + + /* + * First check for a numeric specification of an event. + */ + + if (isdigit(UCHAR(*string)) || (*string == '-')) { + if (Tcl_GetInt((Tcl_Interp *) iPtr, string, &eventNum) != TCL_OK) { + return NULL; + } + if (eventNum < 0) { + eventNum += iPtr->curEventNum; + } + if (eventNum > iPtr->curEventNum) { + Tcl_AppendResult((Tcl_Interp *) iPtr, "event \"", string, + "\" hasn't occurred yet", (char *) NULL); + return NULL; + } + if ((eventNum <= iPtr->curEventNum-iPtr->numEvents) + || (eventNum <= 0)) { + Tcl_AppendResult((Tcl_Interp *) iPtr, "event \"", string, + "\" is too far in the past", (char *) NULL); + return NULL; + } + index = iPtr->curEvent + (eventNum - iPtr->curEventNum); + if (index < 0) { + index += iPtr->numEvents; + } + return &iPtr->events[index]; + } + + /* + * Next, check for an event that contains the string as a prefix or + * that matches the string in the sense of Tcl_StringMatch. + */ + + length = strlen(string); + for (index = iPtr->curEvent - 1; ; index--) { + if (index < 0) { + index += iPtr->numEvents; + } + if (index == iPtr->curEvent) { + break; + } + eventPtr = &iPtr->events[index]; + if ((strncmp(eventPtr->command, string, (size_t) length) == 0) + || Tcl_StringMatch(eventPtr->command, string)) { + return eventPtr; + } + } + + Tcl_AppendResult((Tcl_Interp *) iPtr, "no event matches \"", string, + "\"", (char *) NULL); + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * SubsAndEval -- + * + * Generate a new command by making a textual substitution in + * the "cmd" argument. Then execute the new command. + * + * Results: + * The return value is a standard Tcl error. + * + * Side effects: + * History gets revised if the substitution is occurring on + * a recorded command line. Also, the re-executed command + * may produce side-effects. + * + *---------------------------------------------------------------------- + */ + +static int +SubsAndEval(iPtr, cmd, old, new) + register Interp *iPtr; /* Interpreter in which to execute + * new command. */ + char *cmd; /* Command in which to substitute. */ + char *old; /* String to search for in command. */ + char *new; /* Replacement string for "old". */ +{ + char *src, *dst, *newCmd; + int count, oldLength, newLength, length, result; + + /* + * Figure out how much space it will take to hold the + * substituted command (and complain if the old string + * doesn't appear in the original command). + */ + + oldLength = strlen(old); + newLength = strlen(new); + src = cmd; + count = 0; + while (1) { + src = strstr(src, old); + if (src == NULL) { + break; + } + src += oldLength; + count++; + } + if (count == 0) { + Tcl_AppendResult((Tcl_Interp *) iPtr, "\"", old, + "\" doesn't appear in event", (char *) NULL); + return TCL_ERROR; + } + length = strlen(cmd) + count*(newLength - oldLength); + + /* + * Generate a substituted command. + */ + + newCmd = (char *) ckalloc((unsigned) (length + 1)); + dst = newCmd; + while (1) { + src = strstr(cmd, old); + if (src == NULL) { + strcpy(dst, cmd); + break; + } + strncpy(dst, cmd, (size_t) (src-cmd)); + dst += src-cmd; + strcpy(dst, new); + dst += newLength; + cmd = src + oldLength; + } + + RevCommand(iPtr, newCmd); + result = Tcl_Eval((Tcl_Interp *) iPtr, newCmd); + ckfree(newCmd); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * GetWords -- + * + * Given a command string, return one or more words from the + * command string. + * + * Results: + * The return value is a pointer to a dynamically-allocated + * string containing the words of command specified by "words". + * If the word specifier has improper syntax then an error + * message is placed in iPtr->result and NULL is returned. + * + * Side effects: + * Memory is allocated. It is the caller's responsibilty to + * free the returned string.. + * + *---------------------------------------------------------------------- + */ + +static char * +GetWords(iPtr, command, words) + register Interp *iPtr; /* Tcl interpreter in which to place + * an error message if needed. */ + char *command; /* Command string. */ + char *words; /* Description of which words to extract + * from the command. Either num[-num] or + * a pattern. */ +{ + char *result; + char *start, *end, *dst; + register char *next; + int first; /* First word desired. -1 means last word + * only. */ + int last; /* Last word desired. -1 means use everything + * up to the end. */ + int index; /* Index of current word. */ + char *pattern; + + /* + * Figure out whether we're looking for a numerical range or for + * a pattern. + */ + + pattern = NULL; + first = 0; + last = -1; + if (*words == '$') { + if (words[1] != '\0') { + goto error; + } + first = -1; + } else if (isdigit(UCHAR(*words))) { + first = strtoul(words, &start, 0); + if (*start == 0) { + last = first; + } else if (*start == '-') { + start++; + if (*start == '$') { + start++; + } else if (isdigit(UCHAR(*start))) { + last = strtoul(start, &start, 0); + } else { + goto error; + } + if (*start != 0) { + goto error; + } + } + if ((first > last) && (last != -1)) { + goto error; + } + } else { + pattern = words; + } + + /* + * Scan through the words one at a time, copying those that are + * relevant into the result string. Allocate a result area large + * enough to hold all the words if necessary. + */ + + result = (char *) ckalloc((unsigned) (strlen(command) + 1)); + dst = result; + for (next = command; isspace(UCHAR(*next)); next++) { + /* Empty loop body: just find start of first word. */ + } + for (index = 0; *next != 0; index++) { + start = next; + end = TclWordEnd(next, 0, (int *) NULL); + if (*end != 0) { + end++; + for (next = end; isspace(UCHAR(*next)); next++) { + /* Empty loop body: just find start of next word. */ + } + } + if ((first > index) || ((first == -1) && (*next != 0))) { + continue; + } + if ((last != -1) && (last < index)) { + continue; + } + if (pattern != NULL) { + int match; + char savedChar = *end; + + *end = 0; + match = Tcl_StringMatch(start, pattern); + *end = savedChar; + if (!match) { + continue; + } + } + if (dst != result) { + *dst = ' '; + dst++; + } + strncpy(dst, start, (size_t) (end-start)); + dst += end-start; + } + *dst = 0; + + /* + * Check for an out-of-range argument index. + */ + + if ((last >= index) || (first >= index)) { + ckfree(result); + Tcl_AppendResult((Tcl_Interp *) iPtr, "word selector \"", words, + "\" specified non-existent words", (char *) NULL); + return NULL; + } + return result; + + error: + Tcl_AppendResult((Tcl_Interp *) iPtr, "bad word selector \"", words, + "\": should be num-num or pattern", (char *) NULL); + return NULL; +} diff --git a/contrib/tcl/generic/tclIO.c b/contrib/tcl/generic/tclIO.c new file mode 100644 index 0000000000000..0c54c12a0da19 --- /dev/null +++ b/contrib/tcl/generic/tclIO.c @@ -0,0 +1,5055 @@ +/* + * tclIO.c -- + * + * This file provides the generic portions (those that are the same on + * all platforms and for all channel types) of Tcl's IO facilities. + * + * 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: @(#) tclIO.c 1.211 96/04/18 09:59:06 + */ + +#include "tclInt.h" +#include "tclPort.h" + +/* + * Make sure that both EAGAIN and EWOULDBLOCK are defined. This does not + * compile on systems where neither is defined. We want both defined so + * that we can test safely for both. In the code we still have to test for + * both because there may be systems on which both are defined and have + * different values. + */ + +#if ((!defined(EWOULDBLOCK)) && (defined(EAGAIN))) +# define EWOULDBLOCK EAGAIN +#endif +#if ((!defined(EAGAIN)) && (defined(EWOULDBLOCK))) +# define EAGAIN EWOULDBLOCK +#endif +#if ((!defined(EAGAIN)) && (!defined(EWOULDBLOCK))) + error one of EWOULDBLOCK or EAGAIN must be defined +#endif + +/* + * struct ChannelBuffer: + * + * Buffers data being sent to or from a channel. + */ + +typedef struct ChannelBuffer { + int nextAdded; /* The next position into which a character + * will be put in the buffer. */ + int nextRemoved; /* Position of next byte to be removed + * from the buffer. */ + int bufSize; /* How big is the buffer? */ + struct ChannelBuffer *nextPtr; + /* Next buffer in chain. */ + char buf[4]; /* Placeholder for real buffer. The real + * buffer occuppies this space + bufSize-4 + * bytes. This must be the last field in + * the structure. */ +} ChannelBuffer; + +#define CHANNELBUFFER_HEADER_SIZE (sizeof(ChannelBuffer) - 4) + +/* + * The following defines the *default* buffer size for channels. + */ + +#define CHANNELBUFFER_DEFAULT_SIZE (1024 * 4) + +/* + * Structure to record a close callback. One such record exists for + * each close callback registered for a channel. + */ + +typedef struct CloseCallback { + Tcl_CloseProc *proc; /* The procedure to call. */ + ClientData clientData; /* Arbitrary one-word data to pass + * to the callback. */ + struct CloseCallback *nextPtr; /* For chaining close callbacks. */ +} CloseCallback; + +/* + * Forward declaration of Channel; being used in struct EventScriptRecord, + * below. + */ + +typedef struct Channel *ChanPtr; + +/* + * The following structure describes the information saved from a call to + * "fileevent". This is used later when the event being waited for to + * invoke the saved script in the interpreter designed in this record. + */ + +typedef struct EventScriptRecord { + struct Channel *chanPtr; /* The channel for which this script is + * registered. This is used only when an + * error occurs during evaluation of the + * script, to delete the handler. */ + char *script; /* Script to invoke. */ + Tcl_Interp *interp; /* In what interpreter to invoke script? */ + int mask; /* Events must overlap current mask for the + * stored script to be invoked. */ + struct EventScriptRecord *nextPtr; + /* Next in chain of records. */ +} EventScriptRecord; + +/* + * Forward declaration of ChannelHandler; being used in struct Channel, + * below. + */ + +typedef struct ChannelHandler *ChannelHandlerPtr; + +/* + * struct Channel: + * + * One of these structures is allocated for each open channel. It contains data + * specific to the channel but which belongs to the generic part of the Tcl + * channel mechanism, and it points at an instance specific (and type + * specific) * instance data, and at a channel type structure. + */ + +typedef struct Channel { + char *channelName; /* The name of the channel instance in Tcl + * commands. Storage is owned by the generic IO + * code, is dynamically allocated. */ + int flags; /* ORed combination of the flags defined + * below. */ + Tcl_EolTranslation inputTranslation; + /* What translation to apply for end of line + * sequences on input? */ + Tcl_EolTranslation outputTranslation; + /* What translation to use for generating + * end of line sequences in output? */ + int inEofChar; /* If nonzero, use this as a signal of EOF + * on input. */ + int outEofChar; /* If nonzero, append this to the channel + * when it is closed if it is open for + * writing. */ + int unreportedError; /* Non-zero if an error report was deferred + * because it happened in the background. The + * value is the POSIX error code. */ + ClientData instanceData; /* Instance specific data. */ + Tcl_File inFile; /* File to use for input, or NULL. */ + Tcl_File outFile; /* File to use for output, or NULL. */ + Tcl_ChannelType *typePtr; /* Pointer to channel type structure. */ + int refCount; /* How many interpreters hold references to + * this IO channel? */ + CloseCallback *closeCbPtr; /* Callbacks registered to be called when the + * channel is closed. */ + ChannelBuffer *curOutPtr; /* Current output buffer being filled. */ + ChannelBuffer *outQueueHead;/* Points at first buffer in output queue. */ + ChannelBuffer *outQueueTail;/* Points at last buffer in output queue. */ + + ChannelBuffer *saveInBufPtr;/* Buffer saved for input queue - eliminates + * need to allocate a new buffer for "gets" + * that crosses buffer boundaries. */ + ChannelBuffer *inQueueHead; /* Points at first buffer in input queue. */ + ChannelBuffer *inQueueTail; /* Points at last buffer in input queue. */ + + struct ChannelHandler *chPtr;/* List of channel handlers registered + * for this channel. */ + int interestMask; /* Mask of all events this channel has + * handlers for. */ + struct Channel *nextChanPtr;/* Next in list of channels currently open. */ + EventScriptRecord *scriptRecordPtr; + /* Chain of all scripts registered for + * event handlers ("fileevent") on this + * channel. */ + int bufSize; /* What size buffers to allocate? */ +} Channel; + +/* + * Values for the flags field in Channel. Any ORed combination of the + * following flags can be stored in the field. These flags record various + * options and state bits about the channel. In addition to the flags below, + * the channel can also have TCL_READABLE (1<<1) and TCL_WRITABLE (1<<2) set. + */ + +#define CHANNEL_NONBLOCKING (1<<3) /* Channel is currently in + * nonblocking mode. */ +#define CHANNEL_LINEBUFFERED (1<<4) /* Output to the channel must be + * flushed after every newline. */ +#define CHANNEL_UNBUFFERED (1<<5) /* Output to the channel must always + * be flushed immediately. */ +#define BUFFER_READY (1<<6) /* Current output buffer (the + * curOutPtr field in the + * channel structure) should be + * output as soon as possible event + * though it may not be full. */ +#define BG_FLUSH_SCHEDULED (1<<7) /* A background flush of the + * queued output buffers has been + * scheduled. */ +#define CHANNEL_CLOSED (1<<8) /* Channel has been closed. No + * further Tcl-level IO on the + * channel is allowed. */ +#define CHANNEL_EOF (1<<9) /* EOF occurred on this channel. + * This bit is cleared before every + * input operation. */ +#define CHANNEL_STICKY_EOF (1<<10) /* EOF occurred on this channel because + * we saw the input eofChar. This bit + * prevents clearing of the EOF bit + * before every input operation. */ +#define CHANNEL_BLOCKED (1<<11) /* EWOULDBLOCK or EAGAIN occurred + * on this channel. This bit is + * cleared before every input or + * output operation. */ +#define INPUT_SAW_CR (1<<12) /* Channel is in CRLF eol input + * translation mode and the last + * byte seen was a "\r". */ + +/* + * For each channel handler registered in a call to Tcl_CreateChannelHandler, + * there is one record of the following type. All of records for a specific + * channel are chained together in a singly linked list which is stored in + * the channel structure. + */ + +typedef struct ChannelHandler { + Channel *chanPtr; /* The channel structure for this channel. */ + int mask; /* Mask of desired events. */ + Tcl_ChannelProc *proc; /* Procedure to call in the type of + * Tcl_CreateChannelHandler. */ + ClientData clientData; /* Argument to pass to procedure. */ + struct ChannelHandler *nextPtr; + /* Next one in list of registered handlers. */ +} ChannelHandler; + +/* + * This structure keeps track of the current ChannelHandler being invoked in + * the current invocation of ChannelHandlerEventProc. There is a potential + * problem if a ChannelHandler is deleted while it is the current one, since + * ChannelHandlerEventProc needs to look at the nextPtr field. To handle this + * problem, structures of the type below indicate the next handler to be + * processed for any (recursively nested) dispatches in progress. The + * nextHandlerPtr field is updated if the handler being pointed to is deleted. + * The nextPtr field is used to chain together all recursive invocations, so + * that Tcl_DeleteChannelHandler can find all the recursively nested + * invocations of ChannelHandlerEventProc and compare the handler being + * deleted against the NEXT handler to be invoked in that invocation; when it + * finds such a situation, Tcl_DeleteChannelHandler updates the nextHandlerPtr + * field of the structure to the next handler. + */ + +typedef struct NextChannelHandler { + ChannelHandler *nextHandlerPtr; /* The next handler to be invoked in + * this invocation. */ + struct NextChannelHandler *nestedHandlerPtr; + /* Next nested invocation of + * ChannelHandlerEventProc. */ +} NextChannelHandler; + +/* + * This variable holds the list of nested ChannelHandlerEventProc invocations. + */ + +static NextChannelHandler *nestedHandlerPtr = (NextChannelHandler *) NULL; + +/* + * List of all channels currently open. + */ + +static Channel *firstChanPtr = (Channel *) NULL; + +/* + * Has a channel exit handler been created yet? + */ + +static int channelExitHandlerCreated = 0; + +/* + * Has the channel event source been created and registered with the + * notifier? + */ + +static int channelEventSourceCreated = 0; + +/* + * The following structure describes the event that is added to the Tcl + * event queue by the channel handler check procedure. + */ + +typedef struct ChannelHandlerEvent { + Tcl_Event header; /* Standard header for all events. */ + Channel *chanPtr; /* The channel that is ready. */ + int readyMask; /* Events that have occurred. */ +} ChannelHandlerEvent; + +/* + * Static buffer used to sprintf channel option values and return + * them to the caller. + */ + +static char optionVal[128]; + +/* + * Static variables to hold channels for stdin, stdout and stderr. + */ + +static Tcl_Channel stdinChannel = NULL; +static int stdinInitialized = 0; +static Tcl_Channel stdoutChannel = NULL; +static int stdoutInitialized = 0; +static Tcl_Channel stderrChannel = NULL; +static int stderrInitialized = 0; + +/* + * Static functions in this file: + */ + +static int ChannelEventDeleteProc _ANSI_ARGS_(( + Tcl_Event *evPtr, ClientData clientData)); +static void ChannelEventSourceExitProc _ANSI_ARGS_(( + ClientData data)); +static int ChannelHandlerEventProc _ANSI_ARGS_(( + Tcl_Event *evPtr, int flags)); +static void ChannelHandlerCheckProc _ANSI_ARGS_(( + ClientData clientData, int flags)); +static void ChannelHandlerSetupProc _ANSI_ARGS_(( + ClientData clientData, int flags)); +static void ChannelEventScriptInvoker _ANSI_ARGS_(( + ClientData clientData, int flags)); +static int CloseChannel _ANSI_ARGS_((Tcl_Interp *interp, + Channel *chanPtr, int errorCode)); +static void CloseChannelsOnExit _ANSI_ARGS_((ClientData data)); +static int CopyAndTranslateBuffer _ANSI_ARGS_(( + Channel *chanPtr, char *result, int space)); +static void CreateScriptRecord _ANSI_ARGS_(( + Tcl_Interp *interp, Channel *chanPtr, + int mask, char *script)); +static void DeleteChannelTable _ANSI_ARGS_(( + ClientData clientData, Tcl_Interp *interp)); +static void DeleteScriptRecord _ANSI_ARGS_((Tcl_Interp *interp, + Channel *chanPtr, int mask)); +static void DiscardInputQueued _ANSI_ARGS_(( + Channel *chanPtr, int discardSavedBuffers)); +static void DiscardOutputQueued _ANSI_ARGS_(( + Channel *chanPtr)); +static int FlushChannel _ANSI_ARGS_((Tcl_Interp *interp, + Channel *chanPtr, int calledFromAsyncFlush)); +static void FlushEventProc _ANSI_ARGS_((ClientData clientData, + int mask)); +static Tcl_HashTable *GetChannelTable _ANSI_ARGS_((Tcl_Interp *interp)); +static int GetEOL _ANSI_ARGS_((Channel *chanPtr)); +static int GetInput _ANSI_ARGS_((Channel *chanPtr)); +static void RecycleBuffer _ANSI_ARGS_((Channel *chanPtr, + ChannelBuffer *bufPtr, int mustDiscard)); +static void ReturnScriptRecord _ANSI_ARGS_((Tcl_Interp *interp, + Channel *chanPtr, int mask)); +static int ScanBufferForEOL _ANSI_ARGS_((Channel *chanPtr, + ChannelBuffer *bufPtr, + Tcl_EolTranslation translation, int eofChar, + int *bytesToEOLPtr, int *crSeenPtr)); +static int ScanInputForEOL _ANSI_ARGS_((Channel *chanPtr, + int *bytesQueuedPtr)); + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetStdChannel -- + * + * This function is used to change the channels that are used + * for stdin/stdout/stderr in new interpreters. + * + * Results: + * None + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SetStdChannel(channel, type) + Tcl_Channel channel; + int type; /* One of TCL_STDIN, TCL_STDOUT, TCL_STDERR. */ +{ + switch (type) { + case TCL_STDIN: + stdinInitialized = 1; + stdinChannel = channel; + break; + case TCL_STDOUT: + stdoutInitialized = 1; + stdoutChannel = channel; + break; + case TCL_STDERR: + stderrInitialized = 1; + stderrChannel = channel; + break; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetStdChannel -- + * + * Returns the specified standard channel. + * + * Results: + * Returns the specified standard channel, or NULL. + * + * Side effects: + * May cause the creation of a standard channel and the underlying + * file. + * + *---------------------------------------------------------------------- + */ + +Tcl_Channel +Tcl_GetStdChannel(type) + int type; /* One of TCL_STDIN, TCL_STDOUT, TCL_STDERR. */ +{ + Tcl_Channel channel = NULL; + + /* + * If the channels were not created yet, create them now and + * store them in the static variables. Note that we need to set + * stdinInitialized before calling TclGetDefaultStdChannel in order + * to avoid recursive loops when TclGetDefaultStdChannel calls + * Tcl_CreateChannel. + */ + + switch (type) { + case TCL_STDIN: + if (!stdinInitialized) { + stdinInitialized = 1; + stdinChannel = TclGetDefaultStdChannel(TCL_STDIN); + } + channel = stdinChannel; + break; + case TCL_STDOUT: + if (!stdoutInitialized) { + stdoutInitialized = 1; + stdoutChannel = TclGetDefaultStdChannel(TCL_STDOUT); + } + channel = stdoutChannel; + break; + case TCL_STDERR: + if (!stderrInitialized) { + stderrInitialized = 1; + stderrChannel = TclGetDefaultStdChannel(TCL_STDERR); + } + channel = stderrChannel; + break; + } + return channel; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CreateCloseHandler + * + * Creates a close callback which will be called when the channel is + * closed. + * + * Results: + * None. + * + * Side effects: + * Causes the callback to be called in the future when the channel + * will be closed. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_CreateCloseHandler(chan, proc, clientData) + Tcl_Channel chan; /* The channel for which to create the + * close callback. */ + Tcl_CloseProc *proc; /* The callback routine to call when the + * channel will be closed. */ + ClientData clientData; /* Arbitrary data to pass to the + * close callback. */ +{ + Channel *chanPtr; + CloseCallback *cbPtr; + + chanPtr = (Channel *) chan; + + cbPtr = (CloseCallback *) ckalloc((unsigned) sizeof(CloseCallback)); + cbPtr->proc = proc; + cbPtr->clientData = clientData; + + cbPtr->nextPtr = chanPtr->closeCbPtr; + chanPtr->closeCbPtr = cbPtr; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DeleteCloseHandler -- + * + * Removes a callback that would have been called on closing + * the channel. If there is no matching callback then this + * function has no effect. + * + * Results: + * None. + * + * Side effects: + * The callback will not be called in the future when the channel + * is eventually closed. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DeleteCloseHandler(chan, proc, clientData) + Tcl_Channel chan; /* The channel for which to cancel the + * close callback. */ + Tcl_CloseProc *proc; /* The procedure for the callback to + * remove. */ + ClientData clientData; /* The callback data for the callback + * to remove. */ +{ + Channel *chanPtr; + CloseCallback *cbPtr, *cbPrevPtr; + + chanPtr = (Channel *) chan; + for (cbPtr = chanPtr->closeCbPtr, cbPrevPtr = (CloseCallback *) NULL; + cbPtr != (CloseCallback *) NULL; + cbPtr = cbPtr->nextPtr) { + if ((cbPtr->proc == proc) && (cbPtr->clientData == clientData)) { + if (cbPrevPtr == (CloseCallback *) NULL) { + chanPtr->closeCbPtr = cbPtr->nextPtr; + } else { + cbPrevPtr = cbPtr->nextPtr; + } + ckfree((char *) cbPtr); + break; + } else { + cbPrevPtr = cbPtr; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * CloseChannelsOnExit -- + * + * Closes all the existing channels, on exit. This routine is called + * during exit processing. + * + * Results: + * None. + * + * Side effects: + * Closes all channels. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static void +CloseChannelsOnExit(clientData) + ClientData clientData; /* NULL - unused. */ +{ + Channel *chanPtr; /* Iterates over open channels. */ + Channel *nextChanPtr; /* Iterates over open channels. */ + + + for (chanPtr = firstChanPtr; chanPtr != (Channel *) NULL; + chanPtr = nextChanPtr) { + nextChanPtr = chanPtr->nextChanPtr; + + /* + * Close it only if the refcount indicates that the channel is not + * referenced from any interpreter. If it is, that interpreter will + * close the channel when it gets destroyed. + */ + + if (chanPtr->refCount <= 0) { + + /* + * Switch the channel back into synchronous mode to ensure that it + * gets flushed now. + */ + + (void) Tcl_SetChannelOption(NULL, (Tcl_Channel) chanPtr, + "-blocking", "on"); + + Tcl_Close((Tcl_Interp *) NULL, (Tcl_Channel) chanPtr); + } + } +} + +/* + *---------------------------------------------------------------------- + * + * GetChannelTable -- + * + * Gets and potentially initializes the channel table for an + * interpreter. If it is initializing the table it also inserts + * channels for stdin, stdout and stderr if the interpreter is + * trusted. + * + * Results: + * A pointer to the hash table created, for use by the caller. + * + * Side effects: + * Initializes the channel table for an interpreter. May create + * channels for stdin, stdout and stderr. + * + *---------------------------------------------------------------------- + */ + +static Tcl_HashTable * +GetChannelTable(interp) + Tcl_Interp *interp; +{ + Tcl_HashTable *hTblPtr; /* Hash table of channels. */ + Tcl_Channel stdinChannel, stdoutChannel, stderrChannel; + + hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclIO", NULL); + if (hTblPtr == (Tcl_HashTable *) NULL) { + hTblPtr = (Tcl_HashTable *) ckalloc((unsigned) sizeof(Tcl_HashTable)); + Tcl_InitHashTable(hTblPtr, TCL_STRING_KEYS); + + (void) Tcl_SetAssocData(interp, "tclIO", + (Tcl_InterpDeleteProc *) DeleteChannelTable, + (ClientData) hTblPtr); + + /* + * If the interpreter is trusted (not "safe"), insert channels + * for stdin, stdout and stderr (possibly creating them in the + * process). + */ + + if (Tcl_IsSafe(interp) == 0) { + stdinChannel = Tcl_GetStdChannel(TCL_STDIN); + if (stdinChannel != NULL) { + Tcl_RegisterChannel(interp, stdinChannel); + } + stdoutChannel = Tcl_GetStdChannel(TCL_STDOUT); + if (stdoutChannel != NULL) { + Tcl_RegisterChannel(interp, stdoutChannel); + } + stderrChannel = Tcl_GetStdChannel(TCL_STDERR); + if (stderrChannel != NULL) { + Tcl_RegisterChannel(interp, stderrChannel); + } + } + + } + return hTblPtr; +} + +/* + *---------------------------------------------------------------------- + * + * DeleteChannelTable -- + * + * Deletes the channel table for an interpreter, closing any open + * channels whose refcount reaches zero. This procedure is invoked + * when an interpreter is deleted, via the AssocData cleanup + * mechanism. + * + * Results: + * None. + * + * Side effects: + * Deletes the hash table of channels. May close channels. May flush + * output on closed channels. Removes any channeEvent handlers that were + * registered in this interpreter. + * + *---------------------------------------------------------------------- + */ + +static void +DeleteChannelTable(clientData, interp) + ClientData clientData; /* The per-interpreter data structure. */ + Tcl_Interp *interp; /* The interpreter being deleted. */ +{ + Tcl_HashTable *hTblPtr; /* The hash table. */ + Tcl_HashSearch hSearch; /* Search variable. */ + Tcl_HashEntry *hPtr; /* Search variable. */ + Channel *chanPtr; /* Channel being deleted. */ + EventScriptRecord *sPtr, *prevPtr, *nextPtr; + /* Variables to loop over all channel events + * registered, to delete the ones that refer + * to the interpreter being deleted. */ + + /* + * Delete all the registered channels - this will close channels whose + * refcount reaches zero. + */ + + hTblPtr = (Tcl_HashTable *) clientData; + for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); + hPtr != (Tcl_HashEntry *) NULL; + hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch)) { + + chanPtr = (Channel *) Tcl_GetHashValue(hPtr); + + /* + * Remove any fileevents registered in this interpreter. + */ + + for (sPtr = chanPtr->scriptRecordPtr, + prevPtr = (EventScriptRecord *) NULL; + sPtr != (EventScriptRecord *) NULL; + sPtr = nextPtr) { + nextPtr = sPtr->nextPtr; + if (sPtr->interp == interp) { + if (prevPtr == (EventScriptRecord *) NULL) { + chanPtr->scriptRecordPtr = nextPtr; + } else { + prevPtr->nextPtr = nextPtr; + } + + Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr, + ChannelEventScriptInvoker, (ClientData) sPtr); + + Tcl_EventuallyFree((ClientData) sPtr->script, TCL_DYNAMIC); + ckfree((char *) sPtr); + } else { + prevPtr = sPtr; + } + } + + /* + * Cannot call Tcl_UnregisterChannel because that procedure calls + * Tcl_GetAssocData to get the channel table, which might already + * be inaccessible from the interpreter structure. Instead, we + * emulate the behavior of Tcl_UnregisterChannel directly here. + */ + + Tcl_DeleteHashEntry(hPtr); + chanPtr->refCount--; + if (chanPtr->refCount <= 0) { + chanPtr->flags |= CHANNEL_CLOSED; + if (!(chanPtr->flags & BG_FLUSH_SCHEDULED)) { + Tcl_Close(interp, (Tcl_Channel) chanPtr); + } + } + } + Tcl_DeleteHashTable(hTblPtr); + ckfree((char *) hTblPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_UnregisterChannel -- + * + * Deletes the hash entry for a channel associated with an interpreter. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Deletes the hash entry for a channel associated with an interpreter. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_UnregisterChannel(interp, chan) + Tcl_Interp *interp; /* Interpreter in which channel is defined. */ + Tcl_Channel chan; /* Channel to delete. */ +{ + Tcl_HashTable *hTblPtr; /* Hash table of channels. */ + Tcl_HashEntry *hPtr; /* Search variable. */ + Channel *chanPtr; /* The real IO channel. */ + + chanPtr = (Channel *) chan; + hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclIO", NULL); + if (hTblPtr == (Tcl_HashTable *) NULL) { + return TCL_OK; + } + hPtr = Tcl_FindHashEntry(hTblPtr, chanPtr->channelName); + if (hPtr == (Tcl_HashEntry *) NULL) { + return TCL_OK; + } + if ((Channel *) Tcl_GetHashValue(hPtr) != chanPtr) { + return TCL_OK; + } + Tcl_DeleteHashEntry(hPtr); + chanPtr->refCount--; + if (chanPtr->refCount <= 0) { + chanPtr->flags |= CHANNEL_CLOSED; + if (!(chanPtr->flags & BG_FLUSH_SCHEDULED)) { + if (Tcl_Close(interp, chan) != TCL_OK) { + return TCL_ERROR; + } + } + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_RegisterChannel -- + * + * Adds an already-open channel to the channel table of an interpreter. + * + * Results: + * None. + * + * Side effects: + * May increment the reference count of a channel. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_RegisterChannel(interp, chan) + Tcl_Interp *interp; /* Interpreter in which to add the channel. */ + Tcl_Channel chan; /* The channel to add to this interpreter + * channel table. */ +{ + Tcl_HashTable *hTblPtr; /* Hash table of channels. */ + Tcl_HashEntry *hPtr; /* Search variable. */ + int new; /* Is the hash entry new or does it exist? */ + Channel *chanPtr; /* The actual channel. */ + + chanPtr = (Channel *) chan; + + if (chanPtr->channelName == (char *) NULL) { + panic("Tcl_RegisterChannel: channel without name"); + } + hTblPtr = GetChannelTable(interp); + hPtr = Tcl_CreateHashEntry(hTblPtr, chanPtr->channelName, &new); + if (new == 0) { + if (chan == (Tcl_Channel) Tcl_GetHashValue(hPtr)) { + return; + } + panic("Tcl_RegisterChannel: duplicate channel names"); + } + Tcl_SetHashValue(hPtr, (ClientData) chanPtr); + chanPtr->refCount++; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetChannel -- + * + * Finds an existing Tcl_Channel structure by name in a given + * interpreter. This function is public because it is used by + * channel-type-specific functions. + * + * Results: + * A Tcl_Channel or NULL on failure. If failed, interp->result + * contains an error message. It also returns, in modePtr, the + * modes in which the channel is opened. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_Channel +Tcl_GetChannel(interp, chanName, modePtr) + Tcl_Interp *interp; /* Interpreter in which to find or create + * the channel. */ + char *chanName; /* The name of the channel. */ + int *modePtr; /* Where to store the mode in which the + * channel was opened? Will contain an ORed + * combination of TCL_READABLE and + * TCL_WRITABLE, if non-NULL. */ +{ + Channel *chanPtr; /* The actual channel. */ + Tcl_HashTable *hTblPtr; /* Hash table of channels. */ + Tcl_HashEntry *hPtr; /* Search variable. */ + char *name; /* Translated name. */ + + /* + * Substitute "stdin", etc. Note that even though we immediately + * find the channel using Tcl_GetStdChannel, we still need to look + * it up in the specified interpreter to ensure that it is present + * in the channel table. Otherwise, safe interpreters would always + * have access to the standard channels. + */ + + name = chanName; + if ((chanName[0] == 's') && (chanName[1] == 't')) { + chanPtr = NULL; + if (strcmp(chanName, "stdin") == 0) { + chanPtr = (Channel *)Tcl_GetStdChannel(TCL_STDIN); + } else if (strcmp(chanName, "stdout") == 0) { + chanPtr = (Channel *)Tcl_GetStdChannel(TCL_STDOUT); + } else if (strcmp(chanName, "stderr") == 0) { + chanPtr = (Channel *)Tcl_GetStdChannel(TCL_STDERR); + } + if (chanPtr != NULL) { + name = chanPtr->channelName; + } + } + + hTblPtr = GetChannelTable(interp); + hPtr = Tcl_FindHashEntry(hTblPtr, name); + if (hPtr == (Tcl_HashEntry *) NULL) { + Tcl_AppendResult(interp, "can not find channel named \"", + chanName, "\"", (char *) NULL); + return NULL; + } + + chanPtr = (Channel *) Tcl_GetHashValue(hPtr); + if (modePtr != NULL) { + *modePtr = (chanPtr->flags & (TCL_READABLE|TCL_WRITABLE)); + } + + return (Tcl_Channel) chanPtr; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CreateChannel -- + * + * Creates a new entry in the hash table for a Tcl_Channel + * record. + * + * Results: + * Returns the new Tcl_Channel. + * + * Side effects: + * Creates a new Tcl_Channel instance and inserts it into the + * hash table. + * + *---------------------------------------------------------------------- + */ + +Tcl_Channel +Tcl_CreateChannel(typePtr, chanName, inFile, outFile, instanceData) + Tcl_ChannelType *typePtr; /* The channel type record. */ + char *chanName; /* Name of channel to record. */ + Tcl_File inFile; /* File to use for input, or NULL. */ + Tcl_File outFile; /* File to use for output, or NULL. */ + ClientData instanceData; /* Instance specific data. */ +{ + Channel *chanPtr; /* The channel structure newly created. */ + + chanPtr = (Channel *) ckalloc((unsigned) sizeof(Channel)); + + if (chanName != (char *) NULL) { + chanPtr->channelName = ckalloc((unsigned) (strlen(chanName) + 1)); + strcpy(chanPtr->channelName, chanName); + } else { + panic("Tcl_CreateChannel: NULL channel name"); + } + + chanPtr->flags = 0; + if (inFile != (Tcl_File) NULL) { + chanPtr->flags |= TCL_READABLE; + } + if (outFile != (Tcl_File) NULL) { + chanPtr->flags |= TCL_WRITABLE; + } + + /* + * Set the channel up initially in AUTO input translation mode to + * accept "\n", "\r" and "\r\n". Output translation mode is set to + * a platform specific default value. The eofChar is set to 0 for both + * input and output, so that Tcl does not look for an in-file EOF + * indicator (e.g. ^Z) and does not append an EOF indicator to files. + */ + + chanPtr->inputTranslation = TCL_TRANSLATE_AUTO; + chanPtr->outputTranslation = TCL_PLATFORM_TRANSLATION; + chanPtr->inEofChar = 0; + chanPtr->outEofChar = 0; + + chanPtr->unreportedError = 0; + chanPtr->instanceData = instanceData; + chanPtr->inFile = inFile; + chanPtr->outFile = outFile; + chanPtr->typePtr = typePtr; + chanPtr->refCount = 0; + chanPtr->closeCbPtr = (CloseCallback *) NULL; + chanPtr->curOutPtr = (ChannelBuffer *) NULL; + chanPtr->outQueueHead = (ChannelBuffer *) NULL; + chanPtr->outQueueTail = (ChannelBuffer *) NULL; + chanPtr->saveInBufPtr = (ChannelBuffer *) NULL; + chanPtr->inQueueHead = (ChannelBuffer *) NULL; + chanPtr->inQueueTail = (ChannelBuffer *) NULL; + chanPtr->chPtr = (ChannelHandler *) NULL; + chanPtr->interestMask = 0; + chanPtr->scriptRecordPtr = (EventScriptRecord *) NULL; + chanPtr->bufSize = CHANNELBUFFER_DEFAULT_SIZE; + + /* + * Link the channel into the list of all channels; create an on-exit + * handler if there is not one already, to close off all the channels + * in the list on exit. + */ + + chanPtr->nextChanPtr = firstChanPtr; + firstChanPtr = chanPtr; + + if (!channelExitHandlerCreated) { + channelExitHandlerCreated = 1; + Tcl_CreateExitHandler(CloseChannelsOnExit, (ClientData) NULL); + } + + /* + * Install this channel in the first empty standard channel slot. + */ + + if (Tcl_GetStdChannel(TCL_STDIN) == NULL) { + Tcl_SetStdChannel((Tcl_Channel)chanPtr, TCL_STDIN); + } else if (Tcl_GetStdChannel(TCL_STDOUT) == NULL) { + Tcl_SetStdChannel((Tcl_Channel)chanPtr, TCL_STDOUT); + } else if (Tcl_GetStdChannel(TCL_STDERR) == NULL) { + Tcl_SetStdChannel((Tcl_Channel)chanPtr, TCL_STDERR); + } + + return (Tcl_Channel) chanPtr; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetChannelName -- + * + * Returns the string identifying the channel name. + * + * Results: + * The string containing the channel name. This memory is + * owned by the generic layer and should not be modified by + * the caller. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_GetChannelName(chan) + Tcl_Channel chan; /* The channel for which to return the name. */ +{ + Channel *chanPtr; /* The actual channel. */ + + chanPtr = (Channel *) chan; + return chanPtr->channelName; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetChannelType -- + * + * Given a channel structure, returns the channel type structure. + * + * Results: + * Returns a pointer to the channel type structure. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_ChannelType * +Tcl_GetChannelType(chan) + Tcl_Channel chan; /* The channel to return type for. */ +{ + Channel *chanPtr; /* The actual channel. */ + + chanPtr = (Channel *) chan; + return chanPtr->typePtr; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetChannelFile -- + * + * Returns a file associated with a channel. + * + * Results: + * The file or NULL if failed (e.g. the channel is not open for the + * requested direction). + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_File +Tcl_GetChannelFile(chan, direction) + Tcl_Channel chan; /* The channel to get file from. */ + int direction; /* TCL_WRITABLE or TCL_READABLE. */ +{ + Channel *chanPtr; /* The actual channel. */ + + chanPtr = (Channel *) chan; + switch (direction) { + case TCL_WRITABLE: + return chanPtr->outFile; + case TCL_READABLE: + return chanPtr->inFile; + default: + return NULL; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetChannelInstanceData -- + * + * Returns the client data associated with a channel. + * + * Results: + * The client data. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +ClientData +Tcl_GetChannelInstanceData(chan) + Tcl_Channel chan; /* Channel for which to return client data. */ +{ + Channel *chanPtr; /* The actual channel. */ + + chanPtr = (Channel *) chan; + return chanPtr->instanceData; +} + +/* + *---------------------------------------------------------------------- + * + * RecycleBuffer -- + * + * Helper function to recycle input and output buffers. Ensures + * that two input buffers are saved (one in the input queue and + * another in the saveInBufPtr field) and that curOutPtr is set + * to a buffer. Only if these conditions are met is the buffer + * freed to the OS. + * + * Results: + * None. + * + * Side effects: + * May free a buffer to the OS. + * + *---------------------------------------------------------------------- + */ + +static void +RecycleBuffer(chanPtr, bufPtr, mustDiscard) + Channel *chanPtr; /* Channel for which to recycle buffers. */ + ChannelBuffer *bufPtr; /* The buffer to recycle. */ + int mustDiscard; /* If nonzero, free the buffer to the + * OS, always. */ +{ + /* + * Do we have to free the buffer to the OS? + */ + + if (mustDiscard) { + ckfree((char *) bufPtr); + return; + } + + /* + * Only save buffers for the input queue if the channel is readable. + */ + + if (chanPtr->flags & TCL_READABLE) { + if (chanPtr->inQueueHead == (ChannelBuffer *) NULL) { + chanPtr->inQueueHead = bufPtr; + chanPtr->inQueueTail = bufPtr; + goto keepit; + } + if (chanPtr->saveInBufPtr == (ChannelBuffer *) NULL) { + chanPtr->saveInBufPtr = bufPtr; + goto keepit; + } + } + + /* + * Only save buffers for the output queue if the channel is writable. + */ + + if (chanPtr->flags & TCL_WRITABLE) { + if (chanPtr->curOutPtr == (ChannelBuffer *) NULL) { + chanPtr->curOutPtr = bufPtr; + goto keepit; + } + } + + /* + * If we reached this code we return the buffer to the OS. + */ + + ckfree((char *) bufPtr); + return; + +keepit: + bufPtr->nextRemoved = 0; + bufPtr->nextAdded = 0; + bufPtr->nextPtr = (ChannelBuffer *) NULL; +} + +/* + *---------------------------------------------------------------------- + * + * DiscardOutputQueued -- + * + * Discards all output queued in the output queue of a channel. + * + * Results: + * None. + * + * Side effects: + * Recycles buffers. + * + *---------------------------------------------------------------------- + */ + +static void +DiscardOutputQueued(chanPtr) + Channel *chanPtr; /* The channel for which to discard output. */ +{ + ChannelBuffer *bufPtr; + + while (chanPtr->outQueueHead != (ChannelBuffer *) NULL) { + bufPtr = chanPtr->outQueueHead; + chanPtr->outQueueHead = bufPtr->nextPtr; + RecycleBuffer(chanPtr, bufPtr, 0); + } + chanPtr->outQueueHead = (ChannelBuffer *) NULL; + chanPtr->outQueueTail = (ChannelBuffer *) NULL; +} + +/* + *---------------------------------------------------------------------- + * + * FlushChannel -- + * + * This function flushes as much of the queued output as is possible + * now. If calledFromAsyncFlush is nonzero, it is being called in an + * event handler to flush channel output asynchronously. + * + * Results: + * 0 if successful, else the error code that was returned by the + * channel type operation. + * + * Side effects: + * May produce output on a channel. May block indefinitely if the + * channel is synchronous. May schedule an async flush on the channel. + * May recycle memory for buffers in the output queue. + * + *---------------------------------------------------------------------- + */ + +static int +FlushChannel(interp, chanPtr, calledFromAsyncFlush) + Tcl_Interp *interp; /* For error reporting during close. */ + Channel *chanPtr; /* The channel to flush on. */ + int calledFromAsyncFlush; /* If nonzero then we are being + * called from an asynchronous + * flush callback. */ +{ + ChannelBuffer *bufPtr; /* Iterates over buffered output + * queue. */ + int toWrite; /* Amount of output data in current + * buffer available to be written. */ + int written; /* Amount of output data actually + * written in current round. */ + int errorCode; /* Stores POSIX error codes from + * channel driver operations. */ + + errorCode = 0; + + /* + * Loop over the queued buffers and attempt to flush as + * much as possible of the queued output to the channel. + */ + + while (1) { + + /* + * If the queue is empty and there is a ready current buffer, OR if + * the current buffer is full, then move the current buffer to the + * queue. + */ + + if (((chanPtr->curOutPtr != (ChannelBuffer *) NULL) && + (chanPtr->curOutPtr->nextAdded == chanPtr->curOutPtr->bufSize)) + || ((chanPtr->flags & BUFFER_READY) && + (chanPtr->outQueueHead == (ChannelBuffer *) NULL))) { + chanPtr->flags &= (~(BUFFER_READY)); + chanPtr->curOutPtr->nextPtr = (ChannelBuffer *) NULL; + if (chanPtr->outQueueHead == (ChannelBuffer *) NULL) { + chanPtr->outQueueHead = chanPtr->curOutPtr; + } else { + chanPtr->outQueueTail->nextPtr = chanPtr->curOutPtr; + } + chanPtr->outQueueTail = chanPtr->curOutPtr; + chanPtr->curOutPtr = (ChannelBuffer *) NULL; + } + bufPtr = chanPtr->outQueueHead; + + /* + * If we are not being called from an async flush and an async + * flush is active, we just return without producing any output. + */ + + if ((!calledFromAsyncFlush) && + (chanPtr->flags & BG_FLUSH_SCHEDULED)) { + return 0; + } + + /* + * If the output queue is still empty, break out of the while loop. + */ + + if (bufPtr == (ChannelBuffer *) NULL) { + break; /* Out of the "while (1)". */ + } + + /* + * Produce the output on the channel. + */ + + toWrite = bufPtr->nextAdded - bufPtr->nextRemoved; + written = (chanPtr->typePtr->outputProc) (chanPtr->instanceData, + chanPtr->outFile, bufPtr->buf + bufPtr->nextRemoved, + toWrite, &errorCode); + + /* + * If the write failed completely attempt to start the asynchronous + * flush mechanism and break out of this loop - do not attempt to + * write any more output at this time. + */ + + if (written < 0) { + + /* + * If the last attempt to write was interrupted, simply retry. + */ + + if (errorCode == EINTR) { + continue; + } + + /* + * If we would have blocked, attempt to set up an asynchronous + * background flushing for this channel if the channel is + * nonblocking, or block until more output can be written if + * the channel is blocking. + */ + + if ((errorCode == EWOULDBLOCK) || (errorCode == EAGAIN)) { + if (chanPtr->flags & CHANNEL_NONBLOCKING) { + if (!(chanPtr->flags & BG_FLUSH_SCHEDULED)) { + Tcl_CreateFileHandler(chanPtr->outFile, + TCL_WRITABLE, FlushEventProc, + (ClientData) chanPtr); + } + chanPtr->flags |= BG_FLUSH_SCHEDULED; + errorCode = 0; + break; /* Out of the "while (1)" loop. */ + } else { + + /* + * If the device driver did not emulate blocking behavior + * then we must do it it here. + */ + + TclWaitForFile(chanPtr->outFile, TCL_WRITABLE, -1); + continue; + } + } + + /* + * Decide whether to report the error upwards or defer it. If + * we got an error during async flush we discard all queued + * output. + */ + + if (calledFromAsyncFlush) { + if (chanPtr->unreportedError == 0) { + chanPtr->unreportedError = errorCode; + } + } else { + Tcl_SetErrno(errorCode); + } + + /* + * When we get an error we throw away all the output + * currently queued. + */ + + DiscardOutputQueued(chanPtr); + continue; + } + + bufPtr->nextRemoved += written; + + /* + * If this buffer is now empty, recycle it. + */ + + if (bufPtr->nextRemoved == bufPtr->nextAdded) { + chanPtr->outQueueHead = bufPtr->nextPtr; + if (chanPtr->outQueueHead == (ChannelBuffer *) NULL) { + chanPtr->outQueueTail = (ChannelBuffer *) NULL; + } + RecycleBuffer(chanPtr, bufPtr, 0); + } + } /* Closes "while (1)". */ + + /* + * If the queue became empty and we have an asynchronous flushing + * mechanism active, cancel the asynchronous flushing. + */ + + if ((chanPtr->outQueueHead == (ChannelBuffer *) NULL) && + (chanPtr->flags & BG_FLUSH_SCHEDULED)) { + chanPtr->flags &= (~(BG_FLUSH_SCHEDULED)); + if (chanPtr->outFile != (Tcl_File) NULL) { + Tcl_DeleteFileHandler(chanPtr->outFile); + } + } + + /* + * If the channel is flagged as closed, delete it when the refcount + * drops to zero, the output queue is empty and there is no output + * in the current output buffer. + */ + + if ((chanPtr->flags & CHANNEL_CLOSED) && (chanPtr->refCount <= 0) && + (chanPtr->outQueueHead == (ChannelBuffer *) NULL) && + ((chanPtr->curOutPtr == (ChannelBuffer *) NULL) || + (chanPtr->curOutPtr->nextAdded == + chanPtr->curOutPtr->nextRemoved))) { + return CloseChannel(interp, chanPtr, errorCode); + } + return errorCode; +} + +/* + *---------------------------------------------------------------------- + * + * CloseChannel -- + * + * Utility procedure to close a channel and free its associated + * resources. + * + * Results: + * 0 on success or a POSIX error code if the operation failed. + * + * Side effects: + * May close the actual channel; may free memory. + * + *---------------------------------------------------------------------- + */ + +static int +CloseChannel(interp, chanPtr, errorCode) + Tcl_Interp *interp; /* For error reporting. */ + Channel *chanPtr; /* The channel to close. */ + int errorCode; /* Status of operation so far. */ +{ + int result; /* Of calling driver close + * operation. */ + Channel *prevChanPtr; /* Preceding channel in list of + * all channels - used to splice a + * channel out of the list on close. */ + + /* + * No more input can be consumed so discard any leftover input. + */ + + DiscardInputQueued(chanPtr, 1); + + /* + * Discard a leftover buffer in the current output buffer field. + */ + + if (chanPtr->curOutPtr != (ChannelBuffer *) NULL) { + ckfree((char *) chanPtr->curOutPtr); + chanPtr->curOutPtr = (ChannelBuffer *) NULL; + } + + /* + * The caller guarantees that there are no more buffers + * queued for output. + */ + + if (chanPtr->outQueueHead != (ChannelBuffer *) NULL) { + panic("TclFlush, closed channel: queued output left"); + } + + /* + * If the EOF character is set in the channel, append that to the + * output device. + */ + + if ((chanPtr->outEofChar != 0) && (chanPtr->outFile != NULL)) { + int dummy; + char c; + + c = (char) chanPtr->outEofChar; + (chanPtr->typePtr->outputProc) (chanPtr->instanceData, + chanPtr->outFile, &c, 1, &dummy); + } + + /* + * Remove TCL_READABLE and TCL_WRITABLE from chanPtr->flags, so + * that close callbacks can not do input or output (assuming they + * squirreled the channel away in their clientData). This also + * prevents infinite loops if the callback calls any C API that + * could call FlushChannel. + */ + + chanPtr->flags &= (~(TCL_READABLE|TCL_WRITABLE)); + + /* + * Splice this channel out of the list of all channels. + */ + + if (chanPtr == firstChanPtr) { + firstChanPtr = chanPtr->nextChanPtr; + } else { + for (prevChanPtr = firstChanPtr; + (prevChanPtr != (Channel *) NULL) && + (prevChanPtr->nextChanPtr != chanPtr); + prevChanPtr = prevChanPtr->nextChanPtr) { + /* Empty loop body. */ + } + if (prevChanPtr == (Channel *) NULL) { + panic("FlushChannel: damaged channel list"); + } + prevChanPtr->nextChanPtr = chanPtr->nextChanPtr; + } + + if (chanPtr->channelName != (char *) NULL) { + ckfree(chanPtr->channelName); + } + + /* + * OK, close the channel itself. + */ + + result = (chanPtr->typePtr->closeProc) (chanPtr->instanceData, interp, + chanPtr->inFile, chanPtr->outFile); + + /* + * If we are being called synchronously, report either + * any latent error on the channel or the current error. + */ + + if (chanPtr->unreportedError != 0) { + errorCode = chanPtr->unreportedError; + } + if (errorCode == 0) { + errorCode = result; + if (errorCode != 0) { + Tcl_SetErrno(errorCode); + } + } + + Tcl_EventuallyFree((ClientData) chanPtr, TCL_DYNAMIC); + + return errorCode; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_Close -- + * + * Closes a channel. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Closes the channel if this is the last reference. + * + * NOTE: + * Tcl_Close removes the channel as far as the user is concerned. + * However, it may continue to exist for a while longer if it has + * a background flush scheduled. The device itself is eventually + * closed and the channel record removed, in CloseChannel, above. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_Close(interp, chan) + Tcl_Interp *interp; /* Interpreter for errors. */ + Tcl_Channel chan; /* The channel being closed. Must + * not be referenced in any + * interpreter. */ +{ + ChannelHandler *chPtr, *chNext; /* Iterate over channel handlers. */ + CloseCallback *cbPtr; /* Iterate over close callbacks + * for this channel. */ + EventScriptRecord *ePtr, *eNextPtr; /* Iterate over eventscript records. */ + Channel *chanPtr; /* The real IO channel. */ + int result; /* Of calling FlushChannel. */ + + chanPtr = (Channel *) chan; + + if (chanPtr->refCount > 0) { + panic("called Tcl_Close on channel with refcount > 0"); + } + + /* + * Remove the channel from the standard channel table. + */ + + if (Tcl_GetStdChannel(TCL_STDIN) == chan) { + Tcl_SetStdChannel(NULL, TCL_STDIN); + } else if (Tcl_GetStdChannel(TCL_STDOUT) == chan) { + Tcl_SetStdChannel(NULL, TCL_STDOUT); + } else if (Tcl_GetStdChannel(TCL_STDERR) == chan) { + Tcl_SetStdChannel(NULL, TCL_STDERR); + } + + /* + * Remove all the channel handler records attached to the channel + * itself. + */ + + for (chPtr = chanPtr->chPtr; + chPtr != (ChannelHandler *) NULL; + chPtr = chNext) { + chNext = chPtr->nextPtr; + ckfree((char *) chPtr); + } + chanPtr->chPtr = (ChannelHandler *) NULL; + + /* + * Must set the interest mask now to 0, otherwise infinite loops + * will occur if Tcl_DoOneEvent is called before the channel is + * finally deleted in FlushChannel. This can happen if the channel + * has a background flush active. + */ + + chanPtr->interestMask = 0; + + /* + * Remove any EventScript records for this channel. + */ + + for (ePtr = chanPtr->scriptRecordPtr; + ePtr != (EventScriptRecord *) NULL; + ePtr = eNextPtr) { + eNextPtr = ePtr->nextPtr; + Tcl_EventuallyFree((ClientData)ePtr->script, TCL_DYNAMIC); + ckfree((char *) ePtr); + } + chanPtr->scriptRecordPtr = (EventScriptRecord *) NULL; + + /* + * Invoke the registered close callbacks and delete their records. + */ + + while (chanPtr->closeCbPtr != (CloseCallback *) NULL) { + cbPtr = chanPtr->closeCbPtr; + chanPtr->closeCbPtr = cbPtr->nextPtr; + (cbPtr->proc) (cbPtr->clientData); + ckfree((char *) cbPtr); + } + + /* + * And remove any events for this channel from the event queue. + */ + + Tcl_DeleteEvents(ChannelEventDeleteProc, (ClientData) chanPtr); + + /* + * Ensure that the last output buffer will be flushed. + */ + + if ((chanPtr->curOutPtr != (ChannelBuffer *) NULL) && + (chanPtr->curOutPtr->nextAdded > chanPtr->curOutPtr->nextRemoved)) { + chanPtr->flags |= BUFFER_READY; + } + + /* + * The call to FlushChannel will flush any queued output and invoke + * the close function of the channel driver, or it will set up the + * channel to be flushed and closed asynchronously. + */ + + chanPtr->flags |= CHANNEL_CLOSED; + result = FlushChannel(interp, chanPtr, 0); + if (result != 0) { + return TCL_ERROR; + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ChannelEventDeleteProc -- + * + * This procedure returns 1 if the event passed in is for the + * channel passed in as the second argument. This procedure is + * used as a filter for events to delete in a call to + * Tcl_DeleteEvents in CloseChannel. + * + * Results: + * 1 if matching, 0 otherwise. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +ChannelEventDeleteProc(evPtr, clientData) + Tcl_Event *evPtr; /* The event to check for a match. */ + ClientData clientData; /* The channel to check for. */ +{ + ChannelHandlerEvent *cEvPtr; + Channel *chanPtr; + + if (evPtr->proc != ChannelHandlerEventProc) { + return 0; + } + cEvPtr = (ChannelHandlerEvent *) evPtr; + chanPtr = (Channel *) clientData; + if (cEvPtr->chanPtr != chanPtr) { + return 0; + } + return 1; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_Write -- + * + * Puts a sequence of characters into an output buffer, may queue the + * buffer for output if it gets full, and also remembers whether the + * current buffer is ready e.g. if it contains a newline and we are in + * line buffering mode. + * + * Results: + * The number of bytes written or -1 in case of error. If -1, + * Tcl_GetErrno will return the error code. + * + * Side effects: + * May buffer up output and may cause output to be produced on the + * channel. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_Write(chan, srcPtr, slen) + Tcl_Channel chan; /* The channel to buffer output for. */ + char *srcPtr; /* Output to buffer. */ + int slen; /* Its length. Negative means + * the output is null terminated + * and we must compute its length. */ +{ + Channel *chanPtr; /* The actual channel. */ + ChannelBuffer *outBufPtr; /* Current output buffer. */ + int foundNewline; /* Did we find a newline in output? */ + char *dPtr, *sPtr; /* Search variables for newline. */ + int crsent; /* In CRLF eol translation mode, + * remember the fact that a CR was + * output to the channel without + * its following NL. */ + int i; /* Loop index for newline search. */ + int destCopied; /* How many bytes were used in this + * destination buffer to hold the + * output? */ + int totalDestCopied; /* How many bytes total were + * copied to the channel buffer? */ + int srcCopied; /* How many bytes were copied from + * the source string? */ + char *destPtr; /* Where in line to copy to? */ + + chanPtr = (Channel *) chan; + + /* + * Check for unreported error. + */ + + if (chanPtr->unreportedError != 0) { + Tcl_SetErrno(chanPtr->unreportedError); + chanPtr->unreportedError = 0; + return -1; + } + + /* + * If the channel is not open for writing punt. + */ + + if (!(chanPtr->flags & TCL_WRITABLE)) { + Tcl_SetErrno(EACCES); + return -1; + } + + /* + * If length passed is negative, assume that the output is null terminated + * and compute its length. + */ + + if (slen < 0) { + slen = strlen(srcPtr); + } + + /* + * If we are in network (or windows) translation mode, record the fact + * that we have not yet sent a CR to the channel. + */ + + crsent = 0; + + /* + * Loop filling buffers and flushing them until all output has been + * consumed. + */ + + srcCopied = 0; + totalDestCopied = 0; + + while (slen > 0) { + + /* + * Make sure there is a current output buffer to accept output. + */ + + if (chanPtr->curOutPtr == (ChannelBuffer *) NULL) { + chanPtr->curOutPtr = (ChannelBuffer *) ckalloc((unsigned) + (CHANNELBUFFER_HEADER_SIZE + chanPtr->bufSize)); + chanPtr->curOutPtr->nextAdded = 0; + chanPtr->curOutPtr->nextRemoved = 0; + chanPtr->curOutPtr->bufSize = chanPtr->bufSize; + chanPtr->curOutPtr->nextPtr = (ChannelBuffer *) NULL; + } + + outBufPtr = chanPtr->curOutPtr; + + destCopied = outBufPtr->bufSize - outBufPtr->nextAdded; + if (destCopied > slen) { + destCopied = slen; + } + + destPtr = outBufPtr->buf + outBufPtr->nextAdded; + switch (chanPtr->outputTranslation) { + case TCL_TRANSLATE_LF: + srcCopied = destCopied; + memcpy((VOID *) destPtr, (VOID *) srcPtr, (size_t) destCopied); + break; + case TCL_TRANSLATE_CR: + srcCopied = destCopied; + memcpy((VOID *) destPtr, (VOID *) srcPtr, (size_t) destCopied); + for (dPtr = destPtr; dPtr < destPtr + destCopied; dPtr++) { + if (*dPtr == '\n') { + *dPtr = '\r'; + } + } + break; + case TCL_TRANSLATE_CRLF: + for (srcCopied = 0, dPtr = destPtr, sPtr = srcPtr; + dPtr < destPtr + destCopied; + dPtr++, sPtr++, srcCopied++) { + if (*sPtr == '\n') { + if (crsent) { + *dPtr = '\n'; + crsent = 0; + } else { + *dPtr = '\r'; + crsent = 1; + sPtr--, srcCopied--; + } + } else { + *dPtr = *sPtr; + } + } + break; + case TCL_TRANSLATE_AUTO: + panic("Tcl_Write: AUTO output translation mode not supported"); + default: + panic("Tcl_Write: unknown output translation mode"); + } + + /* + * The current buffer is ready for output if it is full, or if it + * contains a newline and this channel is line-buffered, or if it + * contains any output and this channel is unbuffered. + */ + + outBufPtr->nextAdded += destCopied; + if (!(chanPtr->flags & BUFFER_READY)) { + if (outBufPtr->nextAdded == outBufPtr->bufSize) { + chanPtr->flags |= BUFFER_READY; + } else if (chanPtr->flags & CHANNEL_LINEBUFFERED) { + for (sPtr = srcPtr, i = 0, foundNewline = 0; + (i < srcCopied) && (!foundNewline); + i++, sPtr++) { + if (*sPtr == '\n') { + foundNewline = 1; + break; + } + } + if (foundNewline) { + chanPtr->flags |= BUFFER_READY; + } + } else if (chanPtr->flags & CHANNEL_UNBUFFERED) { + chanPtr->flags |= BUFFER_READY; + } + } + + totalDestCopied += srcCopied; + srcPtr += srcCopied; + slen -= srcCopied; + + if (chanPtr->flags & BUFFER_READY) { + if (FlushChannel(NULL, chanPtr, 0) != 0) { + return -1; + } + } + } /* Closes "while" */ + + return totalDestCopied; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_Flush -- + * + * Flushes output data on a channel. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * May flush output queued on this channel. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_Flush(chan) + Tcl_Channel chan; /* The Channel to flush. */ +{ + int result; /* Of calling FlushChannel. */ + Channel *chanPtr; /* The actual channel. */ + + chanPtr = (Channel *) chan; + + /* + * Check for unreported error. + */ + + if (chanPtr->unreportedError != 0) { + Tcl_SetErrno(chanPtr->unreportedError); + chanPtr->unreportedError = 0; + return TCL_ERROR; + } + + /* + * If the channel is not open for writing punt. + */ + + if (!(chanPtr->flags & TCL_WRITABLE)) { + Tcl_SetErrno(EACCES); + return TCL_ERROR; + } + + /* + * Force current output buffer to be output also. + */ + + if ((chanPtr->curOutPtr != (ChannelBuffer *) NULL) && + (chanPtr->curOutPtr->nextAdded > 0)) { + chanPtr->flags |= BUFFER_READY; + } + + result = FlushChannel(NULL, chanPtr, 0); + if (result != 0) { + return TCL_ERROR; + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * DiscardInputQueued -- + * + * Discards any input read from the channel but not yet consumed + * by Tcl reading commands. + * + * Results: + * None. + * + * Side effects: + * May discard input from the channel. If discardLastBuffer is zero, + * leaves one buffer in place for back-filling. + * + *---------------------------------------------------------------------- + */ + +static void +DiscardInputQueued(chanPtr, discardSavedBuffers) + Channel *chanPtr; /* Channel on which to discard + * the queued input. */ + int discardSavedBuffers; /* If non-zero, discard all buffers including + * last one. */ +{ + ChannelBuffer *bufPtr, *nxtPtr; /* Loop variables. */ + + bufPtr = chanPtr->inQueueHead; + chanPtr->inQueueHead = (ChannelBuffer *) NULL; + chanPtr->inQueueTail = (ChannelBuffer *) NULL; + for (; bufPtr != (ChannelBuffer *) NULL; bufPtr = nxtPtr) { + nxtPtr = bufPtr->nextPtr; + RecycleBuffer(chanPtr, bufPtr, discardSavedBuffers); + } + + /* + * If discardSavedBuffers is nonzero, must also discard any previously + * saved buffer in the saveInBufPtr field. + */ + + if (discardSavedBuffers) { + if (chanPtr->saveInBufPtr != (ChannelBuffer *) NULL) { + ckfree((char *) chanPtr->saveInBufPtr); + chanPtr->saveInBufPtr = (ChannelBuffer *) NULL; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * GetInput -- + * + * Reads input data from a device or file into an input buffer. + * + * Results: + * A Posix error code or 0. + * + * Side effects: + * Reads from the underlying device. + * + *---------------------------------------------------------------------- + */ + +static int +GetInput(chanPtr) + Channel *chanPtr; /* Channel to read input from. */ +{ + int toRead; /* How much to read? */ + int result; /* Of calling driver. */ + int nread; /* How much was read from channel? */ + ChannelBuffer *bufPtr; /* New buffer to add to input queue. */ + + /* + * See if we can fill an existing buffer. If we can, read only + * as much as will fit in it. Otherwise allocate a new buffer, + * add it to the input queue and attempt to fill it to the max. + */ + + if ((chanPtr->inQueueTail != (ChannelBuffer *) NULL) && + (chanPtr->inQueueTail->nextAdded < chanPtr->inQueueTail->bufSize)) { + bufPtr = chanPtr->inQueueTail; + toRead = bufPtr->bufSize - bufPtr->nextAdded; + } else { + if (chanPtr->saveInBufPtr != (ChannelBuffer *) NULL) { + bufPtr = chanPtr->saveInBufPtr; + chanPtr->saveInBufPtr = (ChannelBuffer *) NULL; + } else { + bufPtr = (ChannelBuffer *) ckalloc( + ((unsigned) CHANNELBUFFER_HEADER_SIZE + chanPtr->bufSize)); + bufPtr->bufSize = chanPtr->bufSize; + } + bufPtr->nextRemoved = 0; + bufPtr->nextAdded = 0; + toRead = bufPtr->bufSize; + if (chanPtr->inQueueTail == (ChannelBuffer *) NULL) { + chanPtr->inQueueHead = bufPtr; + } else { + chanPtr->inQueueTail->nextPtr = bufPtr; + } + chanPtr->inQueueTail = bufPtr; + bufPtr->nextPtr = (ChannelBuffer *) NULL; + } + + while (1) { + + /* + * If EOF is set, we should avoid calling the driver because on some + * platforms it is impossible to read from a device after EOF. + */ + + if (chanPtr->flags & CHANNEL_EOF) { + break; + } + nread = (chanPtr->typePtr->inputProc) (chanPtr->instanceData, + chanPtr->inFile, bufPtr->buf + bufPtr->nextAdded, + toRead, &result); + if (nread == 0) { + chanPtr->flags |= CHANNEL_EOF; + break; + } else if (nread < 0) { + if ((result == EWOULDBLOCK) || (result == EAGAIN)) { + chanPtr->flags |= CHANNEL_BLOCKED; + result = EAGAIN; + if (chanPtr->flags & CHANNEL_NONBLOCKING) { + Tcl_SetErrno(result); + return result; + } else { + + /* + * If the device driver did not emulate blocking behavior + * then we have to do it here. + */ + + TclWaitForFile(chanPtr->inFile, TCL_READABLE, -1); + } + } else { + Tcl_SetErrno(result); + return result; + } + } else { + bufPtr->nextAdded += nread; + + /* + * If we get a short read, signal up that we may be BLOCKED. We + * should avoid calling the driver because on some platforms we + * will block in the low level reading code even though the + * channel is set into nonblocking mode. + */ + + if (nread < toRead) { + chanPtr->flags |= CHANNEL_BLOCKED; + } + break; + } + } + + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * CopyAndTranslateBuffer -- + * + * Copy at most one buffer of input to the result space, doing + * eol translations according to mode in effect currently. + * + * Results: + * Number of characters (as opposed to bytes) copied. May return + * zero if no input is available to be translated. + * + * Side effects: + * Consumes buffered input. May deallocate one buffer. + * + *---------------------------------------------------------------------- + */ + +static int +CopyAndTranslateBuffer(chanPtr, result, space) + Channel *chanPtr; /* The channel from which to read input. */ + char *result; /* Where to store the copied input. */ + int space; /* How many bytes are available in result + * to store the copied input? */ +{ + int bytesInBuffer; /* How many bytes are available to be + * copied in the current input buffer? */ + int copied; /* How many characters were already copied + * into the destination space? */ + ChannelBuffer *bufPtr; /* The buffer from which to copy bytes. */ + char curByte; /* The byte we are currently translating. */ + int i; /* Iterates over the copied input looking + * for the input eofChar. */ + + /* + * If there is no input at all, return zero. The invariant is that either + * there is no buffer in the queue, or if the first buffer is empty, it + * is also the last buffer (and thus there is no input in the queue). + * Note also that if the buffer is empty, we leave it in the queue. + */ + + if (chanPtr->inQueueHead == (ChannelBuffer *) NULL) { + return 0; + } + bufPtr = chanPtr->inQueueHead; + bytesInBuffer = bufPtr->nextAdded - bufPtr->nextRemoved; + if (bytesInBuffer < space) { + space = bytesInBuffer; + } + copied = 0; + switch (chanPtr->inputTranslation) { + case TCL_TRANSLATE_LF: + + if (space == 0) { + return 0; + } + + /* + * Copy the current chunk into the result buffer. + */ + + memcpy((VOID *) result, + (VOID *)(bufPtr->buf + bufPtr->nextRemoved), + (size_t) space); + bufPtr->nextRemoved += space; + copied = space; + break; + + case TCL_TRANSLATE_CR: + + if (space == 0) { + return 0; + } + + /* + * Copy the current chunk into the result buffer, then + * replace all \r with \n. + */ + + memcpy((VOID *) result, + (VOID *)(bufPtr->buf + bufPtr->nextRemoved), + (size_t) space); + bufPtr->nextRemoved += space; + for (copied = 0; copied < space; copied++) { + if (result[copied] == '\r') { + result[copied] = '\n'; + } + } + break; + + case TCL_TRANSLATE_CRLF: + + /* + * If there is a held-back "\r" at EOF, produce it now. + */ + + if (space == 0) { + if ((chanPtr->flags & (INPUT_SAW_CR | CHANNEL_EOF)) == + (INPUT_SAW_CR | CHANNEL_EOF)) { + result[0] = '\r'; + chanPtr->flags &= (~(INPUT_SAW_CR)); + return 1; + } + return 0; + } + + /* + * Copy the current chunk and replace "\r\n" with "\n" + * (but not standalone "\r"!). + */ + + for (copied = 0; + (copied < space) && + (bufPtr->nextRemoved < bufPtr->nextAdded); + copied++) { + curByte = bufPtr->buf[bufPtr->nextRemoved]; + bufPtr->nextRemoved++; + if (curByte == '\r') { + if (chanPtr->flags & INPUT_SAW_CR) { + result[copied] = '\r'; + } else { + chanPtr->flags |= INPUT_SAW_CR; + copied--; + } + } else if (curByte == '\n') { + chanPtr->flags &= (~(INPUT_SAW_CR)); + result[copied] = '\n'; + } else { + if (chanPtr->flags & INPUT_SAW_CR) { + chanPtr->flags &= (~(INPUT_SAW_CR)); + result[copied] = '\r'; + copied++; + } + result[copied] = curByte; + } + } + break; + + case TCL_TRANSLATE_AUTO: + + if (space == 0) { + return 0; + } + + /* + * Loop over the current buffer, converting "\r" and "\r\n" + * to "\n". + */ + + for (copied = 0; + (copied < space) && + (bufPtr->nextRemoved < bufPtr->nextAdded); ) { + curByte = bufPtr->buf[bufPtr->nextRemoved]; + bufPtr->nextRemoved++; + if (curByte == '\r') { + result[copied] = '\n'; + copied++; + if (bufPtr->nextRemoved < bufPtr->nextAdded) { + if (bufPtr->buf[bufPtr->nextRemoved] == '\n') { + bufPtr->nextRemoved++; + } + chanPtr->flags &= (~(INPUT_SAW_CR)); + } else { + chanPtr->flags |= INPUT_SAW_CR; + } + } else { + if (curByte == '\n') { + if (!(chanPtr->flags & INPUT_SAW_CR)) { + result[copied] = '\n'; + copied++; + } + } else { + result[copied] = curByte; + copied++; + } + chanPtr->flags &= (~(INPUT_SAW_CR)); + } + } + break; + + default: + panic("unknown eol translation mode"); + } + + /* + * If an in-stream EOF character is set for this channel,, check that + * the input we copied so far does not contain the EOF char. If it does, + * copy only up to and excluding that character. + */ + + if (chanPtr->inEofChar != 0) { + for (i = 0; i < copied; i++) { + if (result[i] == (char) chanPtr->inEofChar) { + break; + } + } + if (i < copied) { + + /* + * Set sticky EOF so that no further input is presented + * to the caller. + */ + + chanPtr->flags |= (CHANNEL_EOF | CHANNEL_STICKY_EOF); + + /* + * Reset the start of valid data in the input buffer to the + * position of the eofChar, so that subsequent reads will + * encounter it immediately. First we set it to the position + * of the last byte consumed if all result bytes were the + * product of one input byte; since it is possible that "\r\n" + * contracted to "\n" in the result, we have to search back + * from that position until we find the eofChar, because it + * is possible that its actual position in the buffer is n + * bytes further back (n is the number of "\r\n" sequences + * that were contracted to "\n" in the result). + */ + + bufPtr->nextRemoved -= (copied - i); + while ((bufPtr->nextRemoved > 0) && + (bufPtr->buf[bufPtr->nextRemoved] != + (char) chanPtr->inEofChar)) { + bufPtr->nextRemoved--; + } + copied = i; + } + } + + /* + * If the current buffer is empty recycle it. + */ + + if (bufPtr->nextRemoved == bufPtr->nextAdded) { + chanPtr->inQueueHead = bufPtr->nextPtr; + if (chanPtr->inQueueHead == (ChannelBuffer *) NULL) { + chanPtr->inQueueTail = (ChannelBuffer *) NULL; + } + RecycleBuffer(chanPtr, bufPtr, 0); + } + + /* + * Return the number of characters copied into the result buffer. + * This may be different from the number of bytes consumed, because + * of EOL translations. + */ + + return copied; +} + +/* + *---------------------------------------------------------------------- + * + * ScanBufferForEOL -- + * + * Scans one buffer for EOL according to the specified EOL + * translation mode. If it sees the input eofChar for the channel + * it stops also. + * + * Results: + * TRUE if EOL is found, FALSE otherwise. Also sets output parameter + * bytesToEOLPtr to the number of bytes so far to EOL, and crSeenPtr + * to whether a "\r" was seen. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +ScanBufferForEOL(chanPtr, bufPtr, translation, eofChar, bytesToEOLPtr, + crSeenPtr) + Channel *chanPtr; + ChannelBuffer *bufPtr; /* Buffer to scan for EOL. */ + Tcl_EolTranslation translation; /* Translation mode to use. */ + int eofChar; /* EOF char to look for. */ + int *bytesToEOLPtr; /* Running counter. */ + int *crSeenPtr; /* Has "\r" been seen? */ +{ + char *rPtr; /* Iterates over input string. */ + char *sPtr; /* Where to stop search? */ + int EOLFound; + int bytesToEOL; + + for (EOLFound = 0, rPtr = bufPtr->buf + bufPtr->nextRemoved, + sPtr = bufPtr->buf + bufPtr->nextAdded, + bytesToEOL = *bytesToEOLPtr; + (!EOLFound) && (rPtr < sPtr); + rPtr++) { + switch (translation) { + case TCL_TRANSLATE_AUTO: + if ((*rPtr == (char) eofChar) && (eofChar != 0)) { + chanPtr->flags |= (CHANNEL_EOF | CHANNEL_STICKY_EOF); + EOLFound = 1; + } else if (*rPtr == '\n') { + + /* + * CopyAndTranslateBuffer wants to know the length + * of the result, not the input. The input is one + * larger because "\r\n" shrinks to "\n". + */ + + if (!(*crSeenPtr)) { + bytesToEOL++; + EOLFound = 1; + } else { + + /* + * This is a lf at the begining of a buffer + * where the previous buffer ended in a cr. + * Consume this lf because we've already emitted + * the newline for this crlf sequence. ALSO, if + * bytesToEOL is 0 (which means that we are at the + * first character of the scan), unset the + * INPUT_SAW_CR flag in the channel, because we + * already handled it; leaving it set would cause + * CopyAndTranslateBuffer to potentially consume + * another lf if one follows the current byte. + */ + + bufPtr->nextRemoved++; + *crSeenPtr = 0; + chanPtr->flags &= (~(INPUT_SAW_CR)); + } + } else if (*rPtr == '\r') { + bytesToEOL++; + EOLFound = 1; + } else { + *crSeenPtr = 0; + bytesToEOL++; + } + break; + case TCL_TRANSLATE_LF: + if ((*rPtr == (char) eofChar) && (eofChar != 0)) { + chanPtr->flags |= (CHANNEL_EOF | CHANNEL_STICKY_EOF); + EOLFound = 1; + } else { + if (*rPtr == '\n') { + EOLFound = 1; + } + bytesToEOL++; + } + break; + case TCL_TRANSLATE_CR: + if ((*rPtr == (char) eofChar) && (eofChar != 0)) { + chanPtr->flags |= (CHANNEL_EOF | CHANNEL_STICKY_EOF); + EOLFound = 1; + } else { + if (*rPtr == '\r') { + EOLFound = 1; + } + bytesToEOL++; + } + break; + case TCL_TRANSLATE_CRLF: + if ((*rPtr == (char) eofChar) && (eofChar != 0)) { + chanPtr->flags |= (CHANNEL_EOF | CHANNEL_STICKY_EOF); + EOLFound = 1; + } else if (*rPtr == '\n') { + + /* + * CopyAndTranslateBuffer wants to know the length + * of the result, not the input. The input is one + * larger because crlf shrinks to lf. + */ + + if (*crSeenPtr) { + EOLFound = 1; + } else { + bytesToEOL++; + } + } else { + if (*rPtr == '\r') { + *crSeenPtr = 1; + } else { + *crSeenPtr = 0; + } + bytesToEOL++; + } + break; + default: + panic("unknown eol translation mode"); + } + } + + *bytesToEOLPtr = bytesToEOL; + return EOLFound; +} + +/* + *---------------------------------------------------------------------- + * + * ScanInputForEOL -- + * + * Scans queued input for chanPtr for an end of line (according to the + * current EOL translation mode) and returns the number of bytes + * upto and including the end of line, or -1 if none was found. + * + * Results: + * Count of bytes upto and including the end of line if one is present + * or -1 if none was found. Also returns in an output parameter the + * number of bytes queued if no end of line was found. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +ScanInputForEOL(chanPtr, bytesQueuedPtr) + Channel *chanPtr; /* Channel for which to scan queued + * input for end of line. */ + int *bytesQueuedPtr; /* Where to store the number of bytes + * currently queued if no end of line + * was found. */ +{ + ChannelBuffer *bufPtr; /* Iterates over queued buffers. */ + int bytesToEOL; /* How many bytes to end of line? */ + int EOLFound; /* Did we find an end of line? */ + int crSeen; /* Did we see a "\r" in CRLF mode? */ + + *bytesQueuedPtr = 0; + bytesToEOL = 0; + EOLFound = 0; + for (bufPtr = chanPtr->inQueueHead, + crSeen = (chanPtr->flags & INPUT_SAW_CR) ? 1 : 0; + (!EOLFound) && (bufPtr != (ChannelBuffer *) NULL); + bufPtr = bufPtr->nextPtr) { + EOLFound = ScanBufferForEOL(chanPtr, bufPtr, chanPtr->inputTranslation, + chanPtr->inEofChar, &bytesToEOL, &crSeen); + } + + if (EOLFound == 0) { + *bytesQueuedPtr = bytesToEOL; + return -1; + } + return bytesToEOL; +} + +/* + *---------------------------------------------------------------------- + * + * GetEOL -- + * + * Accumulate input into the channel input buffer queue until an + * end of line has been seen. + * + * Results: + * Number of bytes buffered or -1 on failure. + * + * Side effects: + * Consumes input from the channel. + * + *---------------------------------------------------------------------- + */ + +static int +GetEOL(chanPtr) + Channel *chanPtr; /* Channel to queue input on. */ +{ + int result; /* Of getting another buffer from the + * channel. */ + int bytesToEOL; /* How many bytes in buffer up to and + * including the end of line? */ + int bytesQueued; /* How many bytes are queued currently + * in the input chain of the channel? */ + + while (1) { + bytesToEOL = ScanInputForEOL(chanPtr, &bytesQueued); + if (bytesToEOL > 0) { + chanPtr->flags &= (~(CHANNEL_BLOCKED)); + return bytesToEOL; + } + if (chanPtr->flags & CHANNEL_EOF) { + /* + * Boundary case where cr was at the end of the previous buffer + * and this buffer just has a newline. At EOF our caller wants + * to see -1 for the line length. + */ + return (bytesQueued == 0) ? -1 : bytesQueued ; + } + if (chanPtr->flags & CHANNEL_BLOCKED) { + if (chanPtr->flags & CHANNEL_NONBLOCKING) { + return -1; + } + chanPtr->flags &= (~(CHANNEL_BLOCKED)); + } + result = GetInput(chanPtr); + if (result != 0) { + if (result == EAGAIN) { + chanPtr->flags |= CHANNEL_BLOCKED; + } + return -1; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_Read -- + * + * Reads a given number of characters from a channel. + * + * Results: + * The number of characters read, or -1 on error. Use Tcl_GetErrno() + * to retrieve the error code for the error that occurred. + * + * Side effects: + * May cause input to be buffered. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_Read(chan, bufPtr, toRead) + Tcl_Channel chan; /* The channel from which to read. */ + char *bufPtr; /* Where to store input read. */ + int toRead; /* Maximum number of characters to read. */ +{ + Channel *chanPtr; /* The real IO channel. */ + int copied; /* How many characters were copied into + * the result string? */ + int copiedNow; /* How many characters were copied from + * the current input buffer? */ + int result; /* Of calling GetInput. */ + + chanPtr = (Channel *) chan; + + /* + * Check for unreported error. + */ + + if (chanPtr->unreportedError != 0) { + Tcl_SetErrno(chanPtr->unreportedError); + chanPtr->unreportedError = 0; + return -1; + } + + /* + * Punt if the channel is not opened for reading. + */ + + if (!(chanPtr->flags & TCL_READABLE)) { + Tcl_SetErrno(EACCES); + return -1; + } + + /* + * If we have not encountered a sticky EOF, clear the EOF bit. Either + * way clear the BLOCKED bit. We want to discover these anew during + * each operation. + */ + + if (!(chanPtr->flags & CHANNEL_STICKY_EOF)) { + chanPtr->flags &= (~(CHANNEL_EOF)); + } + chanPtr->flags &= (~(CHANNEL_BLOCKED)); + + for (copied = 0; copied < toRead; copied += copiedNow) { + copiedNow = CopyAndTranslateBuffer(chanPtr, bufPtr + copied, + toRead - copied); + if (copiedNow == 0) { + if (chanPtr->flags & CHANNEL_EOF) { + return copied; + } + if (chanPtr->flags & CHANNEL_BLOCKED) { + if (chanPtr->flags & CHANNEL_NONBLOCKING) { + return copied; + } + chanPtr->flags &= (~(CHANNEL_BLOCKED)); + } + result = GetInput(chanPtr); + if (result != 0) { + if (result == EAGAIN) { + return copied; + } + return -1; + } + } + } + chanPtr->flags &= (~(CHANNEL_BLOCKED)); + return copied; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_Gets -- + * + * Reads a complete line of input from the channel. + * + * Results: + * Length of line read or -1 if error, EOF or blocked. If -1, use + * Tcl_GetErrno() to retrieve the POSIX error code for the + * error or condition that occurred. + * + * Side effects: + * May flush output on the channel. May cause input to be + * consumed from the channel. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_Gets(chan, lineRead) + Tcl_Channel chan; /* Channel from which to read. */ + Tcl_DString *lineRead; /* The characters of the line read + * (excluding the terminating newline if + * present) will be appended to this + * DString. The caller must have initialized + * it and is responsible for managing the + * storage. */ +{ + Channel *chanPtr; /* The channel to read from. */ + char *buf; /* Points into DString where data + * will be stored. */ + int offset; /* Offset from start of DString at + * which to append the line just read. */ + int copiedTotal; /* Accumulates total length of input copied. */ + int copiedNow; /* How many bytes were copied from the + * current input buffer? */ + int lineLen; /* Length of line read, including the + * translated newline. If this is zero + * and neither EOF nor BLOCKED is set, + * the current line is empty. */ + + chanPtr = (Channel *) chan; + + /* + * Check for unreported error. + */ + + if (chanPtr->unreportedError != 0) { + Tcl_SetErrno(chanPtr->unreportedError); + chanPtr->unreportedError = 0; + return -1; + } + + /* + * Punt if the channel is not opened for reading. + */ + + if (!(chanPtr->flags & TCL_READABLE)) { + Tcl_SetErrno(EACCES); + return -1; + } + + /* + * If we have not encountered a sticky EOF, clear the EOF bit + * (sticky EOF is set if we have seen the input eofChar, to prevent + * reading beyond the eofChar). Also, always clear the BLOCKED bit. + * We want to discover these conditions anew in each operation. + */ + + if (!(chanPtr->flags & CHANNEL_STICKY_EOF)) { + chanPtr->flags &= (~(CHANNEL_EOF)); + } + chanPtr->flags &= (~(CHANNEL_BLOCKED)); + lineLen = GetEOL(chanPtr); + if (lineLen < 0) { + return -1; + } + if (lineLen == 0) { + if (chanPtr->flags & (CHANNEL_EOF | CHANNEL_BLOCKED)) { + return -1; + } + return 0; + } + offset = Tcl_DStringLength(lineRead); + Tcl_DStringSetLength(lineRead, lineLen + offset); + buf = Tcl_DStringValue(lineRead) + offset; + + for (copiedTotal = 0; copiedTotal < lineLen; copiedTotal += copiedNow) { + copiedNow = CopyAndTranslateBuffer(chanPtr, buf + copiedTotal, + lineLen - copiedTotal); + } + if ((copiedTotal > 0) && (buf[copiedTotal - 1] == '\n')) { + copiedTotal--; + } + Tcl_DStringSetLength(lineRead, copiedTotal + offset); + return copiedTotal; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_Seek -- + * + * Implements seeking on Tcl Channels. This is a public function + * so that other C facilities may be implemented on top of it. + * + * Results: + * The new access point or -1 on error. If error, use Tcl_GetErrno() + * to retrieve the POSIX error code for the error that occurred. + * + * Side effects: + * May flush output on the channel. May discard queued input. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_Seek(chan, offset, mode) + Tcl_Channel chan; /* The channel on which to seek. */ + int offset; /* Offset to seek to. */ + int mode; /* Relative to which location to seek? */ +{ + Channel *chanPtr; /* The real IO channel. */ + ChannelBuffer *bufPtr; /* Iterates over queued input + * and output buffers. */ + int inputBuffered, outputBuffered; + int result; /* Of device driver operations. */ + int curPos; /* Position on the device. */ + int wasAsync; /* Was the channel nonblocking before the + * seek operation? If so, must restore to + * nonblocking mode after the seek. */ + + chanPtr = (Channel *) chan; + + /* + * Check for unreported error. + */ + + if (chanPtr->unreportedError != 0) { + Tcl_SetErrno(chanPtr->unreportedError); + chanPtr->unreportedError = 0; + return -1; + } + + /* + * Disallow seek on channels that are open for neither writing nor + * reading (e.g. socket server channels). + */ + + if (!(chanPtr->flags & (TCL_WRITABLE|TCL_READABLE))) { + Tcl_SetErrno(EACCES); + return -1; + } + + /* + * Disallow seek on channels whose type does not have a seek procedure + * defined. This means that the channel does not support seeking. + */ + + if (chanPtr->typePtr->seekProc == (Tcl_DriverSeekProc *) NULL) { + Tcl_SetErrno(EINVAL); + return -1; + } + + /* + * Compute how much input and output is buffered. If both input and + * output is buffered, cannot compute the current position. + */ + + for (bufPtr = chanPtr->inQueueHead, inputBuffered = 0; + bufPtr != (ChannelBuffer *) NULL; + bufPtr = bufPtr->nextPtr) { + inputBuffered += (bufPtr->nextAdded - bufPtr->nextRemoved); + } + for (bufPtr = chanPtr->outQueueHead, outputBuffered = 0; + bufPtr != (ChannelBuffer *) NULL; + bufPtr = bufPtr->nextPtr) { + outputBuffered += (bufPtr->nextAdded - bufPtr->nextRemoved); + } + if ((chanPtr->curOutPtr != (ChannelBuffer *) NULL) && + (chanPtr->curOutPtr->nextAdded > chanPtr->curOutPtr->nextRemoved)) { + chanPtr->flags |= BUFFER_READY; + outputBuffered += + (chanPtr->curOutPtr->nextAdded - chanPtr->curOutPtr->nextRemoved); + } + if ((inputBuffered != 0) && (outputBuffered != 0)) { + Tcl_SetErrno(EFAULT); + return -1; + } + + /* + * If we are seeking relative to the current position, compute the + * corrected offset taking into account the amount of unread input. + */ + + if (mode == SEEK_CUR) { + offset -= inputBuffered; + } + + /* + * Discard any queued input - this input should not be read after + * the seek. + */ + + DiscardInputQueued(chanPtr, 0); + + /* + * Reset EOF and BLOCKED flags. We invalidate them by moving the + * access point. Also clear CR related flags. + */ + + chanPtr->flags &= + (~(CHANNEL_EOF | CHANNEL_STICKY_EOF | CHANNEL_BLOCKED | INPUT_SAW_CR)); + + /* + * If the channel is in asynchronous output mode, switch it back + * to synchronous mode and cancel any async flush that may be + * scheduled. After the flush, the channel will be put back into + * asynchronous output mode. + */ + + wasAsync = 0; + if (chanPtr->flags & CHANNEL_NONBLOCKING) { + wasAsync = 1; + result = 0; + if (chanPtr->typePtr->blockModeProc != NULL) { + result = (chanPtr->typePtr->blockModeProc) (chanPtr->instanceData, + chanPtr->inFile, chanPtr->outFile, TCL_MODE_BLOCKING); + } + if (result != 0) { + Tcl_SetErrno(result); + return -1; + } + chanPtr->flags &= (~(CHANNEL_NONBLOCKING)); + if (chanPtr->flags & BG_FLUSH_SCHEDULED) { + Tcl_DeleteFileHandler(chanPtr->outFile); + chanPtr->flags &= (~(BG_FLUSH_SCHEDULED)); + } + } + + /* + * If the flush fails we cannot recover the original position. In + * that case the seek is not attempted because we do not know where + * the access position is - instead we return the error. FlushChannel + * has already called Tcl_SetErrno() to report the error upwards. + * If the flush succeeds we do the seek also. + */ + + if (FlushChannel(NULL, chanPtr, 0) != 0) { + curPos = -1; + } else { + + /* + * Now seek to the new position in the channel as requested by the + * caller. + */ + + curPos = (chanPtr->typePtr->seekProc) (chanPtr->instanceData, + chanPtr->inFile, chanPtr->outFile, (long) offset, + mode, &result); + if (curPos == -1) { + Tcl_SetErrno(result); + } + } + + /* + * Restore to nonblocking mode if that was the previous behavior. + * + * NOTE: Even if there was an async flush active we do not restore + * it now because we already flushed all the queued output, above. + */ + + if (wasAsync) { + chanPtr->flags |= CHANNEL_NONBLOCKING; + result = 0; + if (chanPtr->typePtr->blockModeProc != NULL) { + result = (chanPtr->typePtr->blockModeProc) (chanPtr->instanceData, + chanPtr->inFile, chanPtr->outFile, TCL_MODE_NONBLOCKING); + } + if (result != 0) { + Tcl_SetErrno(result); + return -1; + } + } + + return curPos; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_Tell -- + * + * Returns the position of the next character to be read/written on + * this channel. + * + * Results: + * A nonnegative integer on success, -1 on failure. If failed, + * use Tcl_GetErrno() to retrieve the POSIX error code for the + * error that occurred. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_Tell(chan) + Tcl_Channel chan; /* The channel to return pos for. */ +{ + Channel *chanPtr; /* The actual channel to tell on. */ + ChannelBuffer *bufPtr; /* Iterates over queued input + * and output buffers. */ + int inputBuffered, outputBuffered; + int result; /* Of calling device driver. */ + int curPos; /* Position on device. */ + + chanPtr = (Channel *) chan; + + /* + * Check for unreported error. + */ + + if (chanPtr->unreportedError != 0) { + Tcl_SetErrno(chanPtr->unreportedError); + chanPtr->unreportedError = 0; + return -1; + } + + /* + * Disallow tell on channels that are open for neither + * writing nor reading (e.g. socket server channels). + */ + + if (!(chanPtr->flags & (TCL_WRITABLE|TCL_READABLE))) { + Tcl_SetErrno(EACCES); + return -1; + } + + /* + * Disallow tell on channels whose type does not have a seek procedure + * defined. This means that the channel does not support seeking. + */ + + if (chanPtr->typePtr->seekProc == (Tcl_DriverSeekProc *) NULL) { + Tcl_SetErrno(EINVAL); + return -1; + } + + /* + * Compute how much input and output is buffered. If both input and + * output is buffered, cannot compute the current position. + */ + + for (bufPtr = chanPtr->inQueueHead, inputBuffered = 0; + bufPtr != (ChannelBuffer *) NULL; + bufPtr = bufPtr->nextPtr) { + inputBuffered += (bufPtr->nextAdded - bufPtr->nextRemoved); + } + for (bufPtr = chanPtr->outQueueHead, outputBuffered = 0; + bufPtr != (ChannelBuffer *) NULL; + bufPtr = bufPtr->nextPtr) { + outputBuffered += (bufPtr->nextAdded - bufPtr->nextRemoved); + } + if (chanPtr->curOutPtr != (ChannelBuffer *) NULL) { + outputBuffered += + (chanPtr->curOutPtr->nextAdded - chanPtr->curOutPtr->nextRemoved); + } + if ((inputBuffered != 0) && (outputBuffered != 0)) { + Tcl_SetErrno(EFAULT); + return -1; + } + + /* + * Get the current position in the device and compute the position + * where the next character will be read or written. + */ + + curPos = (chanPtr->typePtr->seekProc) (chanPtr->instanceData, + chanPtr->inFile, chanPtr->outFile, (long) 0, SEEK_CUR, &result); + if (curPos == -1) { + Tcl_SetErrno(result); + return -1; + } + if (inputBuffered != 0) { + return (curPos - inputBuffered); + } + return (curPos + outputBuffered); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_Eof -- + * + * Returns 1 if the channel is at EOF, 0 otherwise. + * + * Results: + * 1 or 0, always. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_Eof(chan) + Tcl_Channel chan; /* Does this channel have EOF? */ +{ + Channel *chanPtr; /* The real channel structure. */ + + chanPtr = (Channel *) chan; + return ((chanPtr->flags & CHANNEL_STICKY_EOF) || + ((chanPtr->flags & CHANNEL_EOF) && (Tcl_InputBuffered(chan) == 0))) + ? 1 : 0; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_InputBlocked -- + * + * Returns 1 if input is blocked on this channel, 0 otherwise. + * + * Results: + * 0 or 1, always. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_InputBlocked(chan) + Tcl_Channel chan; /* Is this channel blocked? */ +{ + Channel *chanPtr; /* The real channel structure. */ + + chanPtr = (Channel *) chan; + return (chanPtr->flags & CHANNEL_BLOCKED) ? 1 : 0; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_InputBuffered -- + * + * Returns the number of bytes of input currently buffered in the + * internal buffer of a channel. + * + * Results: + * The number of input bytes buffered, or zero if the channel is not + * open for reading. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_InputBuffered(chan) + Tcl_Channel chan; /* The channel to query. */ +{ + Channel *chanPtr; + int bytesBuffered; + ChannelBuffer *bufPtr; + + chanPtr = (Channel *) chan; + for (bytesBuffered = 0, bufPtr = chanPtr->inQueueHead; + bufPtr != (ChannelBuffer *) NULL; + bufPtr = bufPtr->nextPtr) { + bytesBuffered += (bufPtr->nextAdded - bufPtr->nextRemoved); + } + return bytesBuffered; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetChannelBufferSize -- + * + * Sets the size of buffers to allocate to store input or output + * in the channel. The size must be between 10 bytes and 1 MByte. + * + * Results: + * None. + * + * Side effects: + * Sets the size of buffers subsequently allocated for this channel. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SetChannelBufferSize(chan, sz) + Tcl_Channel chan; /* The channel whose buffer size + * to set. */ + int sz; /* The size to set. */ +{ + Channel *chanPtr; + + if (sz < 10) { + sz = CHANNELBUFFER_DEFAULT_SIZE; + } + + /* + * Allow only buffers that are smaller than one megabyte. + */ + + if (sz > (1024 * 1024)) { + sz = CHANNELBUFFER_DEFAULT_SIZE; + } + + chanPtr = (Channel *) chan; + chanPtr->bufSize = sz; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetChannelBufferSize -- + * + * Retrieves the size of buffers to allocate for this channel. + * + * Results: + * The size. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetChannelBufferSize(chan) + Tcl_Channel chan; /* The channel for which to find the + * buffer size. */ +{ + Channel *chanPtr; + + chanPtr = (Channel *) chan; + return chanPtr->bufSize; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetChannelOption -- + * + * Gets a mode associated with an IO channel. If the optionName arg + * is non NULL, retrieves the value of that option. If the optionName + * arg is NULL, retrieves a list of alternating option names and + * values for the given channel. + * + * Results: + * A standard Tcl result. Also sets the supplied DString to the + * string value of the option(s) returned. + * + * Side effects: + * The string returned by this function is in static storage and + * may be reused at any time subsequent to the call. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetChannelOption(chan, optionName, dsPtr) + Tcl_Channel chan; /* Channel on which to get option. */ + char *optionName; /* Option to get. */ + Tcl_DString *dsPtr; /* Where to store value(s). */ +{ + Channel *chanPtr; /* The real IO channel. */ + size_t len; /* Length of optionName string. */ + + chanPtr = (Channel *) chan; + + /* + * If the optionName is NULL it means that we want a list of all + * options and values. + */ + + if (optionName == (char *) NULL) { + len = 0; + } else { + len = strlen(optionName); + } + + if ((len == 0) || ((len > 2) && (optionName[1] == 'b') && + (strncmp(optionName, "-blocking", len) == 0))) { + if (len == 0) { + Tcl_DStringAppendElement(dsPtr, "-blocking"); + } + Tcl_DStringAppendElement(dsPtr, + (chanPtr->flags & CHANNEL_NONBLOCKING) ? "0" : "1"); + if (len > 0) { + return TCL_OK; + } + } + if ((len == 0) || ((len > 7) && (optionName[1] == 'b') && + (strncmp(optionName, "-buffering", len) == 0))) { + if (len == 0) { + Tcl_DStringAppendElement(dsPtr, "-buffering"); + } + if (chanPtr->flags & CHANNEL_LINEBUFFERED) { + Tcl_DStringAppendElement(dsPtr, "line"); + } else if (chanPtr->flags & CHANNEL_UNBUFFERED) { + Tcl_DStringAppendElement(dsPtr, "none"); + } else { + Tcl_DStringAppendElement(dsPtr, "full"); + } + if (len > 0) { + return TCL_OK; + } + } + if ((len == 0) || ((len > 7) && (optionName[1] == 'b') && + (strncmp(optionName, "-buffersize", len) == 0))) { + if (len == 0) { + Tcl_DStringAppendElement(dsPtr, "-buffersize"); + } + sprintf(optionVal, "%d", chanPtr->bufSize); + Tcl_DStringAppendElement(dsPtr, optionVal); + if (len > 0) { + return TCL_OK; + } + } + if ((len == 0) || + ((len > 1) && (optionName[1] == 'e') && + (strncmp(optionName, "-eofchar", len) == 0))) { + if (len == 0) { + Tcl_DStringAppendElement(dsPtr, "-eofchar"); + } + if ((chanPtr->flags & (TCL_READABLE|TCL_WRITABLE)) == + (TCL_READABLE|TCL_WRITABLE)) { + Tcl_DStringStartSublist(dsPtr); + } + if (chanPtr->flags & TCL_READABLE) { + if (chanPtr->inEofChar == 0) { + Tcl_DStringAppendElement(dsPtr, ""); + } else { + char buf[4]; + + sprintf(buf, "%c", chanPtr->inEofChar); + Tcl_DStringAppendElement(dsPtr, buf); + } + } + if (chanPtr->flags & TCL_WRITABLE) { + if (chanPtr->outEofChar == 0) { + Tcl_DStringAppendElement(dsPtr, ""); + } else { + char buf[4]; + + sprintf(buf, "%c", chanPtr->outEofChar); + Tcl_DStringAppendElement(dsPtr, buf); + } + } + if ((chanPtr->flags & (TCL_READABLE|TCL_WRITABLE)) == + (TCL_READABLE|TCL_WRITABLE)) { + Tcl_DStringEndSublist(dsPtr); + } + if (len > 0) { + return TCL_OK; + } + } + if ((len == 0) || + ((len > 1) && (optionName[1] == 't') && + (strncmp(optionName, "-translation", len) == 0))) { + if (len == 0) { + Tcl_DStringAppendElement(dsPtr, "-translation"); + } + if ((chanPtr->flags & (TCL_READABLE|TCL_WRITABLE)) == + (TCL_READABLE|TCL_WRITABLE)) { + Tcl_DStringStartSublist(dsPtr); + } + if (chanPtr->flags & TCL_READABLE) { + if (chanPtr->inputTranslation == TCL_TRANSLATE_AUTO) { + Tcl_DStringAppendElement(dsPtr, "auto"); + } else if (chanPtr->inputTranslation == TCL_TRANSLATE_CR) { + Tcl_DStringAppendElement(dsPtr, "cr"); + } else if (chanPtr->inputTranslation == TCL_TRANSLATE_CRLF) { + Tcl_DStringAppendElement(dsPtr, "crlf"); + } else { + Tcl_DStringAppendElement(dsPtr, "lf"); + } + } + if (chanPtr->flags & TCL_WRITABLE) { + if (chanPtr->outputTranslation == TCL_TRANSLATE_AUTO) { + Tcl_DStringAppendElement(dsPtr, "auto"); + } else if (chanPtr->outputTranslation == TCL_TRANSLATE_CR) { + Tcl_DStringAppendElement(dsPtr, "cr"); + } else if (chanPtr->outputTranslation == TCL_TRANSLATE_CRLF) { + Tcl_DStringAppendElement(dsPtr, "crlf"); + } else { + Tcl_DStringAppendElement(dsPtr, "lf"); + } + } + if ((chanPtr->flags & (TCL_READABLE|TCL_WRITABLE)) == + (TCL_READABLE|TCL_WRITABLE)) { + Tcl_DStringEndSublist(dsPtr); + } + if (len > 0) { + return TCL_OK; + } + } + if (chanPtr->typePtr->getOptionProc != (Tcl_DriverGetOptionProc *) NULL) { + return (chanPtr->typePtr->getOptionProc) (chanPtr->instanceData, + optionName, dsPtr); + } + if (len == 0) { + return TCL_OK; + } + Tcl_SetErrno(EINVAL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetChannelOption -- + * + * Sets an option on a channel. + * + * Results: + * A standard Tcl result. Also sets interp->result on error if + * interp is not NULL. + * + * Side effects: + * May modify an option on a device. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_SetChannelOption(interp, chan, optionName, newValue) + Tcl_Interp *interp; /* For error reporting - can be NULL. */ + Tcl_Channel chan; /* Channel on which to set mode. */ + char *optionName; /* Which option to set? */ + char *newValue; /* New value for option. */ +{ + int result; /* Result of channel type operation. */ + int newMode; /* New (numeric) mode to sert. */ + Channel *chanPtr; /* The real IO channel. */ + size_t len; /* Length of optionName string. */ + int argc; + char **argv; + + chanPtr = (Channel *) chan; + + len = strlen(optionName); + + if ((len > 2) && (optionName[1] == 'b') && + (strncmp(optionName, "-blocking", len) == 0)) { + if (Tcl_GetBoolean(interp, newValue, &newMode) == TCL_ERROR) { + return TCL_ERROR; + } + if (newMode) { + newMode = TCL_MODE_BLOCKING; + } else { + newMode = TCL_MODE_NONBLOCKING; + } + result = 0; + if (chanPtr->typePtr->blockModeProc != NULL) { + result = (chanPtr->typePtr->blockModeProc) (chanPtr->instanceData, + chanPtr->inFile, chanPtr->outFile, newMode); + } + if (result != 0) { + Tcl_SetErrno(result); + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "error setting blocking mode: ", + Tcl_PosixError(interp), (char *) NULL); + } + return TCL_ERROR; + } + if (newMode == TCL_MODE_BLOCKING) { + chanPtr->flags &= (~(CHANNEL_NONBLOCKING)); + if (chanPtr->outFile != (Tcl_File) NULL) { + Tcl_DeleteFileHandler(chanPtr->outFile); + chanPtr->flags &= (~(BG_FLUSH_SCHEDULED)); + } + } else { + chanPtr->flags |= CHANNEL_NONBLOCKING; + } + return TCL_OK; + } + + if ((len > 7) && (optionName[1] == 'b') && + (strncmp(optionName, "-buffering", len) == 0)) { + len = strlen(newValue); + if ((newValue[0] == 'f') && (strncmp(newValue, "full", len) == 0)) { + chanPtr->flags &= + (~(CHANNEL_UNBUFFERED|CHANNEL_LINEBUFFERED)); + } else if ((newValue[0] == 'l') && + (strncmp(newValue, "line", len) == 0)) { + chanPtr->flags &= (~(CHANNEL_UNBUFFERED)); + chanPtr->flags |= CHANNEL_LINEBUFFERED; + } else if ((newValue[0] == 'n') && + (strncmp(newValue, "none", len) == 0)) { + chanPtr->flags &= (~(CHANNEL_LINEBUFFERED)); + chanPtr->flags |= CHANNEL_UNBUFFERED; + } else { + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "bad value for -buffering: ", + "must be one of full, line, or none", + (char *) NULL); + return TCL_ERROR; + } + } + return TCL_OK; + } + + if ((len > 7) && (optionName[1] == 'b') && + (strncmp(optionName, "-buffersize", len) == 0)) { + chanPtr->bufSize = atoi(newValue); + if ((chanPtr->bufSize < 10) || (chanPtr->bufSize > (1024 * 1024))) { + chanPtr->bufSize = CHANNELBUFFER_DEFAULT_SIZE; + } + return TCL_OK; + } + + if ((len > 1) && (optionName[1] == 'e') && + (strncmp(optionName, "-eofchar", len) == 0)) { + if (Tcl_SplitList(interp, newValue, &argc, &argv) == TCL_ERROR) { + return TCL_ERROR; + } + if (argc == 0) { + chanPtr->inEofChar = 0; + chanPtr->outEofChar = 0; + } else if (argc == 1) { + if (chanPtr->flags & TCL_WRITABLE) { + chanPtr->outEofChar = (int) argv[0][0]; + } + if (chanPtr->flags & TCL_READABLE) { + chanPtr->inEofChar = (int) argv[0][0]; + } + } else if (argc != 2) { + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, + "bad value for -eofchar: should be a list of one or", + " two elements", (char *) NULL); + } + ckfree((char *) argv); + return TCL_ERROR; + } else { + if (chanPtr->flags & TCL_READABLE) { + chanPtr->inEofChar = (int) argv[0][0]; + } + if (chanPtr->flags & TCL_WRITABLE) { + chanPtr->outEofChar = (int) argv[1][0]; + } + } + if (argv != (char **) NULL) { + ckfree((char *) argv); + } + return TCL_OK; + } + + if ((len > 1) && (optionName[1] == 't') && + (strncmp(optionName, "-translation", len) == 0)) { + if (Tcl_SplitList(interp, newValue, &argc, &argv) == TCL_ERROR) { + return TCL_ERROR; + } + if (argc == 1) { + if (chanPtr->flags & TCL_READABLE) { + chanPtr->flags &= (~(INPUT_SAW_CR)); + if (strcmp(argv[0], "auto") == 0) { + chanPtr->inputTranslation = TCL_TRANSLATE_AUTO; + } else if (strcmp(argv[0], "binary") == 0) { + chanPtr->inEofChar = 0; + chanPtr->inputTranslation = TCL_TRANSLATE_LF; + } else if (strcmp(argv[0], "lf") == 0) { + chanPtr->inputTranslation = TCL_TRANSLATE_LF; + } else if (strcmp(argv[0], "cr") == 0) { + chanPtr->inputTranslation = TCL_TRANSLATE_CR; + } else if (strcmp(argv[0], "crlf") == 0) { + chanPtr->inputTranslation = TCL_TRANSLATE_CRLF; + } else if (strcmp(argv[0], "platform") == 0) { + chanPtr->inputTranslation = TCL_PLATFORM_TRANSLATION; + } else { + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, + "bad value for -translation: ", + "must be one of auto, binary, cr, lf, crlf,", + " or platform", (char *) NULL); + } + ckfree((char *) argv); + return TCL_ERROR; + } + } + if (chanPtr->flags & TCL_WRITABLE) { + if (strcmp(argv[0], "auto") == 0) { + /* + * This is a hack to get TCP sockets to produce output + * in CRLF mode if they are being set into AUTO mode. + * A better solution for achieving this effect will be + * coded later. + */ + + if (strcmp(chanPtr->typePtr->typeName, "tcp") == 0) { + chanPtr->outputTranslation = TCL_TRANSLATE_CRLF; + } else { + chanPtr->outputTranslation = TCL_PLATFORM_TRANSLATION; + } + } else if (strcmp(argv[0], "binary") == 0) { + chanPtr->outEofChar = 0; + chanPtr->outputTranslation = TCL_TRANSLATE_LF; + } else if (strcmp(argv[0], "lf") == 0) { + chanPtr->outputTranslation = TCL_TRANSLATE_LF; + } else if (strcmp(argv[0], "cr") == 0) { + chanPtr->outputTranslation = TCL_TRANSLATE_CR; + } else if (strcmp(argv[0], "crlf") == 0) { + chanPtr->outputTranslation = TCL_TRANSLATE_CRLF; + } else if (strcmp(argv[0], "platform") == 0) { + chanPtr->outputTranslation = TCL_PLATFORM_TRANSLATION; + } else { + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, + "bad value for -translation: ", + "must be one of auto, binary, cr, lf, crlf,", + " or platform", (char *) NULL); + } + ckfree((char *) argv); + return TCL_ERROR; + } + } + } else if (argc != 2) { + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, + "bad value for -translation: must be a one or two", + " element list", (char *) NULL); + } + ckfree((char *) argv); + return TCL_ERROR; + } else { + if (chanPtr->flags & TCL_READABLE) { + if (argv[0][0] == '\0') { + /* Empty body. */ + } else if (strcmp(argv[0], "auto") == 0) { + chanPtr->flags &= (~(INPUT_SAW_CR)); + chanPtr->inputTranslation = TCL_TRANSLATE_AUTO; + } else if (strcmp(argv[0], "binary") == 0) { + chanPtr->inEofChar = 0; + chanPtr->flags &= (~(INPUT_SAW_CR)); + chanPtr->inputTranslation = TCL_TRANSLATE_LF; + } else if (strcmp(argv[0], "lf") == 0) { + chanPtr->flags &= (~(INPUT_SAW_CR)); + chanPtr->inputTranslation = TCL_TRANSLATE_LF; + } else if (strcmp(argv[0], "cr") == 0) { + chanPtr->flags &= (~(INPUT_SAW_CR)); + chanPtr->inputTranslation = TCL_TRANSLATE_CR; + } else if (strcmp(argv[0], "crlf") == 0) { + chanPtr->flags &= (~(INPUT_SAW_CR)); + chanPtr->inputTranslation = TCL_TRANSLATE_CRLF; + } else if (strcmp(argv[0], "platform") == 0) { + chanPtr->flags &= (~(INPUT_SAW_CR)); + chanPtr->inputTranslation = TCL_PLATFORM_TRANSLATION; + } else { + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, + "bad value for -translation: ", + "must be one of auto, binary, cr, lf, crlf,", + " or platform", (char *) NULL); + } + ckfree((char *) argv); + return TCL_ERROR; + } + } + if (chanPtr->flags & TCL_WRITABLE) { + if (argv[1][0] == '\0') { + /* Empty body. */ + } else if (strcmp(argv[1], "auto") == 0) { + /* + * This is a hack to get TCP sockets to produce output + * in CRLF mode if they are being set into AUTO mode. + * A better solution for achieving this effect will be + * coded later. + */ + + if (strcmp(chanPtr->typePtr->typeName, "tcp") == 0) { + chanPtr->outputTranslation = TCL_TRANSLATE_CRLF; + } else { + chanPtr->outputTranslation = TCL_PLATFORM_TRANSLATION; + } + } else if (strcmp(argv[1], "binary") == 0) { + chanPtr->outEofChar = 0; + chanPtr->outputTranslation = TCL_TRANSLATE_LF; + } else if (strcmp(argv[1], "lf") == 0) { + chanPtr->outputTranslation = TCL_TRANSLATE_LF; + } else if (strcmp(argv[1], "cr") == 0) { + chanPtr->outputTranslation = TCL_TRANSLATE_CR; + } else if (strcmp(argv[1], "crlf") == 0) { + chanPtr->outputTranslation = TCL_TRANSLATE_CRLF; + } else if (strcmp(argv[1], "platform") == 0) { + chanPtr->outputTranslation = TCL_PLATFORM_TRANSLATION; + } else { + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, + "bad value for -translation: ", + "must be one of auto, binary, cr, lf, crlf,", + " or platform", (char *) NULL); + } + ckfree((char *) argv); + return TCL_ERROR; + } + } + } + ckfree((char *) argv); + return TCL_OK; + } + + if (chanPtr->typePtr->setOptionProc != (Tcl_DriverSetOptionProc *) NULL) { + return (chanPtr->typePtr->setOptionProc) (chanPtr->instanceData, + interp, optionName, newValue); + } + + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "bad option \"", optionName, + "\": should be -blocking, -buffering, -buffersize, ", + "-eofchar, -translation, ", + "or channel type specific option", + (char *) NULL); + } + + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * ChannelEventSourceExitProc -- + * + * This procedure is called during exit cleanup to delete the channel + * event source. It deletes the event source for channels. + * + * Results: + * None. + * + * Side effects: + * Destroys the channel event source. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static void +ChannelEventSourceExitProc(clientData) + ClientData clientData; /* Not used. */ +{ + Tcl_DeleteEventSource(ChannelHandlerSetupProc, ChannelHandlerCheckProc, + (ClientData) NULL); + channelEventSourceCreated = 0; +} + +/* + *---------------------------------------------------------------------- + * + * ChannelHandlerSetupProc -- + * + * This procedure is part of the event source for channel handlers. + * It is invoked by Tcl_DoOneEvent before it waits for events. The + * job of this procedure is to provide information to Tcl_DoOneEvent + * on how to wait for events (what files to watch). + * + * Results: + * None. + * + * Side effects: + * Tells the notifier what channels to watch. + * + *---------------------------------------------------------------------- + */ + +static void +ChannelHandlerSetupProc(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. */ +{ + Tcl_Time dontBlock; + Channel *chanPtr, *nextChanPtr; + + if (!(flags & TCL_FILE_EVENTS)) { + return; + } + + dontBlock.sec = 0; dontBlock.usec = 0; + + for (chanPtr = firstChanPtr; chanPtr != (Channel *) NULL; + chanPtr = nextChanPtr) { + nextChanPtr = chanPtr->nextChanPtr; + if (chanPtr->interestMask & TCL_READABLE) { + if ((!(chanPtr->flags & CHANNEL_BLOCKED)) && + (chanPtr->inQueueHead != (ChannelBuffer *) NULL) && + (chanPtr->inQueueHead->nextRemoved < + chanPtr->inQueueHead->nextAdded)) { + Tcl_SetMaxBlockTime(&dontBlock); + } else if (chanPtr->inFile != (Tcl_File) NULL) { + Tcl_WatchFile(chanPtr->inFile, TCL_READABLE); + } + } + if (chanPtr->interestMask & TCL_WRITABLE) { + if (chanPtr->outFile != (Tcl_File) NULL) { + Tcl_WatchFile(chanPtr->outFile, TCL_WRITABLE); + } + } + if (chanPtr->interestMask & TCL_EXCEPTION) { + if (chanPtr->inFile != (Tcl_File) NULL) { + Tcl_WatchFile(chanPtr->inFile, TCL_EXCEPTION); + } + if (chanPtr->outFile != (Tcl_File) NULL) { + Tcl_WatchFile(chanPtr->outFile, TCL_EXCEPTION); + } + } + } +} + +/* + *---------------------------------------------------------------------- + * + * ChannelHandlerCheckProc -- + * + * This procedure is the second part (of three) of the event source + * for channels. It is invoked by Tcl_DoOneEvent after the wait for + * events is over. The job of this procedure is to test each channel + * to see if it is ready now, and if so, to create events and put them + * on the Tcl event queue. + * + * Results: + * None. + * + * Side effects: + * Makes entries on the Tcl event queue for each channel that is + * ready now. + * + *---------------------------------------------------------------------- + */ + +static void +ChannelHandlerCheckProc(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. */ +{ + Channel *chanPtr, *nextChanPtr; + ChannelHandlerEvent *ePtr; + int readyMask; + + if (!(flags & TCL_FILE_EVENTS)) { + return; + } + + for (chanPtr = firstChanPtr; + chanPtr != (Channel *) NULL; + chanPtr = nextChanPtr) { + nextChanPtr = chanPtr->nextChanPtr; + + readyMask = 0; + + /* + * Check for readability. + */ + + if (chanPtr->interestMask & TCL_READABLE) { + + /* + * The channel is considered ready for reading if there is input + * buffered AND the last attempt to read from the channel did not + * return EWOULDBLOCK, OR if the underlying file is ready. + * + * NOTE that the input queue may contain empty buffers, hence the + * special check to see if the first input buffer is empty. The + * invariant is that if there is an empty buffer in the queue + * there is only one buffer in the queue, hence an empty first + * buffer indicates that there is no input queued. + */ + + if ((!(chanPtr->flags & CHANNEL_BLOCKED)) && + ((chanPtr->inQueueHead != (ChannelBuffer *) NULL) && + (chanPtr->inQueueHead->nextRemoved < + chanPtr->inQueueHead->nextAdded))) { + readyMask |= TCL_READABLE; + } else if (chanPtr->inFile != (Tcl_File) NULL) { + readyMask |= + Tcl_FileReady(chanPtr->inFile, TCL_READABLE); + } + } + + /* + * Check for writability. + */ + + if (chanPtr->interestMask & TCL_WRITABLE) { + + /* + * The channel is considered ready for writing if there is no + * output buffered waiting to be written to the device, AND the + * underlying file is ready. + */ + + if ((chanPtr->outQueueHead == (ChannelBuffer *) NULL) && + (chanPtr->outFile != (Tcl_File) NULL)) { + readyMask |= + Tcl_FileReady(chanPtr->outFile, TCL_WRITABLE); + } + } + + /* + * Check for exceptions. + */ + + if (chanPtr->interestMask & TCL_EXCEPTION) { + if (chanPtr->inFile != (Tcl_File) NULL) { + readyMask |= + Tcl_FileReady(chanPtr->inFile, TCL_EXCEPTION); + } + if (chanPtr->outFile != (Tcl_File) NULL) { + readyMask |= + Tcl_FileReady(chanPtr->outFile, TCL_EXCEPTION); + } + } + + /* + * If there are any events for this channel, put a notice into the + * Tcl event queue. + */ + + if (readyMask != 0) { + ePtr = (ChannelHandlerEvent *) ckalloc((unsigned) + sizeof(ChannelHandlerEvent)); + ePtr->header.proc = ChannelHandlerEventProc; + ePtr->chanPtr = chanPtr; + ePtr->readyMask = readyMask; + Tcl_QueueEvent((Tcl_Event *) ePtr, TCL_QUEUE_TAIL); + } + } +} + +/* + *---------------------------------------------------------------------- + * + * FlushEventProc -- + * + * This routine dispatches a background flush event. + * + * Errors that occur during the write operation are stored + * inside the channel structure for future reporting by the next + * operation that uses this channel. + * + * Results: + * None. + * + * Side effects: + * Causes production of output on a channel. + * + *---------------------------------------------------------------------- + */ + +static void +FlushEventProc(clientData, mask) + ClientData clientData; /* Channel to produce output on. */ + int mask; /* Not used. */ +{ + (void) FlushChannel(NULL, (Channel *) clientData, 1); +} + +/* + *---------------------------------------------------------------------- + * + * ChannelHandlerEventProc -- + * + * This procedure is called by Tcl_DoOneEvent when a channel event + * reaches the front of the event queue. This procedure is responsible + * for actually handling the event by invoking the callback for the + * channel handler. + * + * Results: + * Returns 1 if the event was handled, meaning that it should be + * removed from the queue. Returns 0 if the event was not handled + * meaning that it should stay in the queue. The only time the event + * will not be handled is if the TCL_FILE_EVENTS flag bit is not + * set in the flags passed. + * + * NOTE: If the handler is deleted between the time the event is added + * to the queue and the time it reaches the head of the queue, the + * event is silently discarded (i.e. we return 1). + * + * Side effects: + * Whatever the channel handler callback procedure does. + * + *---------------------------------------------------------------------- + */ + +static int +ChannelHandlerEventProc(evPtr, flags) + Tcl_Event *evPtr; /* Event to service. */ + int flags; /* Flags that indicate what events to + * handle, such as TCL_FILE_EVENTS. */ +{ + Channel *chanPtr; + ChannelHandler *chPtr; + ChannelHandlerEvent *ePtr; + NextChannelHandler nh; + + if (!(flags & TCL_FILE_EVENTS)) { + return 0; + } + + ePtr = (ChannelHandlerEvent *) evPtr; + chanPtr = ePtr->chanPtr; + + /* + * Add this invocation to the list of recursive invocations of + * ChannelHandlerEventProc. + */ + + nh.nextHandlerPtr = (ChannelHandler *) NULL; + nh.nestedHandlerPtr = nestedHandlerPtr; + nestedHandlerPtr = &nh; + + for (chPtr = chanPtr->chPtr; chPtr != (ChannelHandler *) NULL; ) { + + /* + * If this channel handler is interested in any of the events that + * have occurred on the channel, invoke its procedure. + */ + + if ((chPtr->mask & ePtr->readyMask) != 0) { + nh.nextHandlerPtr = chPtr->nextPtr; + (*(chPtr->proc))(chPtr->clientData, ePtr->readyMask); + chPtr = nh.nextHandlerPtr; + } else { + chPtr = chPtr->nextPtr; + } + } + + nestedHandlerPtr = nh.nestedHandlerPtr; + + return 1; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CreateChannelHandler -- + * + * Arrange for a given procedure to be invoked whenever the + * channel indicated by the chanPtr arg becomes readable or + * writable. + * + * Results: + * None. + * + * Side effects: + * From now on, whenever the I/O channel given by chanPtr 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 there is already an event handler for chan, proc + * and clientData, then the mask will be updated. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_CreateChannelHandler(chan, mask, proc, clientData) + Tcl_Channel chan; /* The channel to create the handler for. */ + int mask; /* OR'ed combination of TCL_READABLE, + * TCL_WRITABLE, and TCL_EXCEPTION: + * indicates conditions under which + * proc should be called. Use 0 to + * disable a registered handler. */ + Tcl_ChannelProc *proc; /* Procedure to call for each + * selected event. */ + ClientData clientData; /* Arbitrary data to pass to proc. */ +{ + ChannelHandler *chPtr; + Channel *chanPtr; + + chanPtr = (Channel *) chan; + + /* + * Ensure that the channel event source is registered with the Tcl + * notification mechanism. + */ + + if (!channelEventSourceCreated) { + channelEventSourceCreated = 1; + Tcl_CreateEventSource(ChannelHandlerSetupProc, ChannelHandlerCheckProc, + (ClientData) NULL); + Tcl_CreateExitHandler(ChannelEventSourceExitProc, (ClientData) NULL); + } + + /* + * Check whether this channel handler is not already registered. If + * it is not, create a new record, else reuse existing record (smash + * current values). + */ + + for (chPtr = chanPtr->chPtr; + chPtr != (ChannelHandler *) NULL; + chPtr = chPtr->nextPtr) { + if ((chPtr->chanPtr == chanPtr) && (chPtr->proc == proc) && + (chPtr->clientData == clientData)) { + break; + } + } + if (chPtr == (ChannelHandler *) NULL) { + chPtr = (ChannelHandler *) ckalloc((unsigned) sizeof(ChannelHandler)); + chPtr->mask = 0; + chPtr->proc = proc; + chPtr->clientData = clientData; + chPtr->chanPtr = chanPtr; + chPtr->nextPtr = chanPtr->chPtr; + chanPtr->chPtr = chPtr; + } + + /* + * 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. + */ + + chPtr->mask = mask; + + /* + * Recompute the interest mask for the channel - this call may actually + * be disabling an existing handler.. + */ + + chanPtr->interestMask = 0; + for (chPtr = chanPtr->chPtr; + chPtr != (ChannelHandler *) NULL; + chPtr = chPtr->nextPtr) { + chanPtr->interestMask |= chPtr->mask; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DeleteChannelHandler -- + * + * Cancel a previously arranged callback arrangement for an IO + * channel. + * + * Results: + * None. + * + * Side effects: + * If a callback was previously registered for this chan, proc and + * clientData , it is removed and the callback will no longer be called + * when the channel becomes ready for IO. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DeleteChannelHandler(chan, proc, clientData) + Tcl_Channel chan; /* The channel for which to remove the + * callback. */ + Tcl_ChannelProc *proc; /* The procedure in the callback to delete. */ + ClientData clientData; /* The client data in the callback + * to delete. */ + +{ + ChannelHandler *chPtr, *prevChPtr; + Channel *chanPtr; + NextChannelHandler *nhPtr; + + chanPtr = (Channel *) chan; + + /* + * Find the entry and the previous one in the list. + */ + + for (prevChPtr = (ChannelHandler *) NULL, chPtr = chanPtr->chPtr; + chPtr != (ChannelHandler *) NULL; + chPtr = chPtr->nextPtr) { + if ((chPtr->chanPtr == chanPtr) && (chPtr->clientData == clientData) + && (chPtr->proc == proc)) { + break; + } + prevChPtr = chPtr; + } + + /* + * If ChannelHandlerEventProc is about to process this handler, tell it to + * process the next one instead - we are going to delete *this* one. + */ + + for (nhPtr = nestedHandlerPtr; + nhPtr != (NextChannelHandler *) NULL; + nhPtr = nhPtr->nestedHandlerPtr) { + if (nhPtr->nextHandlerPtr == chPtr) { + nhPtr->nextHandlerPtr = chPtr->nextPtr; + } + } + + /* + * If found, splice the entry out of the list. + */ + + if (chPtr == (ChannelHandler *) NULL) { + return; + } + + if (prevChPtr == (ChannelHandler *) NULL) { + chanPtr->chPtr = chPtr->nextPtr; + } else { + prevChPtr->nextPtr = chPtr->nextPtr; + } + ckfree((char *) chPtr); + + /* + * Recompute the interest list for the channel, so that infinite loops + * will not result if Tcl_DeleteChanelHandler is called inside an event. + */ + + chanPtr->interestMask = 0; + for (chPtr = chanPtr->chPtr; + chPtr != (ChannelHandler *) NULL; + chPtr = chPtr->nextPtr) { + chanPtr->interestMask |= chPtr->mask; + } +} + +/* + *---------------------------------------------------------------------- + * + * ReturnScriptRecord -- + * + * Get a script stored for this channel with this interpreter. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Sets interp->result to the script. + * + *---------------------------------------------------------------------- + */ + +static void +ReturnScriptRecord(interp, chanPtr, mask) + Tcl_Interp *interp; /* The interpreter in which the script + * is to be executed. */ + Channel *chanPtr; /* The channel for which the script is + * stored. */ + int mask; /* Events in mask must overlap with events + * for which this script is stored. */ +{ + EventScriptRecord *esPtr; + + for (esPtr = chanPtr->scriptRecordPtr; + esPtr != (EventScriptRecord *) NULL; + esPtr = esPtr->nextPtr) { + if ((esPtr->interp == interp) && (esPtr->mask == mask)) { + interp->result = esPtr->script; + return; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * DeleteScriptRecord -- + * + * Delete a script record for this combination of channel, interp + * and mask. + * + * Results: + * None. + * + * Side effects: + * Deletes a script record and cancels a channel event handler. + * + *---------------------------------------------------------------------- + */ + +static void +DeleteScriptRecord(interp, chanPtr, mask) + Tcl_Interp *interp; /* Interpreter in which script was to be + * executed. */ + Channel *chanPtr; /* The channel for which to delete the + * script record (if any). */ + int mask; /* Events in mask must exactly match mask + * of script to delete. */ +{ + EventScriptRecord *esPtr, *prevEsPtr; + + for (esPtr = chanPtr->scriptRecordPtr, + prevEsPtr = (EventScriptRecord *) NULL; + esPtr != (EventScriptRecord *) NULL; + prevEsPtr = esPtr, esPtr = esPtr->nextPtr) { + if ((esPtr->interp == interp) && (esPtr->mask == mask)) { + if (esPtr == chanPtr->scriptRecordPtr) { + chanPtr->scriptRecordPtr = esPtr->nextPtr; + } else { + prevEsPtr->nextPtr = esPtr->nextPtr; + } + + Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr, + ChannelEventScriptInvoker, (ClientData) esPtr); + + Tcl_EventuallyFree((ClientData)esPtr->script, TCL_DYNAMIC); + ckfree((char *) esPtr); + + break; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * CreateScriptRecord -- + * + * Creates a record to store a script to be executed when a specific + * event fires on a specific channel. + * + * Results: + * None. + * + * Side effects: + * Causes the script to be stored for later execution. + * + *---------------------------------------------------------------------- + */ + +static void +CreateScriptRecord(interp, chanPtr, mask, script) + Tcl_Interp *interp; /* Interpreter in which to execute + * the stored script. */ + Channel *chanPtr; /* Channel for which script is to + * be stored. */ + int mask; /* Set of events for which script + * will be invoked. */ + char *script; /* A copy of this script is stored + * in the newly created record. */ +{ + EventScriptRecord *esPtr; + + for (esPtr = chanPtr->scriptRecordPtr; + esPtr != (EventScriptRecord *) NULL; + esPtr = esPtr->nextPtr) { + if ((esPtr->interp == interp) && (esPtr->mask == mask)) { + Tcl_EventuallyFree((ClientData)esPtr->script, TCL_DYNAMIC); + esPtr->script = (char *) NULL; + break; + } + } + if (esPtr == (EventScriptRecord *) NULL) { + esPtr = (EventScriptRecord *) ckalloc((unsigned) + sizeof(EventScriptRecord)); + Tcl_CreateChannelHandler((Tcl_Channel) chanPtr, mask, + ChannelEventScriptInvoker, (ClientData) esPtr); + esPtr->nextPtr = chanPtr->scriptRecordPtr; + chanPtr->scriptRecordPtr = esPtr; + } + esPtr->chanPtr = chanPtr; + esPtr->interp = interp; + esPtr->mask = mask; + esPtr->script = ckalloc((unsigned) (strlen(script) + 1)); + strcpy(esPtr->script, script); +} + +/* + *---------------------------------------------------------------------- + * + * ChannelEventScriptInvoker -- + * + * Invokes a script scheduled by "fileevent" for when the channel + * becomes ready for IO. This function is invoked by the channel + * handler which was created by the Tcl "fileevent" command. + * + * Results: + * None. + * + * Side effects: + * Whatever the script does. + * + *---------------------------------------------------------------------- + */ + +static void +ChannelEventScriptInvoker(clientData, mask) + ClientData clientData; /* The script+interp record. */ + int mask; /* Not used. */ +{ + Tcl_Interp *interp; /* Interpreter in which to eval the script. */ + Channel *chanPtr; /* The channel for which this handler is + * registered. */ + char *script; /* Script to eval. */ + EventScriptRecord *esPtr; /* The event script + interpreter to eval it + * in. */ + int result; /* Result of call to eval script. */ + + esPtr = (EventScriptRecord *) clientData; + + chanPtr = esPtr->chanPtr; + mask = esPtr->mask; + interp = esPtr->interp; + script = esPtr->script; + + /* + * We must preserve the channel, script and interpreter because each of + * these may be deleted in the evaluation. If an error later occurs, we + * want to have the relevant data around for error reporting and so we + * can safely delete it. + */ + + Tcl_Preserve((ClientData) chanPtr); + Tcl_Preserve((ClientData) script); + Tcl_Preserve((ClientData) interp); + result = Tcl_GlobalEval(esPtr->interp, script); + + /* + * On error, cause a background error and remove the channel handler + * and the script record. + */ + + if (result != TCL_OK) { + Tcl_BackgroundError(interp); + DeleteScriptRecord(interp, chanPtr, mask); + } + Tcl_Release((ClientData) chanPtr); + Tcl_Release((ClientData) script); + Tcl_Release((ClientData) interp); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FileEventCmd -- + * + * This procedure implements the "fileevent" Tcl command. See the + * user documentation for details on what it does. This command is + * based on the Tk command "fileevent" which in turn is based on work + * contributed by Mark Diekhans. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * May create a channel handler for the specified channel. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_FileEventCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Interpreter in which the channel + * for which to create the handler + * is found. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Channel *chanPtr; /* The channel to create + * the handler for. */ + Tcl_Channel chan; /* The opaque type for the channel. */ + int c; /* First char of mode argument. */ + int mask; /* Mask for events of interest. */ + size_t length; /* Length of mode argument. */ + + /* + * Parse arguments. + */ + + if ((argc != 3) && (argc != 4)) { + Tcl_AppendResult(interp, "wrong # args: must be \"", argv[0], + " channelId event ?script?", (char *) NULL); + return TCL_ERROR; + } + c = argv[2][0]; + length = strlen(argv[2]); + if ((c == 'r') && (strncmp(argv[2], "readable", length) == 0)) { + mask = TCL_READABLE; + } else if ((c == 'w') && (strncmp(argv[2], "writable", length) == 0)) { + mask = TCL_WRITABLE; + } else { + Tcl_AppendResult(interp, "bad event name \"", argv[2], + "\": must be readable or writable", (char *) NULL); + return TCL_ERROR; + } + chan = Tcl_GetChannel(interp, argv[1], NULL); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + + chanPtr = (Channel *) chan; + if ((chanPtr->flags & mask) == 0) { + Tcl_AppendResult(interp, "channel is not ", + (mask == TCL_READABLE) ? "readable" : "writable", + (char *) NULL); + return TCL_ERROR; + } + + /* + * If we are supposed to return the script, do so. + */ + + if (argc == 3) { + ReturnScriptRecord(interp, chanPtr, mask); + return TCL_OK; + } + + /* + * If we are supposed to delete a stored script, do so. + */ + + if (argv[3][0] == 0) { + DeleteScriptRecord(interp, chanPtr, mask); + return TCL_OK; + } + + /* + * Make the script record that will link between the event and the + * script to invoke. This also creates a channel event handler which + * will evaluate the script in the supplied interpreter. + */ + + CreateScriptRecord(interp, chanPtr, mask, argv[3]); + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclTestChannelCmd -- + * + * Implements the Tcl "testchannel" debugging command and its + * subcommands. This is part of the testing environment but must be + * in this file instead of tclTest.c because it needs access to the + * fields of struct Channel. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +TclTestChannelCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Interpreter for result. */ + int argc; /* Count of additional args. */ + char **argv; /* Additional arg strings. */ +{ + char *cmdName; /* Sub command. */ + Tcl_HashTable *hTblPtr; /* Hash table of channels. */ + Tcl_HashSearch hSearch; /* Search variable. */ + Tcl_HashEntry *hPtr; /* Search variable. */ + Channel *chanPtr; /* The actual channel. */ + Tcl_Channel chan; /* The opaque type. */ + size_t len; /* Length of subcommand string. */ + int IOQueued; /* How much IO is queued inside channel? */ + ChannelBuffer *bufPtr; /* For iterating over queued IO. */ + char buf[128]; /* For sprintf. */ + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " subcommand ?additional args..?\"", (char *) NULL); + return TCL_ERROR; + } + cmdName = argv[1]; + len = strlen(cmdName); + + chanPtr = (Channel *) NULL; + if (argc > 2) { + chan = Tcl_GetChannel(interp, argv[2], NULL); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + chanPtr = (Channel *) chan; + } + + if ((cmdName[0] == 'i') && (strncmp(cmdName, "info", len) == 0)) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " info channelName\"", (char *) NULL); + return TCL_ERROR; + } + Tcl_AppendElement(interp, argv[2]); + Tcl_AppendElement(interp, chanPtr->typePtr->typeName); + if (chanPtr->flags & TCL_READABLE) { + Tcl_AppendElement(interp, "read"); + } else { + Tcl_AppendElement(interp, ""); + } + if (chanPtr->flags & TCL_WRITABLE) { + Tcl_AppendElement(interp, "write"); + } else { + Tcl_AppendElement(interp, ""); + } + if (chanPtr->flags & CHANNEL_NONBLOCKING) { + Tcl_AppendElement(interp, "nonblocking"); + } else { + Tcl_AppendElement(interp, "blocking"); + } + if (chanPtr->flags & CHANNEL_LINEBUFFERED) { + Tcl_AppendElement(interp, "line"); + } else if (chanPtr->flags & CHANNEL_UNBUFFERED) { + Tcl_AppendElement(interp, "none"); + } else { + Tcl_AppendElement(interp, "full"); + } + if (chanPtr->flags & BG_FLUSH_SCHEDULED) { + Tcl_AppendElement(interp, "async_flush"); + } else { + Tcl_AppendElement(interp, ""); + } + if (chanPtr->flags & CHANNEL_EOF) { + Tcl_AppendElement(interp, "eof"); + } else { + Tcl_AppendElement(interp, ""); + } + if (chanPtr->flags & CHANNEL_BLOCKED) { + Tcl_AppendElement(interp, "blocked"); + } else { + Tcl_AppendElement(interp, "unblocked"); + } + if (chanPtr->inputTranslation == TCL_TRANSLATE_AUTO) { + Tcl_AppendElement(interp, "auto"); + if (chanPtr->flags & INPUT_SAW_CR) { + Tcl_AppendElement(interp, "saw_cr"); + } else { + Tcl_AppendElement(interp, ""); + } + } else if (chanPtr->inputTranslation == TCL_TRANSLATE_LF) { + Tcl_AppendElement(interp, "lf"); + Tcl_AppendElement(interp, ""); + } else if (chanPtr->inputTranslation == TCL_TRANSLATE_CR) { + Tcl_AppendElement(interp, "cr"); + Tcl_AppendElement(interp, ""); + } else if (chanPtr->inputTranslation == TCL_TRANSLATE_CRLF) { + Tcl_AppendElement(interp, "crlf"); + if (chanPtr->flags & INPUT_SAW_CR) { + Tcl_AppendElement(interp, "queued_cr"); + } else { + Tcl_AppendElement(interp, ""); + } + } + if (chanPtr->outputTranslation == TCL_TRANSLATE_AUTO) { + Tcl_AppendElement(interp, "auto"); + } else if (chanPtr->outputTranslation == TCL_TRANSLATE_LF) { + Tcl_AppendElement(interp, "lf"); + } else if (chanPtr->outputTranslation == TCL_TRANSLATE_CR) { + Tcl_AppendElement(interp, "cr"); + } else if (chanPtr->outputTranslation == TCL_TRANSLATE_CRLF) { + Tcl_AppendElement(interp, "crlf"); + } + for (IOQueued = 0, bufPtr = chanPtr->inQueueHead; + bufPtr != (ChannelBuffer *) NULL; + bufPtr = bufPtr->nextPtr) { + IOQueued += bufPtr->nextAdded - bufPtr->nextRemoved; + } + sprintf(buf, "%d", IOQueued); + Tcl_AppendElement(interp, buf); + + IOQueued = 0; + if (chanPtr->curOutPtr != (ChannelBuffer *) NULL) { + IOQueued = chanPtr->curOutPtr->nextAdded - + chanPtr->curOutPtr->nextRemoved; + } + for (bufPtr = chanPtr->outQueueHead; + bufPtr != (ChannelBuffer *) NULL; + bufPtr = bufPtr->nextPtr) { + IOQueued += (bufPtr->nextAdded - bufPtr->nextRemoved); + } + sprintf(buf, "%d", IOQueued); + Tcl_AppendElement(interp, buf); + + sprintf(buf, "%d", Tcl_Tell((Tcl_Channel) chanPtr)); + Tcl_AppendElement(interp, buf); + + sprintf(buf, "%d", chanPtr->refCount); + Tcl_AppendElement(interp, buf); + + return TCL_OK; + } + + if ((cmdName[0] == 'i') && + (strncmp(cmdName, "inputbuffered", len) == 0)) { + if (argc != 3) { + Tcl_AppendResult(interp, "channel name required", + (char *) NULL); + return TCL_ERROR; + } + + for (IOQueued = 0, bufPtr = chanPtr->inQueueHead; + bufPtr != (ChannelBuffer *) NULL; + bufPtr = bufPtr->nextPtr) { + IOQueued += bufPtr->nextAdded - bufPtr->nextRemoved; + } + sprintf(buf, "%d", IOQueued); + Tcl_AppendResult(interp, buf, (char *) NULL); + return TCL_OK; + } + + if ((cmdName[0] == 'm') && (strncmp(cmdName, "mode", len) == 0)) { + if (argc != 3) { + Tcl_AppendResult(interp, "channel name required", + (char *) NULL); + return TCL_ERROR; + } + + if (chanPtr->flags & TCL_READABLE) { + Tcl_AppendElement(interp, "read"); + } else { + Tcl_AppendElement(interp, ""); + } + if (chanPtr->flags & TCL_WRITABLE) { + Tcl_AppendElement(interp, "write"); + } else { + Tcl_AppendElement(interp, ""); + } + return TCL_OK; + } + + if ((cmdName[0] == 'n') && (strncmp(cmdName, "name", len) == 0)) { + if (argc != 3) { + Tcl_AppendResult(interp, "channel name required", + (char *) NULL); + return TCL_ERROR; + } + Tcl_AppendResult(interp, chanPtr->channelName, (char *) NULL); + return TCL_OK; + } + + if ((cmdName[0] == 'o') && (strncmp(cmdName, "open", len) == 0)) { + hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclIO", NULL); + if (hTblPtr == (Tcl_HashTable *) NULL) { + return TCL_OK; + } + for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); + hPtr != (Tcl_HashEntry *) NULL; + hPtr = Tcl_NextHashEntry(&hSearch)) { + Tcl_AppendElement(interp, Tcl_GetHashKey(hTblPtr, hPtr)); + } + return TCL_OK; + } + + if ((cmdName[0] == 'o') && + (strncmp(cmdName, "outputbuffered", len) == 0)) { + if (argc != 3) { + Tcl_AppendResult(interp, "channel name required", + (char *) NULL); + return TCL_ERROR; + } + + IOQueued = 0; + if (chanPtr->curOutPtr != (ChannelBuffer *) NULL) { + IOQueued = chanPtr->curOutPtr->nextAdded - + chanPtr->curOutPtr->nextRemoved; + } + for (bufPtr = chanPtr->outQueueHead; + bufPtr != (ChannelBuffer *) NULL; + bufPtr = bufPtr->nextPtr) { + IOQueued += (bufPtr->nextAdded - bufPtr->nextRemoved); + } + sprintf(buf, "%d", IOQueued); + Tcl_AppendResult(interp, buf, (char *) NULL); + return TCL_OK; + } + + if ((cmdName[0] == 'q') && + (strncmp(cmdName, "queuedcr", len) == 0)) { + if (argc != 3) { + Tcl_AppendResult(interp, "channel name required", + (char *) NULL); + return TCL_ERROR; + } + + Tcl_AppendResult(interp, + (chanPtr->flags & INPUT_SAW_CR) ? "1" : "0", + (char *) NULL); + return TCL_OK; + } + + if ((cmdName[0] == 'r') && (strncmp(cmdName, "readable", len) == 0)) { + hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclIO", NULL); + if (hTblPtr == (Tcl_HashTable *) NULL) { + return TCL_OK; + } + for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); + hPtr != (Tcl_HashEntry *) NULL; + hPtr = Tcl_NextHashEntry(&hSearch)) { + chanPtr = (Channel *) Tcl_GetHashValue(hPtr); + if (chanPtr->flags & TCL_READABLE) { + Tcl_AppendElement(interp, Tcl_GetHashKey(hTblPtr, hPtr)); + } + } + return TCL_OK; + } + + if ((cmdName[0] == 'r') && (strncmp(cmdName, "refcount", len) == 0)) { + if (argc != 3) { + Tcl_AppendResult(interp, "channel name required", + (char *) NULL); + return TCL_ERROR; + } + + sprintf(buf, "%d", chanPtr->refCount); + Tcl_AppendResult(interp, buf, (char *) NULL); + return TCL_OK; + } + + if ((cmdName[0] == 't') && (strncmp(cmdName, "type", len) == 0)) { + if (argc != 3) { + Tcl_AppendResult(interp, "channel name required", + (char *) NULL); + return TCL_ERROR; + } + Tcl_AppendResult(interp, chanPtr->typePtr->typeName, (char *) NULL); + return TCL_OK; + } + + if ((cmdName[0] == 'w') && (strncmp(cmdName, "writable", len) == 0)) { + hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclIO", NULL); + if (hTblPtr == (Tcl_HashTable *) NULL) { + return TCL_OK; + } + for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); + hPtr != (Tcl_HashEntry *) NULL; + hPtr = Tcl_NextHashEntry(&hSearch)) { + chanPtr = (Channel *) Tcl_GetHashValue(hPtr); + if (chanPtr->flags & TCL_WRITABLE) { + Tcl_AppendElement(interp, Tcl_GetHashKey(hTblPtr, hPtr)); + } + } + return TCL_OK; + } + + Tcl_AppendResult(interp, "bad option \"", cmdName, "\": should be ", + "info, open, readable, or writable", + (char *) NULL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * TclTestChannelEventCmd -- + * + * This procedure implements the "testchannelevent" command. It is + * used to test the Tcl channel event mechanism. It is present in + * this file instead of tclTest.c because it needs access to the + * internal structure of the channel. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Creates, deletes and returns channel event handlers. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +TclTestChannelEventCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Channel *chanPtr; + EventScriptRecord *esPtr, *prevEsPtr, *nextEsPtr; + char *cmd; + int index, i, mask, len; + + if ((argc < 3) || (argc > 5)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " channelName cmd ?arg1? ?arg2?\"", (char *) NULL); + return TCL_ERROR; + } + chanPtr = (Channel *) Tcl_GetChannel(interp, argv[1], NULL); + if (chanPtr == (Channel *) NULL) { + return TCL_ERROR; + } + cmd = argv[2]; + len = strlen(cmd); + if ((cmd[0] == 'a') && (strncmp(cmd, "add", (unsigned) len) == 0)) { + if (argc != 5) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " channelName add eventSpec script\"", (char *) NULL); + return TCL_ERROR; + } + if (strcmp(argv[3], "readable") == 0) { + mask = TCL_READABLE; + } else if (strcmp(argv[3], "writable") == 0) { + mask = TCL_WRITABLE; + } else { + Tcl_AppendResult(interp, "bad event name \"", argv[3], + "\": must be readable or writable", (char *) NULL); + return TCL_ERROR; + } + + esPtr = (EventScriptRecord *) ckalloc((unsigned) + sizeof(EventScriptRecord)); + esPtr->nextPtr = chanPtr->scriptRecordPtr; + chanPtr->scriptRecordPtr = esPtr; + + esPtr->chanPtr = chanPtr; + esPtr->interp = interp; + esPtr->mask = mask; + esPtr->script = ckalloc((unsigned) (strlen(argv[4]) + 1)); + strcpy(esPtr->script, argv[4]); + + Tcl_CreateChannelHandler((Tcl_Channel) chanPtr, mask, + ChannelEventScriptInvoker, (ClientData) esPtr); + + return TCL_OK; + } + + if ((cmd[0] == 'd') && (strncmp(cmd, "delete", (unsigned) len) == 0)) { + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " channelName delete index\"", (char *) NULL); + return TCL_ERROR; + } + if (Tcl_GetInt(interp, argv[3], &index) == TCL_ERROR) { + return TCL_ERROR; + } + if (index < 0) { + Tcl_AppendResult(interp, "bad event index: ", argv[3], + ": must be nonnegative", (char *) NULL); + return TCL_ERROR; + } + for (i = 0, esPtr = chanPtr->scriptRecordPtr; + (i < index) && (esPtr != (EventScriptRecord *) NULL); + i++, esPtr = esPtr->nextPtr) { + /* Empty loop body. */ + } + if (esPtr == (EventScriptRecord *) NULL) { + Tcl_AppendResult(interp, "bad event index ", argv[3], + ": out of range", (char *) NULL); + return TCL_ERROR; + } + if (esPtr == chanPtr->scriptRecordPtr) { + chanPtr->scriptRecordPtr = esPtr->nextPtr; + } else { + for (prevEsPtr = chanPtr->scriptRecordPtr; + (prevEsPtr != (EventScriptRecord *) NULL) && + (prevEsPtr->nextPtr != esPtr); + prevEsPtr = prevEsPtr->nextPtr) { + /* Empty loop body. */ + } + if (prevEsPtr == (EventScriptRecord *) NULL) { + panic("TclTestChannelEventCmd: damaged event script list"); + } + prevEsPtr->nextPtr = esPtr->nextPtr; + } + Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr, + ChannelEventScriptInvoker, (ClientData) esPtr); + Tcl_EventuallyFree((ClientData)esPtr->script, TCL_DYNAMIC); + ckfree((char *) esPtr); + + return TCL_OK; + } + + if ((cmd[0] == 'l') && (strncmp(cmd, "list", (unsigned) len) == 0)) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " channelName list\"", (char *) NULL); + return TCL_ERROR; + } + for (esPtr = chanPtr->scriptRecordPtr; + esPtr != (EventScriptRecord *) NULL; + esPtr = esPtr->nextPtr) { + Tcl_AppendElement(interp, + esPtr->mask == TCL_READABLE ? "readable" : "writable"); + Tcl_AppendElement(interp, esPtr->script); + } + return TCL_OK; + } + + if ((cmd[0] == 'r') && (strncmp(cmd, "removeall", (unsigned) len) == 0)) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " channelName removeall\"", (char *) NULL); + return TCL_ERROR; + } + for (esPtr = chanPtr->scriptRecordPtr; + esPtr != (EventScriptRecord *) NULL; + esPtr = nextEsPtr) { + nextEsPtr = esPtr->nextPtr; + Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr, + ChannelEventScriptInvoker, (ClientData) esPtr); + Tcl_EventuallyFree((ClientData)esPtr->script, TCL_DYNAMIC); + ckfree((char *) esPtr); + } + chanPtr->scriptRecordPtr = (EventScriptRecord *) NULL; + return TCL_OK; + } + + Tcl_AppendResult(interp, "bad command ", cmd, ", must be one of ", + "add, delete, list, or removeall", (char *) NULL); + return TCL_ERROR; + +} diff --git a/contrib/tcl/generic/tclIOCmd.c b/contrib/tcl/generic/tclIOCmd.c new file mode 100644 index 0000000000000..d852388a5cf58 --- /dev/null +++ b/contrib/tcl/generic/tclIOCmd.c @@ -0,0 +1,1510 @@ +/* + * tclIOCmd.c -- + * + * Contains the definitions of most of the Tcl commands relating to IO. + * + * 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: @(#) tclIOCmd.c 1.94 96/04/15 06:40:02 + */ + +#include "tclInt.h" +#include "tclPort.h" + +/* + * Return at most this number of bytes in one call to Tcl_Read: + */ + +#define TCL_READ_CHUNK_SIZE 4096 + +/* + * Callback structure for accept callback in a TCP server. + */ + +typedef struct AcceptCallback { + char *script; /* Script to invoke. */ + Tcl_Interp *interp; /* Interpreter in which to run it. */ +} AcceptCallback; + +/* + * Static functions for this file: + */ + +static void AcceptCallbackProc _ANSI_ARGS_((ClientData callbackData, + Tcl_Channel chan, char *address, int port)); +static void RegisterTcpServerInterpCleanup _ANSI_ARGS_((Tcl_Interp *interp, + AcceptCallback *acceptCallbackPtr)); +static void TcpAcceptCallbacksDeleteProc _ANSI_ARGS_(( + ClientData clientData, Tcl_Interp *interp)); +static void TcpServerCloseProc _ANSI_ARGS_((ClientData callbackData)); +static void UnregisterTcpServerInterpCleanupProc _ANSI_ARGS_(( + Tcl_Interp *interp, AcceptCallback *acceptCallbackPtr)); + +/* + *---------------------------------------------------------------------- + * + * Tcl_PutsCmd -- + * + * This procedure is invoked to process the "puts" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Produces output on a channel. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_PutsCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tcl_Channel chan; /* The channel to puts on. */ + int i; /* Counter. */ + int newline; /* Add a newline at end? */ + char *channelId; /* Name of channel for puts. */ + int result; /* Result of puts operation. */ + int mode; /* Mode in which channel is opened. */ + + i = 1; + newline = 1; + if ((argc >= 2) && (strcmp(argv[1], "-nonewline") == 0)) { + newline = 0; + i++; + } + if ((i < (argc-3)) || (i >= argc)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " ?-nonewline? ?channelId? string\"", (char *) NULL); + return TCL_ERROR; + } + + /* + * The code below provides backwards compatibility with an old + * form of the command that is no longer recommended or documented. + */ + + if (i == (argc-3)) { + if (strncmp(argv[i+2], "nonewline", strlen(argv[i+2])) != 0) { + Tcl_AppendResult(interp, "bad argument \"", argv[i+2], + "\": should be \"nonewline\"", (char *) NULL); + return TCL_ERROR; + } + newline = 0; + } + if (i == (argc-1)) { + channelId = "stdout"; + } else { + channelId = argv[i]; + i++; + } + chan = Tcl_GetChannel(interp, channelId, &mode); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + if ((mode & TCL_WRITABLE) == 0) { + Tcl_AppendResult(interp, "channel \"", channelId, + "\" wasn't opened for writing", (char *) NULL); + return TCL_ERROR; + } + + result = Tcl_Write(chan, argv[i], -1); + if (result < 0) { + goto error; + } + if (newline != 0) { + result = Tcl_Write(chan, "\n", 1); + if (result < 0) { + goto error; + } + } + return TCL_OK; +error: + Tcl_AppendResult(interp, "error writing \"", Tcl_GetChannelName(chan), + "\": ", Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FlushCmd -- + * + * This procedure is called to process the Tcl "flush" command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * May cause output to appear on the specified channel. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_FlushCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tcl_Channel chan; /* The channel to flush on. */ + int result; /* Result of call to channel + * level function. */ + int mode; /* Mode in which channel is opened. */ + + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " channelId\"", (char *) NULL); + return TCL_ERROR; + } + chan = Tcl_GetChannel(interp, argv[1], &mode); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + if ((mode & TCL_WRITABLE) == 0) { + Tcl_AppendResult(interp, "channel \"", argv[1], + "\" wasn't opened for writing", (char *) NULL); + return TCL_ERROR; + } + + result = Tcl_Flush(chan); + if (result != TCL_OK) { + Tcl_AppendResult(interp, "error flushing \"", Tcl_GetChannelName(chan), + "\": ", Tcl_PosixError(interp), (char *) NULL); + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetsCmd -- + * + * This procedure is called to process the Tcl "gets" command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * May consume input from channel. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_GetsCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tcl_Channel chan; /* The channel to read from. */ + char *varName; /* Assign to this variable? */ + char buf[128]; /* Buffer to store string + * representation of how long + * a line was read. */ + Tcl_DString ds; /* Dynamic string to hold the + * buffer for the line just read. */ + int lineLen; /* Length of line just read. */ + int mode; /* Mode in which channel is opened. */ + + if ((argc != 2) && (argc != 3)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " channelId ?varName?\"", (char *) NULL); + return TCL_ERROR; + } + chan = Tcl_GetChannel(interp, argv[1], &mode); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + if ((mode & TCL_READABLE) == 0) { + Tcl_AppendResult(interp, "channel \"", argv[1], + "\" wasn't opened for reading", (char *) NULL); + return TCL_ERROR; + } + + if (argc != 3) { + varName = (char *) NULL; + } else { + varName = argv[2]; + } + Tcl_DStringInit(&ds); + lineLen = Tcl_Gets(chan, &ds); + if (lineLen < 0) { + if (!Tcl_Eof(chan) && !Tcl_InputBlocked(chan)) { + Tcl_DStringFree(&ds); + Tcl_AppendResult(interp, "error reading \"", + Tcl_GetChannelName(chan), "\": ", Tcl_PosixError(interp), + (char *) NULL); + return TCL_ERROR; + } + lineLen = -1; + } + if (varName == (char *) NULL) { + Tcl_DStringResult(interp, &ds); + } else { + if (Tcl_SetVar(interp, varName, Tcl_DStringValue(&ds), + TCL_LEAVE_ERR_MSG) == NULL) { + Tcl_DStringFree(&ds); + return TCL_ERROR; + } + Tcl_ResetResult(interp); + sprintf(buf, "%d", lineLen); + Tcl_AppendResult(interp, buf, (char *) NULL); + } + Tcl_DStringFree(&ds); + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ReadCmd -- + * + * This procedure is invoked to process the Tcl "read" command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * May consume input from channel. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_ReadCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tcl_Channel chan; /* The channel to read from. */ + int newline, i; /* Discard newline at end? */ + int toRead; /* How many bytes to read? */ + int toReadNow; /* How many bytes to attempt to + * read in the current iteration? */ + int charactersRead; /* How many characters were read? */ + int charactersReadNow; /* How many characters were read + * in this iteration? */ + int mode; /* Mode in which channel is opened. */ + Tcl_DString ds; /* Used to accumulate the data + * read by Tcl_Read. */ + int bufSize; /* Channel buffer size; used to decide + * in what chunk sizes to read from + * the channel. */ + + if ((argc != 2) && (argc != 3)) { +argerror: + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " channelId ?numBytes?\" or \"", argv[0], + " ?-nonewline? channelId\"", (char *) NULL); + return TCL_ERROR; + } + i = 1; + newline = 0; + if (strcmp(argv[i], "-nonewline") == 0) { + newline = 1; + i++; + } + + if (i == argc) { + goto argerror; + } + + chan = Tcl_GetChannel(interp, argv[i], &mode); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + if ((mode & TCL_READABLE) == 0) { + Tcl_AppendResult(interp, "channel \"", argv[i], + "\" wasn't opened for reading", (char *) NULL); + return TCL_ERROR; + } + + i++; /* Consumed channel name. */ + + /* + * Compute how many bytes to read, and see whether the final + * newline should be dropped. + */ + + toRead = INT_MAX; + if (i < argc) { + if (isdigit((unsigned char) (argv[i][0]))) { + if (Tcl_GetInt(interp, argv[i], &toRead) != TCL_OK) { + return TCL_ERROR; + } + } else if (strcmp(argv[i], "nonewline") == 0) { + newline = 1; + } else { + Tcl_AppendResult(interp, "bad argument \"", argv[i], + "\": should be \"nonewline\"", (char *) NULL); + return TCL_ERROR; + } + } + + bufSize = Tcl_GetChannelBufferSize(chan); + Tcl_DStringInit(&ds); + for (charactersRead = 0; charactersRead < toRead; ) { + toReadNow = toRead - charactersRead; + if (toReadNow > bufSize) { + toReadNow = bufSize; + } + Tcl_DStringSetLength(&ds, charactersRead + toReadNow); + charactersReadNow = + Tcl_Read(chan, Tcl_DStringValue(&ds) + charactersRead, toReadNow); + if (charactersReadNow < 0) { + Tcl_DStringFree(&ds); + Tcl_AppendResult(interp, "error reading \"", + Tcl_GetChannelName(chan), "\": ", + Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; + } + + /* + * If we had a short read it means that we have either EOF + * or BLOCKED on the channel, so break out. + */ + + charactersRead += charactersReadNow; + if (charactersReadNow < toReadNow) { + break; /* Out of "for" loop. */ + } + } + + /* + * Tcl_Read does not put a NULL at the end of the string, so we must + * do it here. + */ + + Tcl_DStringSetLength(&ds, charactersRead); + Tcl_DStringResult(interp, &ds); + Tcl_DStringFree(&ds); + + /* + * If requested, remove the last newline in the channel if at EOF. + */ + + if ((charactersRead > 0) && (newline) && + (interp->result[charactersRead-1] == '\n')) { + interp->result[charactersRead-1] = '\0'; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclUnsupported0Cmd -- + * + * This procedure is invoked to process the Tcl "unsupported0" command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * May copy a chunk from one channel to another. + * + *---------------------------------------------------------------------- + */ + +int +TclUnsupported0Cmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Interpreter in which both channels + * are defined. */ + int argc; /* How many arguments? */ + char **argv; /* The argument strings. */ +{ + Tcl_Channel inChan, outChan; + int requested; + char *bufPtr; + int actuallyRead, actuallyWritten, totalRead, toReadNow, mode; + + /* + * Assume we want to copy the entire channel. + */ + + requested = INT_MAX; + + if ((argc < 3) || (argc > 4)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " inChanId outChanId ?chunkSize?\"", (char *) NULL); + return TCL_ERROR; + } + inChan = Tcl_GetChannel(interp, argv[1], &mode); + if (inChan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + if ((mode & TCL_READABLE) == 0) { + Tcl_AppendResult(interp, "channel \"", argv[1], + "\" wasn't opened for reading", (char *) NULL); + return TCL_ERROR; + } + outChan = Tcl_GetChannel(interp, argv[2], &mode); + if (outChan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + if ((mode & TCL_WRITABLE) == 0) { + Tcl_AppendResult(interp, "channel \"", argv[2], + "\" wasn't opened for writing", (char *) NULL); + return TCL_ERROR; + } + + if (argc == 4) { + if (Tcl_GetInt(interp, argv[3], &requested) != TCL_OK) { + return TCL_ERROR; + } + if (requested < 0) { + requested = INT_MAX; + } + } + + bufPtr = ckalloc((unsigned) TCL_READ_CHUNK_SIZE); + for (totalRead = 0; + requested > 0; + totalRead += actuallyRead, requested -= actuallyRead) { + toReadNow = requested; + if (toReadNow > TCL_READ_CHUNK_SIZE) { + toReadNow = TCL_READ_CHUNK_SIZE; + } + actuallyRead = Tcl_Read(inChan, bufPtr, toReadNow); + if (actuallyRead < 0) { + ckfree(bufPtr); + Tcl_AppendResult(interp, argv[0], ": ", Tcl_GetChannelName(inChan), + Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; + } + if (actuallyRead == 0) { + ckfree(bufPtr); + sprintf(interp->result, "%d", totalRead); + return TCL_OK; + } + actuallyWritten = Tcl_Write(outChan, bufPtr, actuallyRead); + if (actuallyWritten < 0) { + ckfree(bufPtr); + Tcl_AppendResult(interp, argv[0], ": ", Tcl_GetChannelName(outChan), + Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; + } + } + ckfree(bufPtr); + + sprintf(interp->result, "%d", totalRead); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SeekCmd -- + * + * This procedure is invoked to process the Tcl "seek" command. See + * the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Moves the position of the access point on the specified channel. + * May flush queued output. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_SeekCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tcl_Channel chan; /* The channel to tell on. */ + int offset, mode; /* Where to seek? */ + int result; /* Of calling Tcl_Seek. */ + + if ((argc != 3) && (argc != 4)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " channelId offset ?origin?\"", (char *) NULL); + return TCL_ERROR; + } + chan = Tcl_GetChannel(interp, argv[1], NULL); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + if (Tcl_GetInt(interp, argv[2], &offset) != TCL_OK) { + return TCL_ERROR; + } + mode = SEEK_SET; + if (argc == 4) { + size_t length; + int c; + + length = strlen(argv[3]); + c = argv[3][0]; + if ((c == 's') && (strncmp(argv[3], "start", length) == 0)) { + mode = SEEK_SET; + } else if ((c == 'c') && (strncmp(argv[3], "current", length) == 0)) { + mode = SEEK_CUR; + } else if ((c == 'e') && (strncmp(argv[3], "end", length) == 0)) { + mode = SEEK_END; + } else { + Tcl_AppendResult(interp, "bad origin \"", argv[3], + "\": should be start, current, or end", (char *) NULL); + return TCL_ERROR; + } + } + + result = Tcl_Seek(chan, offset, mode); + if (result < 0) { + Tcl_AppendResult(interp, "error during seek on \"", + Tcl_GetChannelName(chan), "\": ", + Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_TellCmd -- + * + * This procedure is invoked to process the Tcl "tell" command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_TellCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tcl_Channel chan; /* The channel to tell on. */ + + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " channelId\"", (char *) NULL); + return TCL_ERROR; + } + /* + * Try to find a channel with the right name and permissions in + * the IO channel table of this interpreter. + */ + + chan = Tcl_GetChannel(interp, argv[1], NULL); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + sprintf(interp->result, "%d", Tcl_Tell(chan)); + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CloseCmd -- + * + * This procedure is invoked to process the Tcl "close" command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * May discard queued input; may flush queued output. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_CloseCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tcl_Channel chan; /* The channel to close. */ + int len; /* Length of error output. */ + + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " channelId\"", (char *) NULL); + return TCL_ERROR; + } + chan = Tcl_GetChannel(interp, argv[1], NULL); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + if (Tcl_UnregisterChannel(interp, chan) != TCL_OK) { + + /* + * If there is an error message and it ends with a newline, remove + * the newline. This is done for command pipeline channels where the + * error output from the subprocesses is stored in interp->result. + * + * NOTE: This is likely to not have any effect on regular error + * messages produced by drivers during the closing of a channel, + * because the Tcl convention is that such error messages do not + * have a terminating newline. + */ + + len = strlen(interp->result); + if ((len > 0) && (interp->result[len - 1] == '\n')) { + interp->result[len - 1] = '\0'; + } + + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FconfigureCmd -- + * + * This procedure is invoked to process the Tcl "fconfigure" command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * May modify the behavior of an IO channel. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_FconfigureCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tcl_Channel chan; /* The channel to set a mode on. */ + int result; /* Of Tcl_Set/GetChannelOption. */ + int i; /* Iterate over arg-value pairs. */ + Tcl_DString ds; /* DString to hold result of + * calling Tcl_GetChannelOption. */ + + if ((argc < 2) || (((argc % 2) == 1) && (argc != 3))) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " channelId ?optionName? ?value? ?optionName value?...\"", + (char *) NULL); + return TCL_ERROR; + } + chan = Tcl_GetChannel(interp, argv[1], NULL); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + if (argc == 2) { + Tcl_DStringInit(&ds); + if (Tcl_GetChannelOption(chan, (char *) NULL, &ds) != TCL_OK) { + Tcl_AppendResult(interp, "option retrieval failed", + (char *) NULL); + return TCL_ERROR; + } + Tcl_DStringResult(interp, &ds); + Tcl_DStringFree(&ds); + return TCL_OK; + } + if (argc == 3) { + Tcl_DStringInit(&ds); + if (Tcl_GetChannelOption(chan, argv[2], &ds) != TCL_OK) { + Tcl_DStringFree(&ds); + Tcl_AppendResult(interp, "bad option \"", argv[2], + "\": must be -blocking, -buffering, -buffersize, ", + "-eofchar, -translation, ", + "or a channel type specific option", (char *) NULL); + return TCL_ERROR; + } + Tcl_DStringResult(interp, &ds); + Tcl_DStringFree(&ds); + return TCL_OK; + } + for (i = 3; i < argc; i += 2) { + result = Tcl_SetChannelOption(interp, chan, argv[i-1], argv[i]); + if (result != TCL_OK) { + return result; + } + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_EofCmd -- + * + * This procedure is invoked to process the Tcl "eof" command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Sets interp->result to "0" or "1" depending on whether the + * specified channel has an EOF condition. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_EofCmd(unused, interp, argc, argv) + ClientData unused; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tcl_Channel chan; /* The channel to query for EOF. */ + int mode; /* Mode in which channel is opened. */ + + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " channelId\"", (char *) NULL); + return TCL_ERROR; + } + chan = Tcl_GetChannel(interp, argv[1], &mode); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + sprintf(interp->result, "%d", Tcl_Eof(chan) ? 1 : 0); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ExecCmd -- + * + * This procedure is invoked to process the "exec" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_ExecCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ +#ifdef MAC_TCL + Tcl_AppendResult(interp, "exec not implemented under Mac OS", + (char *)NULL); + return TCL_ERROR; +#else /* !MAC_TCL */ + int keepNewline, firstWord, background, length, result; + Tcl_Channel chan; + Tcl_DString ds; + int readSoFar, readNow, bufSize; + + /* + * Check for a leading "-keepnewline" argument. + */ + + keepNewline = 0; + for (firstWord = 1; (firstWord < argc) && (argv[firstWord][0] == '-'); + firstWord++) { + if (strcmp(argv[firstWord], "-keepnewline") == 0) { + keepNewline = 1; + } else if (strcmp(argv[firstWord], "--") == 0) { + firstWord++; + break; + } else { + Tcl_AppendResult(interp, "bad switch \"", argv[firstWord], + "\": must be -keepnewline or --", (char *) NULL); + return TCL_ERROR; + } + } + + if (argc <= firstWord) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " ?switches? arg ?arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + + /* + * See if the command is to be run in background. + */ + + background = 0; + if ((argv[argc-1][0] == '&') && (argv[argc-1][1] == 0)) { + argc--; + argv[argc] = NULL; + background = 1; + } + + chan = Tcl_OpenCommandChannel(interp, argc-firstWord, + argv+firstWord, + (background ? 0 : TCL_STDOUT | TCL_STDERR)); + + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + + if (background) { + + /* + * Get the list of PIDs from the pipeline into interp->result and + * detach the PIDs (instead of waiting for them). + */ + + TclGetAndDetachPids(interp, chan); + + if (Tcl_Close(interp, chan) != TCL_OK) { + return TCL_ERROR; + } + return TCL_OK; + } + + if (Tcl_GetChannelFile(chan, TCL_READABLE) != NULL) { +#define EXEC_BUFFER_SIZE 4096 + + Tcl_DStringInit(&ds); + readSoFar = 0; bufSize = 0; + while (1) { + bufSize += EXEC_BUFFER_SIZE; + Tcl_DStringSetLength(&ds, bufSize); + readNow = Tcl_Read(chan, Tcl_DStringValue(&ds) + readSoFar, + EXEC_BUFFER_SIZE); + if (readNow < 0) { + Tcl_DStringFree(&ds); + Tcl_AppendResult(interp, + "error reading output from command: ", + Tcl_PosixError(interp), (char *) NULL); + return TCL_ERROR; + } + readSoFar += readNow; + if (readNow < EXEC_BUFFER_SIZE) { + break; /* Out of "while (1)" loop. */ + } + } + Tcl_DStringSetLength(&ds, readSoFar); + Tcl_DStringResult(interp, &ds); + Tcl_DStringFree(&ds); + } + + result = Tcl_Close(interp, chan); + + /* + * If the last character of interp->result is a newline, then remove + * the newline character (the newline would just confuse things). + * Special hack: must replace the old terminating null character + * as a signal to Tcl_AppendResult et al. that we've mucked with + * the string. + */ + + length = strlen(interp->result); + if (!keepNewline && (length > 0) && + (interp->result[length-1] == '\n')) { + interp->result[length-1] = '\0'; + interp->result[length] = 'x'; + } + + return result; +#endif /* !MAC_TCL */ +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FblockedCmd -- + * + * This procedure is invoked to process the Tcl "fblocked" command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Sets interp->result to "0" or "1" depending on whether the + * a preceding input operation on the channel would have blocked. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_FblockedCmd(unused, interp, argc, argv) + ClientData unused; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tcl_Channel chan; /* The channel to query for blocked. */ + int mode; /* Mode in which channel was opened. */ + + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " channelId\"", (char *) NULL); + return TCL_ERROR; + } + chan = Tcl_GetChannel(interp, argv[1], &mode); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + if ((mode & TCL_READABLE) == 0) { + Tcl_AppendResult(interp, "channel \"", argv[1], + "\" wasn't opened for reading", (char *) NULL); + return TCL_ERROR; + } + + sprintf(interp->result, "%d", Tcl_InputBlocked(chan) ? 1 : 0); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_OpenCmd -- + * + * This procedure is invoked to process the "open" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_OpenCmd(notUsed, interp, argc, argv) + ClientData notUsed; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int pipeline, prot; + char *modeString; + Tcl_Channel chan; + + if ((argc < 2) || (argc > 4)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " fileName ?access? ?permissions?\"", (char *) NULL); + return TCL_ERROR; + } + prot = 0666; + if (argc == 2) { + modeString = "r"; + } else { + modeString = argv[2]; + if (argc == 4) { + if (Tcl_GetInt(interp, argv[3], &prot) != TCL_OK) { + return TCL_ERROR; + } + } + } + + pipeline = 0; + if (argv[1][0] == '|') { + pipeline = 1; + } + + /* + * Open the file or create a process pipeline. + */ + + if (!pipeline) { + chan = Tcl_OpenFileChannel(interp, argv[1], modeString, prot); + } else { + int mode, seekFlag, cmdArgc; + char **cmdArgv; + + if (Tcl_SplitList(interp, argv[1]+1, &cmdArgc, &cmdArgv) != TCL_OK) { + return TCL_ERROR; + } + + mode = TclGetOpenMode(interp, modeString, &seekFlag); + if (mode == -1) { + chan = NULL; + } else { + int flags = TCL_STDERR | TCL_ENFORCE_MODE; + switch (mode & (O_RDONLY | O_WRONLY | O_RDWR)) { + case O_RDONLY: + flags |= TCL_STDOUT; + break; + case O_WRONLY: + flags |= TCL_STDIN; + break; + case O_RDWR: + flags |= (TCL_STDIN | TCL_STDOUT); + break; + default: + panic("Tcl_OpenCmd: invalid mode value"); + break; + } + chan = Tcl_OpenCommandChannel(interp, cmdArgc, cmdArgv, flags); + } + ckfree((char *) cmdArgv); + } + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + Tcl_RegisterChannel(interp, chan); + Tcl_AppendResult(interp, Tcl_GetChannelName(chan), (char *) NULL); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TcpAcceptCallbacksDeleteProc -- + * + * Assocdata cleanup routine called when an interpreter is being + * deleted to set the interp field of all the accept callback records + * registered with the interpreter to NULL. This will prevent the + * interpreter from being used in the future to eval accept scripts. + * + * Results: + * None. + * + * Side effects: + * Deallocates memory and sets the interp field of all the accept + * callback records to NULL to prevent this interpreter from being + * used subsequently to eval accept scripts. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static void +TcpAcceptCallbacksDeleteProc(clientData, interp) + ClientData clientData; /* Data which was passed when the assocdata + * was registered. */ + Tcl_Interp *interp; /* Interpreter being deleted - not used. */ +{ + Tcl_HashTable *hTblPtr; + Tcl_HashEntry *hPtr; + Tcl_HashSearch hSearch; + AcceptCallback *acceptCallbackPtr; + + hTblPtr = (Tcl_HashTable *) clientData; + for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); + hPtr != (Tcl_HashEntry *) NULL; + hPtr = Tcl_NextHashEntry(&hSearch)) { + acceptCallbackPtr = (AcceptCallback *) Tcl_GetHashValue(hPtr); + acceptCallbackPtr->interp = (Tcl_Interp *) NULL; + } + Tcl_DeleteHashTable(hTblPtr); + ckfree((char *) hTblPtr); +} + +/* + *---------------------------------------------------------------------- + * + * RegisterTcpServerInterpCleanup -- + * + * Registers an accept callback record to have its interp + * field set to NULL when the interpreter is deleted. + * + * Results: + * None. + * + * Side effects: + * When, in the future, the interpreter is deleted, the interp + * field of the accept callback data structure will be set to + * NULL. This will prevent attempts to eval the accept script + * in a deleted interpreter. + * + *---------------------------------------------------------------------- + */ + +static void +RegisterTcpServerInterpCleanup(interp, acceptCallbackPtr) + Tcl_Interp *interp; /* Interpreter for which we want to be + * informed of deletion. */ + AcceptCallback *acceptCallbackPtr; + /* The accept callback record whose + * interp field we want set to NULL when + * the interpreter is deleted. */ +{ + Tcl_HashTable *hTblPtr; /* Hash table for accept callback + * records to smash when the interpreter + * will be deleted. */ + Tcl_HashEntry *hPtr; /* Entry for this record. */ + int new; /* Is the entry new? */ + + hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, + "tclTCPAcceptCallbacks", + NULL); + if (hTblPtr == (Tcl_HashTable *) NULL) { + hTblPtr = (Tcl_HashTable *) ckalloc((unsigned) sizeof(Tcl_HashTable)); + Tcl_InitHashTable(hTblPtr, TCL_ONE_WORD_KEYS); + (void) Tcl_SetAssocData(interp, "tclTCPAcceptCallbacks", + TcpAcceptCallbacksDeleteProc, (ClientData) hTblPtr); + } + hPtr = Tcl_CreateHashEntry(hTblPtr, (char *) acceptCallbackPtr, &new); + if (!new) { + panic("RegisterTcpServerCleanup: damaged accept record table"); + } + Tcl_SetHashValue(hPtr, (ClientData) acceptCallbackPtr); +} + +/* + *---------------------------------------------------------------------- + * + * UnregisterTcpServerInterpCleanupProc -- + * + * Unregister a previously registered accept callback record. The + * interp field of this record will no longer be set to NULL in + * the future when the interpreter is deleted. + * + * Results: + * None. + * + * Side effects: + * Prevents the interp field of the accept callback record from + * being set to NULL in the future when the interpreter is deleted. + * + *---------------------------------------------------------------------- + */ + +static void +UnregisterTcpServerInterpCleanupProc(interp, acceptCallbackPtr) + Tcl_Interp *interp; /* Interpreter in which the accept callback + * record was registered. */ + AcceptCallback *acceptCallbackPtr; + /* The record for which to delete the + * registration. */ +{ + Tcl_HashTable *hTblPtr; + Tcl_HashEntry *hPtr; + + hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, + "tclTCPAcceptCallbacks", NULL); + if (hTblPtr == (Tcl_HashTable *) NULL) { + return; + } + hPtr = Tcl_FindHashEntry(hTblPtr, (char *) acceptCallbackPtr); + if (hPtr == (Tcl_HashEntry *) NULL) { + return; + } + Tcl_DeleteHashEntry(hPtr); +} + +/* + *---------------------------------------------------------------------- + * + * AcceptCallbackProc -- + * + * This callback is invoked by the TCP channel driver when it + * accepts a new connection from a client on a server socket. + * + * Results: + * None. + * + * Side effects: + * Whatever the script does. + * + *---------------------------------------------------------------------- + */ + +static void +AcceptCallbackProc(callbackData, chan, address, port) + ClientData callbackData; /* The data stored when the callback + * was created in the call to + * Tcl_OpenTcpServer. */ + Tcl_Channel chan; /* Channel for the newly accepted + * connection. */ + char *address; /* Address of client that was + * accepted. */ + int port; /* Port of client that was accepted. */ +{ + AcceptCallback *acceptCallbackPtr; + Tcl_Interp *interp; + char *script; + char portBuf[10]; + int result; + + acceptCallbackPtr = (AcceptCallback *) callbackData; + + /* + * Check if the callback is still valid; the interpreter may have gone + * away, this is signalled by setting the interp field of the callback + * data to NULL. + */ + + if (acceptCallbackPtr->interp != (Tcl_Interp *) NULL) { + + script = acceptCallbackPtr->script; + interp = acceptCallbackPtr->interp; + + Tcl_Preserve((ClientData) script); + Tcl_Preserve((ClientData) interp); + + sprintf(portBuf, "%d", port); + Tcl_RegisterChannel(interp, chan); + result = Tcl_VarEval(interp, script, " ", Tcl_GetChannelName(chan), + " ", address, " ", portBuf, (char *) NULL); + if (result != TCL_OK) { + Tcl_BackgroundError(interp); + Tcl_UnregisterChannel(interp, chan); + } + Tcl_Release((ClientData) interp); + Tcl_Release((ClientData) script); + } else { + + /* + * The interpreter has been deleted, so there is no useful + * way to utilize the client socket - just close it. + */ + + Tcl_Close((Tcl_Interp *) NULL, chan); + } +} + +/* + *---------------------------------------------------------------------- + * + * TcpServerCloseProc -- + * + * This callback is called when the TCP server channel for which it + * was registered is being closed. It informs the interpreter in + * which the accept script is evaluated (if that interpreter still + * exists) that this channel no longer needs to be informed if the + * interpreter is deleted. + * + * Results: + * None. + * + * Side effects: + * In the future, if the interpreter is deleted this channel will + * no longer be informed. + * + *---------------------------------------------------------------------- + */ + +static void +TcpServerCloseProc(callbackData) + ClientData callbackData; /* The data passed in the call to + * Tcl_CreateCloseHandler. */ +{ + AcceptCallback *acceptCallbackPtr; + /* The actual data. */ + + acceptCallbackPtr = (AcceptCallback *) callbackData; + if (acceptCallbackPtr->interp != (Tcl_Interp *) NULL) { + UnregisterTcpServerInterpCleanupProc(acceptCallbackPtr->interp, + acceptCallbackPtr); + } + Tcl_EventuallyFree((ClientData) acceptCallbackPtr->script, TCL_DYNAMIC); + ckfree((char *) acceptCallbackPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SocketCmd -- + * + * This procedure is invoked to process the "socket" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Creates a socket based channel. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_SocketCmd(notUsed, interp, argc, argv) + ClientData notUsed; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int a, server, port; + char *arg, *copyScript, *host, *script; + char *myaddr = NULL; + int myport = 0; + int async = 0; + Tcl_Channel chan; + AcceptCallback *acceptCallbackPtr; + + server = 0; + script = NULL; + + if (TclHasSockets(interp) != TCL_OK) { + return TCL_ERROR; + } + + for (a = 1; a < argc; a++) { + arg = argv[a]; + if (arg[0] == '-') { + if (strcmp(arg, "-server") == 0) { + if (async == 1) { + Tcl_AppendResult(interp, + "cannot set -async option for server sockets", + (char *) NULL); + return TCL_ERROR; + } + server = 1; + a++; + if (a >= argc) { + Tcl_AppendResult(interp, + "no argument given for -server option", + (char *) NULL); + return TCL_ERROR; + } + script = argv[a]; + } else if (strcmp(arg, "-myaddr") == 0) { + a++; + if (a >= argc) { + Tcl_AppendResult(interp, + "no argument given for -myaddr option", + (char *) NULL); + return TCL_ERROR; + } + myaddr = argv[a]; + } else if (strcmp(arg, "-myport") == 0) { + a++; + if (a >= argc) { + Tcl_AppendResult(interp, + "no argument given for -myport option", + (char *) NULL); + return TCL_ERROR; + } + if (TclSockGetPort(interp, argv[a], "tcp", &myport) + != TCL_OK) { + return TCL_ERROR; + } + } else if (strcmp(arg, "-async") == 0) { + if (server == 1) { + Tcl_AppendResult(interp, + "cannot set -async option for server sockets", + (char *) NULL); + return TCL_ERROR; + } + async = 1; + } else { + Tcl_AppendResult(interp, "bad option \"", arg, + "\", must be -async, -myaddr, -myport, or -server", + (char *) NULL); + return TCL_ERROR; + } + } else { + break; + } + } + if (server) { + host = myaddr; /* NULL implies INADDR_ANY */ + if (myport != 0) { + Tcl_AppendResult(interp, "Option -myport is not valid for servers", + NULL); + return TCL_ERROR; + } + } else if (a < argc) { + host = argv[a]; + a++; + } else { +wrongNumArgs: + Tcl_AppendResult(interp, "wrong # args: should be either:\n", + argv[0], + " ?-myaddr addr? ?-myport myport? ?-async? host port\n", + argv[0], + " -server command ?-myaddr addr? port", + (char *) NULL); + return TCL_ERROR; + } + + if (a == argc-1) { + if (TclSockGetPort(interp, argv[a], "tcp", &port) != TCL_OK) { + return TCL_ERROR; + } + } else { + goto wrongNumArgs; + } + + if (server) { + acceptCallbackPtr = (AcceptCallback *) ckalloc((unsigned) + sizeof(AcceptCallback)); + copyScript = ckalloc((unsigned) strlen(script) + 1); + strcpy(copyScript, script); + acceptCallbackPtr->script = copyScript; + acceptCallbackPtr->interp = interp; + chan = Tcl_OpenTcpServer(interp, port, host, AcceptCallbackProc, + (ClientData) acceptCallbackPtr); + if (chan == (Tcl_Channel) NULL) { + ckfree(copyScript); + ckfree((char *) acceptCallbackPtr); + return TCL_ERROR; + } + + /* + * Register with the interpreter to let us know when the + * interpreter is deleted (by having the callback set the + * acceptCallbackPtr->interp field to NULL). This is to + * avoid trying to eval the script in a deleted interpreter. + */ + + RegisterTcpServerInterpCleanup(interp, acceptCallbackPtr); + + /* + * Register a close callback. This callback will inform the + * interpreter (if it still exists) that this channel does not + * need to be informed when the interpreter is deleted. + */ + + Tcl_CreateCloseHandler(chan, TcpServerCloseProc, + (ClientData) acceptCallbackPtr); + } else { + chan = Tcl_OpenTcpClient(interp, port, host, myaddr, myport, async); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + } + Tcl_RegisterChannel(interp, chan); + Tcl_AppendResult(interp, Tcl_GetChannelName(chan), (char *) NULL); + + return TCL_OK; +} diff --git a/contrib/tcl/generic/tclIOSock.c b/contrib/tcl/generic/tclIOSock.c new file mode 100644 index 0000000000000..828503782d092 --- /dev/null +++ b/contrib/tcl/generic/tclIOSock.c @@ -0,0 +1,96 @@ +/* + * tclIOSock.c -- + * + * Common routines used by all socket based channel types. + * + * 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: @(#) tclIOSock.c 1.16 96/03/12 07:04:33 + */ + +#include "tclInt.h" +#include "tclPort.h" + +/* + *---------------------------------------------------------------------- + * + * TclSockGetPort -- + * + * Maps from a string, which could be a service name, to a port. + * Used by socket creation code to get port numbers and resolve + * registered service names to port numbers. + * + * Results: + * A standard Tcl result. On success, the port number is + * returned in portPtr. On failure, an error message is left in + * interp->result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclSockGetPort(interp, string, proto, portPtr) + Tcl_Interp *interp; + char *string; /* Integer or service name */ + char *proto; /* "tcp" or "udp", typically */ + int *portPtr; /* Return port number */ +{ + struct servent *sp = getservbyname(string, proto); + if (sp != NULL) { + *portPtr = ntohs((unsigned short) sp->s_port); + return TCL_OK; + } + if (Tcl_GetInt(interp, string, portPtr) != TCL_OK) { + return TCL_ERROR; + } + if (*portPtr > 0xFFFF) { + Tcl_AppendResult(interp, "couldn't open socket: port number too high", + (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclSockMinimumBuffers -- + * + * Ensure minimum buffer sizes (non zero). + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Sets SO_SNDBUF and SO_RCVBUF sizes. + * + *---------------------------------------------------------------------- + */ + +int +TclSockMinimumBuffers(sock, size) + int sock; /* Socket file descriptor */ + int size; /* Minimum buffer size */ +{ + int current; + int len = sizeof(int); + + getsockopt(sock, SOL_SOCKET, SO_SNDBUF, (char *) ¤t, &len); + if (current < size) { + len = sizeof(int); + setsockopt(sock, SOL_SOCKET, SO_SNDBUF, (char *) &size, len); + } + len = sizeof(int); + getsockopt(sock, SOL_SOCKET, SO_RCVBUF, (char *) ¤t, &len); + if (current < size) { + len = sizeof(int); + setsockopt(sock, SOL_SOCKET, SO_RCVBUF, (char *) &size, len); + } + return TCL_OK; +} diff --git a/contrib/tcl/generic/tclIOUtil.c b/contrib/tcl/generic/tclIOUtil.c new file mode 100644 index 0000000000000..16f97acb048b5 --- /dev/null +++ b/contrib/tcl/generic/tclIOUtil.c @@ -0,0 +1,1287 @@ +/* + * tclIOUtil.c -- + * + * This file contains a collection of utility procedures that + * are shared by the platform specific IO drivers. + * + * Parts of this file are based on code contributed by Karl + * Lehenbauer, Mark Diekhans and Peter da Silva. + * + * Copyright (c) 1991-1994 The Regents of the University of California. + * Copyright (c) 1994-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: @(#) tclIOUtil.c 1.122 96/04/02 18:46:40 + */ + +#include "tclInt.h" +#include "tclPort.h" + +/* + * A linked list of the following structures is used to keep track + * of child processes that have been detached but haven't exited + * yet, so we can make sure that they're properly "reaped" (officially + * waited for) and don't lie around as zombies cluttering the + * system. + */ + +typedef struct Detached { + int pid; /* Id of process that's been detached + * but isn't known to have exited. */ + struct Detached *nextPtr; /* Next in list of all detached + * processes. */ +} Detached; + +static Detached *detList = NULL; /* List of all detached proceses. */ + +/* + * Declarations for local procedures defined in this file: + */ + +static Tcl_File FileForRedirect _ANSI_ARGS_((Tcl_Interp *interp, + char *spec, int atOk, char *arg, int flags, + char *nextArg, int *skipPtr, int *closePtr)); + +/* + *---------------------------------------------------------------------- + * + * FileForRedirect -- + * + * This procedure does much of the work of parsing redirection + * operators. It handles "@" if specified and allowed, and a file + * name, and opens the file if necessary. + * + * Results: + * The return value is the descriptor number for the file. If an + * error occurs then NULL is returned and an error message is left + * in interp->result. Several arguments are side-effected; see + * the argument list below for details. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static Tcl_File +FileForRedirect(interp, spec, atOk, arg, flags, nextArg, skipPtr, closePtr) + Tcl_Interp *interp; /* Intepreter to use for error + * reporting. */ + register char *spec; /* Points to character just after + * redirection character. */ + int atOk; /* Non-zero means '@' notation is + * OK, zero means it isn't. */ + char *arg; /* Pointer to entire argument + * containing spec: used for error + * reporting. */ + int flags; /* Flags to use for opening file. */ + char *nextArg; /* Next argument in argc/argv + * array, if needed for file name. + * May be NULL. */ + int *skipPtr; /* This value is incremented if + * nextArg is used for redirection + * spec. */ + int *closePtr; /* This value is set to 1 if the file + * that's returned must be closed, 0 + * if it was specified with "@" so + * it must be left open. */ +{ + int writing = (flags & O_WRONLY); + Tcl_Channel chan; + Tcl_File file; + + if (atOk && (*spec == '@')) { + spec++; + if (*spec == 0) { + spec = nextArg; + if (spec == NULL) { + goto badLastArg; + } + *skipPtr += 1; + } + chan = Tcl_GetChannel(interp, spec, NULL); + if (chan == (Tcl_Channel) NULL) { + return NULL; + } + *closePtr = 0; + file = Tcl_GetChannelFile(chan, writing ? TCL_WRITABLE : TCL_READABLE); + if (file == NULL) { + Tcl_AppendResult(interp, + "channel \"", + Tcl_GetChannelName(chan), + "\" wasn't opened for ", + writing ? "writing" : "reading", (char *) NULL); + return NULL; + } + if (writing) { + + /* + * Be sure to flush output to the file, so that anything + * written by the child appears after stuff we've already + * written. + */ + + Tcl_Flush(chan); + } + } else { + Tcl_DString buffer; + char *name; + + if (*spec == 0) { + spec = nextArg; + if (spec == NULL) { + goto badLastArg; + } + *skipPtr += 1; + } + name = Tcl_TranslateFileName(interp, spec, &buffer); + if (name) { + file = TclOpenFile(name, flags); + } else { + file = NULL; + } + Tcl_DStringFree(&buffer); + if (file == NULL) { + Tcl_AppendResult(interp, "couldn't ", + (writing) ? "write" : "read", " file \"", spec, "\": ", + Tcl_PosixError(interp), (char *) NULL); + return NULL; + } + *closePtr = 1; + } + return file; + + badLastArg: + Tcl_AppendResult(interp, "can't specify \"", arg, + "\" as last word in command", (char *) NULL); + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * TclGetOpenMode -- + * + * Description: + * Computes a POSIX mode mask for opening a file, from a given string, + * and also sets a flag to indicate whether the caller should seek to + * EOF after opening the file. + * + * Results: + * On success, returns mode to pass to "open". If an error occurs, the + * returns -1 and if interp is not NULL, sets interp->result to an + * error message. + * + * Side effects: + * Sets the integer referenced by seekFlagPtr to 1 to tell the caller + * to seek to EOF after opening the file. + * + * Special note: + * This code is based on a prototype implementation contributed + * by Mark Diekhans. + * + *---------------------------------------------------------------------- + */ + +int +TclGetOpenMode(interp, string, seekFlagPtr) + Tcl_Interp *interp; /* Interpreter to use for error + * reporting - may be NULL. */ + char *string; /* Mode string, e.g. "r+" or + * "RDONLY CREAT". */ + int *seekFlagPtr; /* Set this to 1 if the caller + * should seek to EOF during the + * opening of the file. */ +{ + int mode, modeArgc, c, i, gotRW; + char **modeArgv, *flag; +#define RW_MODES (O_RDONLY|O_WRONLY|O_RDWR) + + /* + * Check for the simpler fopen-like access modes (e.g. "r"). They + * are distinguished from the POSIX access modes by the presence + * of a lower-case first letter. + */ + + *seekFlagPtr = 0; + mode = 0; + if (islower(UCHAR(string[0]))) { + switch (string[0]) { + case 'r': + mode = O_RDONLY; + break; + case 'w': + mode = O_WRONLY|O_CREAT|O_TRUNC; + break; + case 'a': + mode = O_WRONLY|O_CREAT; + *seekFlagPtr = 1; + break; + default: + error: + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, + "illegal access mode \"", string, "\"", + (char *) NULL); + } + return -1; + } + if (string[1] == '+') { + mode &= ~(O_RDONLY|O_WRONLY); + mode |= O_RDWR; + if (string[2] != 0) { + goto error; + } + } else if (string[1] != 0) { + goto error; + } + return mode; + } + + /* + * The access modes are specified using a list of POSIX modes + * such as O_CREAT. + * + * IMPORTANT NOTE: We rely on Tcl_SplitList working correctly when + * a NULL interpreter is passed in. + */ + + if (Tcl_SplitList(interp, string, &modeArgc, &modeArgv) != TCL_OK) { + if (interp != (Tcl_Interp *) NULL) { + Tcl_AddErrorInfo(interp, + "\n while processing open access modes \""); + Tcl_AddErrorInfo(interp, string); + Tcl_AddErrorInfo(interp, "\""); + } + return -1; + } + + gotRW = 0; + for (i = 0; i < modeArgc; i++) { + flag = modeArgv[i]; + c = flag[0]; + if ((c == 'R') && (strcmp(flag, "RDONLY") == 0)) { + mode = (mode & ~RW_MODES) | O_RDONLY; + gotRW = 1; + } else if ((c == 'W') && (strcmp(flag, "WRONLY") == 0)) { + mode = (mode & ~RW_MODES) | O_WRONLY; + gotRW = 1; + } else if ((c == 'R') && (strcmp(flag, "RDWR") == 0)) { + mode = (mode & ~RW_MODES) | O_RDWR; + gotRW = 1; + } else if ((c == 'A') && (strcmp(flag, "APPEND") == 0)) { + mode |= O_APPEND; + *seekFlagPtr = 1; + } else if ((c == 'C') && (strcmp(flag, "CREAT") == 0)) { + mode |= O_CREAT; + } else if ((c == 'E') && (strcmp(flag, "EXCL") == 0)) { + mode |= O_EXCL; + } else if ((c == 'N') && (strcmp(flag, "NOCTTY") == 0)) { +#ifdef O_NOCTTY + mode |= O_NOCTTY; +#else + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "access mode \"", flag, + "\" not supported by this system", (char *) NULL); + } + ckfree((char *) modeArgv); + return -1; +#endif + } else if ((c == 'N') && (strcmp(flag, "NONBLOCK") == 0)) { +#if defined(O_NDELAY) || defined(O_NONBLOCK) +# ifdef O_NONBLOCK + mode |= O_NONBLOCK; +# else + mode |= O_NDELAY; +# endif +#else + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "access mode \"", flag, + "\" not supported by this system", (char *) NULL); + } + ckfree((char *) modeArgv); + return -1; +#endif + } else if ((c == 'T') && (strcmp(flag, "TRUNC") == 0)) { + mode |= O_TRUNC; + } else { + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "invalid access mode \"", flag, + "\": must be RDONLY, WRONLY, RDWR, APPEND, CREAT", + " EXCL, NOCTTY, NONBLOCK, or TRUNC", (char *) NULL); + } + ckfree((char *) modeArgv); + return -1; + } + } + ckfree((char *) modeArgv); + if (!gotRW) { + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "access mode must include either", + " RDONLY, WRONLY, or RDWR", (char *) NULL); + } + return -1; + } + return mode; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_EvalFile -- + * + * Read in a file and process the entire file as one gigantic + * Tcl command. + * + * Results: + * A standard Tcl result, which is either the result of executing + * the file or an error indicating why the file couldn't be read. + * + * Side effects: + * Depends on the commands in the file. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_EvalFile(interp, fileName) + Tcl_Interp *interp; /* Interpreter in which to process file. */ + char *fileName; /* Name of file to process. Tilde-substitution + * will be performed on this name. */ +{ + int result; + struct stat statBuf; + char *cmdBuffer = (char *) NULL; + char *oldScriptFile = (char *) NULL; + Interp *iPtr = (Interp *) interp; + Tcl_DString buffer; + char *nativeName = (char *) NULL; + Tcl_Channel chan = (Tcl_Channel) NULL; + + Tcl_ResetResult(interp); + oldScriptFile = iPtr->scriptFile; + iPtr->scriptFile = fileName; + Tcl_DStringInit(&buffer); + nativeName = Tcl_TranslateFileName(interp, fileName, &buffer); + if (nativeName == NULL) { + goto error; + } + + /* + * If Tcl_TranslateFileName didn't already copy the file name, do it + * here. This way we don't depend on fileName staying constant + * throughout the execution of the script (e.g., what if it happens + * to point to a Tcl variable that the script could change?). + */ + + if (nativeName != Tcl_DStringValue(&buffer)) { + Tcl_DStringSetLength(&buffer, 0); + Tcl_DStringAppend(&buffer, nativeName, -1); + nativeName = Tcl_DStringValue(&buffer); + } + if (stat(nativeName, &statBuf) == -1) { + Tcl_SetErrno(errno); + Tcl_AppendResult(interp, "couldn't read file \"", fileName, + "\": ", Tcl_PosixError(interp), (char *) NULL); + goto error; + } + chan = Tcl_OpenFileChannel(interp, nativeName, "r", 0644); + if (chan == (Tcl_Channel) NULL) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "couldn't read file \"", fileName, + "\": ", Tcl_PosixError(interp), (char *) NULL); + goto error; + } + cmdBuffer = (char *) ckalloc((unsigned) statBuf.st_size+1); + result = Tcl_Read(chan, cmdBuffer, statBuf.st_size); + if (result < 0) { + Tcl_Close(interp, chan); + Tcl_AppendResult(interp, "couldn't read file \"", fileName, + "\": ", Tcl_PosixError(interp), (char *) NULL); + goto error; + } + cmdBuffer[result] = 0; + if (Tcl_Close(interp, chan) != TCL_OK) { + goto error; + } + + result = Tcl_Eval(interp, cmdBuffer); + if (result == TCL_RETURN) { + result = TclUpdateReturnInfo(iPtr); + } else if (result == TCL_ERROR) { + char msg[200]; + + /* + * Record information telling where the error occurred. + */ + + sprintf(msg, "\n (file \"%.150s\" line %d)", fileName, + interp->errorLine); + Tcl_AddErrorInfo(interp, msg); + } + iPtr->scriptFile = oldScriptFile; + ckfree(cmdBuffer); + Tcl_DStringFree(&buffer); + return result; + +error: + if (cmdBuffer != (char *) NULL) { + ckfree(cmdBuffer); + } + iPtr->scriptFile = oldScriptFile; + Tcl_DStringFree(&buffer); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DetachPids -- + * + * This procedure is called to indicate that one or more child + * processes have been placed in background and will never be + * waited for; they should eventually be reaped by + * Tcl_ReapDetachedProcs. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DetachPids(numPids, pidPtr) + int numPids; /* Number of pids to detach: gives size + * of array pointed to by pidPtr. */ + int *pidPtr; /* Array of pids to detach. */ +{ + register Detached *detPtr; + int i; + + for (i = 0; i < numPids; i++) { + detPtr = (Detached *) ckalloc(sizeof(Detached)); + detPtr->pid = pidPtr[i]; + detPtr->nextPtr = detList; + detList = detPtr; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ReapDetachedProcs -- + * + * This procedure checks to see if any detached processes have + * exited and, if so, it "reaps" them by officially waiting on + * them. It should be called "occasionally" to make sure that + * all detached processes are eventually reaped. + * + * Results: + * None. + * + * Side effects: + * Processes are waited on, so that they can be reaped by the + * system. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_ReapDetachedProcs() +{ + register Detached *detPtr; + Detached *nextPtr, *prevPtr; + int status; + pid_t pid; + + for (detPtr = detList, prevPtr = NULL; detPtr != NULL; ) { + pid = Tcl_WaitPid(detPtr->pid, &status, WNOHANG); + if ((pid == 0) || ((pid == -1) && (errno != ECHILD))) { + prevPtr = detPtr; + detPtr = detPtr->nextPtr; + continue; + } + nextPtr = detPtr->nextPtr; + if (prevPtr == NULL) { + detList = detPtr->nextPtr; + } else { + prevPtr->nextPtr = detPtr->nextPtr; + } + ckfree((char *) detPtr); + detPtr = nextPtr; + } +} + +/* + *---------------------------------------------------------------------- + * + * TclCleanupChildren -- + * + * This is a utility procedure used to wait for child processes + * to exit, record information about abnormal exits, and then + * collect any stderr output generated by them. + * + * Results: + * The return value is a standard Tcl result. If anything at + * weird happened with the child processes, TCL_ERROR is returned + * and a message is left in interp->result. + * + * Side effects: + * If the last character of interp->result is a newline, then it + * is removed unless keepNewline is non-zero. File errorId gets + * closed, and pidPtr is freed back to the storage allocator. + * + *---------------------------------------------------------------------- + */ + +int +TclCleanupChildren(interp, numPids, pidPtr, errorChan) + Tcl_Interp *interp; /* Used for error messages. */ + int numPids; /* Number of entries in pidPtr array. */ + int *pidPtr; /* Array of process ids of children. */ + Tcl_Channel errorChan; /* Channel for file containing stderr output + * from pipeline. NULL means there isn't any + * stderr output. */ +{ + int result = TCL_OK; + int i, pid, abnormalExit, anyErrorInfo; + WAIT_STATUS_TYPE waitStatus; + char *msg; + + abnormalExit = 0; + for (i = 0; i < numPids; i++) { + pid = (int) Tcl_WaitPid(pidPtr[i], (int *) &waitStatus, 0); + if (pid == -1) { + result = TCL_ERROR; + if (interp != (Tcl_Interp *) NULL) { + msg = Tcl_PosixError(interp); + if (errno == ECHILD) { + /* + * This changeup in message suggested by Mark Diekhans + * to remind people that ECHILD errors can occur on + * some systems if SIGCHLD isn't in its default state. + */ + + msg = + "child process lost (is SIGCHLD ignored or trapped?)"; + } + Tcl_AppendResult(interp, "error waiting for process to exit: ", + msg, (char *) NULL); + } + continue; + } + + /* + * Create error messages for unusual process exits. An + * extra newline gets appended to each error message, but + * it gets removed below (in the same fashion that an + * extra newline in the command's output is removed). + */ + + if (!WIFEXITED(waitStatus) || (WEXITSTATUS(waitStatus) != 0)) { + char msg1[20], msg2[20]; + + result = TCL_ERROR; + sprintf(msg1, "%d", pid); + if (WIFEXITED(waitStatus)) { + if (interp != (Tcl_Interp *) NULL) { + sprintf(msg2, "%d", WEXITSTATUS(waitStatus)); + Tcl_SetErrorCode(interp, "CHILDSTATUS", msg1, msg2, + (char *) NULL); + } + abnormalExit = 1; + } else if (WIFSIGNALED(waitStatus)) { + if (interp != (Tcl_Interp *) NULL) { + char *p; + + p = Tcl_SignalMsg((int) (WTERMSIG(waitStatus))); + Tcl_SetErrorCode(interp, "CHILDKILLED", msg1, + Tcl_SignalId((int) (WTERMSIG(waitStatus))), p, + (char *) NULL); + Tcl_AppendResult(interp, "child killed: ", p, "\n", + (char *) NULL); + } + } else if (WIFSTOPPED(waitStatus)) { + if (interp != (Tcl_Interp *) NULL) { + char *p; + + p = Tcl_SignalMsg((int) (WSTOPSIG(waitStatus))); + Tcl_SetErrorCode(interp, "CHILDSUSP", msg1, + Tcl_SignalId((int) (WSTOPSIG(waitStatus))), + p, (char *) NULL); + Tcl_AppendResult(interp, "child suspended: ", p, "\n", + (char *) NULL); + } + } else { + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, + "child wait status didn't make sense\n", + (char *) NULL); + } + } + } + } + + /* + * Read the standard error file. If there's anything there, + * then return an error and add the file's contents to the result + * string. + */ + + anyErrorInfo = 0; + if (errorChan != NULL) { + + /* + * Make sure we start at the beginning of the file. + */ + + Tcl_Seek(errorChan, 0L, SEEK_SET); + + if (interp != (Tcl_Interp *) NULL) { + while (1) { +#define BUFFER_SIZE 1000 + char buffer[BUFFER_SIZE+1]; + int count; + + count = Tcl_Read(errorChan, buffer, BUFFER_SIZE); + if (count == 0) { + break; + } + result = TCL_ERROR; + if (count < 0) { + Tcl_AppendResult(interp, + "error reading stderr output file: ", + Tcl_PosixError(interp), (char *) NULL); + break; /* out of the "while (1)" loop. */ + } + buffer[count] = 0; + Tcl_AppendResult(interp, buffer, (char *) NULL); + anyErrorInfo = 1; + } + } + + Tcl_Close(NULL, errorChan); + } + + /* + * If a child exited abnormally but didn't output any error information + * at all, generate an error message here. + */ + + if (abnormalExit && !anyErrorInfo && (interp != (Tcl_Interp *) NULL)) { + Tcl_AppendResult(interp, "child process exited abnormally", + (char *) NULL); + } + + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TclCreatePipeline -- + * + * Given an argc/argv array, instantiate a pipeline of processes + * as described by the argv. + * + * Results: + * The return value is a count of the number of new processes + * created, or -1 if an error occurred while creating the pipeline. + * *pidArrayPtr is filled in with the address of a dynamically + * allocated array giving the ids of all of the processes. It + * is up to the caller to free this array when it isn't needed + * anymore. If inPipePtr is non-NULL, *inPipePtr is filled in + * with the file id for the input pipe for the pipeline (if any): + * the caller must eventually close this file. If outPipePtr + * isn't NULL, then *outPipePtr is filled in with the file id + * for the output pipe from the pipeline: the caller must close + * this file. If errFilePtr isn't NULL, then *errFilePtr is filled + * with a file id that may be used to read error output after the + * pipeline completes. + * + * Side effects: + * Processes and pipes are created. + * + *---------------------------------------------------------------------- + */ + +int +TclCreatePipeline(interp, argc, argv, pidArrayPtr, inPipePtr, + outPipePtr, errFilePtr) + Tcl_Interp *interp; /* Interpreter to use for error reporting. */ + int argc; /* Number of entries in argv. */ + char **argv; /* Array of strings describing commands in + * pipeline plus I/O redirection with <, + * <<, >, etc. Argv[argc] must be NULL. */ + int **pidArrayPtr; /* Word at *pidArrayPtr gets filled in with + * address of array of pids for processes + * in pipeline (first pid is first process + * in pipeline). */ + Tcl_File *inPipePtr; /* If non-NULL, input to the pipeline comes + * from a pipe (unless overridden by + * redirection in the command). The file + * id with which to write to this pipe is + * stored at *inPipePtr. NULL means command + * specified its own input source. */ + Tcl_File *outPipePtr; /* If non-NULL, output to the pipeline goes + * to a pipe, unless overriden by redirection + * in the command. The file id with which to + * read frome this pipe is stored at + * *outPipePtr. NULL means command specified + * its own output sink. */ + Tcl_File *errFilePtr; /* If non-NULL, all stderr output from the + * pipeline will go to a temporary file + * created here, and a descriptor to read + * the file will be left at *errFilePtr. + * The file will be removed already, so + * closing this descriptor will be the end + * of the file. If this is NULL, then + * all stderr output goes to our stderr. + * If the pipeline specifies redirection + * then the file will still be created + * but it will never get any data. */ +{ +#if defined( MAC_TCL ) + Tcl_AppendResult(interp, + "command pipelines not supported on Macintosh OS", NULL); + return -1; +#else /* !MAC_TCL */ + int *pidPtr = NULL; /* Points to malloc-ed array holding all + * the pids of child processes. */ + int numPids = 0; /* Actual number of processes that exist + * at *pidPtr right now. */ + int cmdCount; /* Count of number of distinct commands + * found in argc/argv. */ + char *input = NULL; /* If non-null, then this points to a + * string containing input data (specified + * via <<) to be piped to the first process + * in the pipeline. */ + Tcl_File inputFile = NULL; + /* If != NULL, gives file to use as input for + * first process in pipeline (specified via < + * or <@). */ + int closeInput = 0; /* If non-zero, then must close inputId + * when cleaning up (zero means the file needs + * to stay open for some other reason). */ + Tcl_File outputFile = NULL; + /* Writable file for output from last command + * in pipeline (could be file or pipe). NULL + * means use stdout. */ + int closeOutput = 0; /* Non-zero means must close outputId when + * cleaning up (similar to closeInput). */ + Tcl_File errorFile = NULL; + /* Writable file for error output from all + * commands in pipeline. NULL means use + * stderr. */ + int closeError = 0; /* Non-zero means must close errorId when + * cleaning up. */ + int skip; /* Number of arguments to skip (because they + * specify redirection). */ + int lastBar; + int i, j; + char *p; + int hasPipes = TclHasPipes(); + char finalOut[L_tmpnam]; + char intIn[L_tmpnam]; + + finalOut[0] = '\0'; + intIn[0] = '\0'; + + if (inPipePtr != NULL) { + *inPipePtr = NULL; + } + if (outPipePtr != NULL) { + *outPipePtr = NULL; + } + if (errFilePtr != NULL) { + *errFilePtr = NULL; + } + + /* + * First, scan through all the arguments to figure out the structure + * of the pipeline. Process all of the input and output redirection + * arguments and remove them from the argument list in the pipeline. + * Count the number of distinct processes (it's the number of "|" + * arguments plus one) but don't remove the "|" arguments. + */ + + cmdCount = 1; + lastBar = -1; + for (i = 0; i < argc; i++) { + if ((argv[i][0] == '|') && (((argv[i][1] == 0)) + || ((argv[i][1] == '&') && (argv[i][2] == 0)))) { + if ((i == (lastBar+1)) || (i == (argc-1))) { + interp->result = "illegal use of | or |& in command"; + return -1; + } + lastBar = i; + cmdCount++; + continue; + } else if (argv[i][0] == '<') { + if ((inputFile != NULL) && closeInput) { + TclCloseFile(inputFile); + } + inputFile = NULL; + skip = 1; + if (argv[i][1] == '<') { + input = argv[i]+2; + if (*input == 0) { + input = argv[i+1]; + if (input == 0) { + Tcl_AppendResult(interp, "can't specify \"", argv[i], + "\" as last word in command", (char *) NULL); + goto error; + } + skip = 2; + } + } else { + input = 0; + inputFile = FileForRedirect(interp, argv[i]+1, 1, argv[i], + O_RDONLY, argv[i+1], &skip, &closeInput); + if (inputFile == NULL) { + goto error; + } + + /* When Win32s dies out, this code can be removed */ + if (!hasPipes) { + if (!closeInput) { + Tcl_AppendResult(interp, "redirection with '@'", + " notation is not supported on this system", + (char *) NULL); + goto error; + } + strcpy(intIn, skip == 1 ? argv[i]+1 : argv[i+1]); + } + } + } else if (argv[i][0] == '>') { + int append, useForStdErr, useForStdOut, mustClose, atOk, flags; + Tcl_File file; + + skip = atOk = 1; + append = useForStdErr = 0; + useForStdOut = 1; + if (argv[i][1] == '>') { + p = argv[i] + 2; + append = 1; + atOk = 0; + flags = O_WRONLY|O_CREAT; + } else { + p = argv[i] + 1; + flags = O_WRONLY|O_CREAT|O_TRUNC; + } + if (*p == '&') { + useForStdErr = 1; + p++; + } + file = FileForRedirect(interp, p, atOk, argv[i], flags, argv[i+1], + &skip, &mustClose); + if (file == NULL) { + goto error; + } + + /* When Win32s dies out, this code can be removed */ + if (!hasPipes) { + if (!mustClose) { + Tcl_AppendResult(interp, "redirection with '@'", + " notation is not supported on this system", + (char *) NULL); + goto error; + } + strcpy(finalOut, skip == 1 ? p : argv[i+1]); + } + + if (hasPipes && append) { + TclSeekFile(file, 0L, 2); + } + + /* + * Got the file descriptor. Now use it for standard output, + * standard error, or both, depending on the redirection. + */ + + if (useForStdOut) { + if ((outputFile != NULL) && closeOutput) { + TclCloseFile(outputFile); + } + outputFile = file; + closeOutput = mustClose; + } + if (useForStdErr) { + if ((errorFile != NULL) && closeError) { + TclCloseFile(errorFile); + } + errorFile = file; + closeError = (useForStdOut) ? 0 : mustClose; + } + } else if ((argv[i][0] == '2') && (argv[i][1] == '>')) { + int append, atOk, flags; + + if ((errorFile != NULL) && closeError) { + TclCloseFile(errorFile); + } + skip = 1; + p = argv[i] + 2; + if (*p == '>') { + p++; + append = 1; + atOk = 0; + flags = O_WRONLY|O_CREAT; + } else { + append = 0; + atOk = 1; + flags = O_WRONLY|O_CREAT|O_TRUNC; + } + errorFile = FileForRedirect(interp, p, atOk, argv[i], flags, + argv[i+1], &skip, &closeError); + if (errorFile == NULL) { + goto error; + } + if (hasPipes && append) { + TclSeekFile(errorFile, 0L, 2); + } + } else { + continue; + } + for (j = i+skip; j < argc; j++) { + argv[j-skip] = argv[j]; + } + argc -= skip; + i -= 1; /* Process next arg from same position. */ + } + if (argc == 0) { + interp->result = "didn't specify command to execute"; + return -1; + } + + if ((hasPipes && inputFile == NULL) || (!hasPipes && intIn[0] == '\0')) { + if (input != NULL) { + + /* + * The input for the first process is immediate data coming from + * Tcl. Create a temporary file for it and put the data into the + * file. + */ + + inputFile = TclCreateTempFile(input); + closeInput = 1; + if (inputFile == NULL) { + Tcl_AppendResult(interp, + "couldn't create input file for command: ", + Tcl_PosixError(interp), (char *) NULL); + goto error; + } + } else if (inPipePtr != NULL) { + Tcl_File inPipe, outPipe; + /* + * The input for the first process in the pipeline is to + * come from a pipe that can be written from this end. + */ + + if (!hasPipes || TclCreatePipe(&inPipe, &outPipe) == 0) { + Tcl_AppendResult(interp, + "couldn't create input pipe for command: ", + Tcl_PosixError(interp), (char *) NULL); + goto error; + } + inputFile = inPipe; + closeInput = 1; + *inPipePtr = outPipe; + } + } + + /* + * Set up a pipe to receive output from the pipeline, if no other + * output sink has been specified. + */ + + if ((outputFile == NULL) && (outPipePtr != NULL)) { + if (!hasPipes) { + tmpnam(finalOut); + } else { + Tcl_File inPipe, outPipe; + if (TclCreatePipe(&inPipe, &outPipe) == 0) { + Tcl_AppendResult(interp, + "couldn't create output pipe for command: ", + Tcl_PosixError(interp), (char *) NULL); + goto error; + } + outputFile = outPipe; + closeOutput = 1; + *outPipePtr = inPipe; + } + } + + /* + * Set up the standard error output sink for the pipeline, if + * requested. Use a temporary file which is opened, then deleted. + * Could potentially just use pipe, but if it filled up it could + * cause the pipeline to deadlock: we'd be waiting for processes + * to complete before reading stderr, and processes couldn't complete + * because stderr was backed up. + */ + + if (errFilePtr && !errorFile) { + *errFilePtr = TclCreateTempFile(NULL); + if (*errFilePtr == NULL) { + Tcl_AppendResult(interp, + "couldn't create error file for command: ", + Tcl_PosixError(interp), (char *) NULL); + goto error; + } + errorFile = *errFilePtr; + closeError = 0; + } + + /* + * Scan through the argc array, forking off a process for each + * group of arguments between "|" arguments. + */ + + pidPtr = (int *) ckalloc((unsigned) (cmdCount * sizeof(int))); + Tcl_ReapDetachedProcs(); + + if (TclSpawnPipeline(interp, pidPtr, &numPids, argc, argv, + inputFile, outputFile, errorFile, intIn, finalOut) == 0) { + goto error; + } + *pidArrayPtr = pidPtr; + + /* + * All done. Cleanup open files lying around and then return. + */ + +cleanup: + if ((inputFile != NULL) && closeInput) { + TclCloseFile(inputFile); + } + if ((outputFile != NULL) && closeOutput) { + TclCloseFile(outputFile); + } + if ((errorFile != NULL) && closeError) { + TclCloseFile(errorFile); + } + return numPids; + + /* + * An error occurred. There could have been extra files open, such + * as pipes between children. Clean them all up. Detach any child + * processes that have been created. + */ + +error: + if ((inPipePtr != NULL) && (*inPipePtr != NULL)) { + TclCloseFile(*inPipePtr); + *inPipePtr = NULL; + } + if ((outPipePtr != NULL) && (*outPipePtr != NULL)) { + TclCloseFile(*outPipePtr); + *outPipePtr = NULL; + } + if ((errFilePtr != NULL) && (*errFilePtr != NULL)) { + TclCloseFile(*errFilePtr); + *errFilePtr = NULL; + } + if (pidPtr != NULL) { + for (i = 0; i < numPids; i++) { + if (pidPtr[i] != -1) { + Tcl_DetachPids(1, &pidPtr[i]); + } + } + ckfree((char *) pidPtr); + } + numPids = -1; + goto cleanup; +#endif /* !MAC_TCL */ +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetErrno -- + * + * Gets the current value of the Tcl error code variable. This is + * currently the global variable "errno" but could in the future + * change to something else. + * + * Results: + * The value of the Tcl error code variable. + * + * Side effects: + * None. Note that the value of the Tcl error code variable is + * UNDEFINED if a call to Tcl_SetErrno did not precede this call. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetErrno() +{ + return errno; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetErrno -- + * + * Sets the Tcl error code variable to the supplied value. + * + * Results: + * None. + * + * Side effects: + * Modifies the value of the Tcl error code variable. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SetErrno(err) + int err; /* The new value. */ +{ + errno = err; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_PosixError -- + * + * This procedure is typically called after UNIX kernel calls + * return errors. It stores machine-readable information about + * the error in $errorCode returns an information string for + * the caller's use. + * + * Results: + * The return value is a human-readable string describing the + * error. + * + * Side effects: + * The global variable $errorCode is reset. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_PosixError(interp) + Tcl_Interp *interp; /* Interpreter whose $errorCode variable + * is to be changed. */ +{ + char *id, *msg; + + msg = Tcl_ErrnoMsg(errno); + id = Tcl_ErrnoId(); + Tcl_SetErrorCode(interp, "POSIX", id, msg, (char *) NULL); + return msg; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_OpenCommandChannel -- + * + * Opens an I/O channel to one or more subprocesses specified + * by argc and argv. The flags argument determines the + * disposition of the stdio handles. If the TCL_STDIN flag is + * set then the standard input for the first subprocess will + * be tied to the channel: writing to the channel will provide + * input to the subprocess. If TCL_STDIN is not set, then + * standard input for the first subprocess will be the same as + * this application's standard input. If TCL_STDOUT is set then + * standard output from the last subprocess can be read from the + * channel; otherwise it goes to this application's standard + * output. If TCL_STDERR is set, standard error output for all + * subprocesses is returned to the channel and results in an error + * when the channel is closed; otherwise it goes to this + * application's standard error. If TCL_ENFORCE_MODE is not set, + * then argc and argv can redirect the stdio handles to override + * TCL_STDIN, TCL_STDOUT, and TCL_STDERR; if it is set, then it + * is an error for argc and argv to override stdio channels for + * which TCL_STDIN, TCL_STDOUT, and TCL_STDERR have been set. + * + * Results: + * A new command channel, or NULL on failure with an error + * message left in interp. + * + * Side effects: + * Creates processes, opens pipes. + * + *---------------------------------------------------------------------- + */ + +Tcl_Channel +Tcl_OpenCommandChannel(interp, argc, argv, flags) + Tcl_Interp *interp; /* Interpreter for error reporting. Can + * NOT be NULL. */ + int argc; /* How many arguments. */ + char **argv; /* Array of arguments for command pipe. */ + int flags; /* Or'ed combination of TCL_STDIN, TCL_STDOUT, + * TCL_STDERR, and TCL_ENFORCE_MODE. */ +{ + Tcl_File *inPipePtr, *outPipePtr, *errFilePtr; + Tcl_File inPipe, outPipe, errFile; + int numPids, *pidPtr; + Tcl_Channel channel; + + inPipe = outPipe = errFile = NULL; + + inPipePtr = (flags & TCL_STDIN) ? &inPipe : NULL; + outPipePtr = (flags & TCL_STDOUT) ? &outPipe : NULL; + errFilePtr = (flags & TCL_STDERR) ? &errFile : NULL; + + numPids = TclCreatePipeline(interp, argc, argv, &pidPtr, inPipePtr, + outPipePtr, errFilePtr); + + if (numPids < 0) { + goto error; + } + + /* + * Verify that the pipes that were created satisfy the + * readable/writable constraints. + */ + + if (flags & TCL_ENFORCE_MODE) { + if ((flags & TCL_STDOUT) && (outPipe == NULL)) { + Tcl_AppendResult(interp, "can't read output from command:", + " standard output was redirected", (char *) NULL); + goto error; + } + if ((flags & TCL_STDIN) && (inPipe == NULL)) { + Tcl_AppendResult(interp, "can't write input to command:", + " standard input was redirected", (char *) NULL); + goto error; + } + } + + channel = TclCreateCommandChannel(outPipe, inPipe, errFile, + numPids, pidPtr); + + if (channel == (Tcl_Channel) NULL) { + Tcl_AppendResult(interp, "pipe for command could not be created", + (char *) NULL); + goto error; + } + return channel; + +error: + if (numPids > 0) { + Tcl_DetachPids(numPids, pidPtr); + ckfree((char *) pidPtr); + } + if (inPipe != NULL) { + TclClosePipeFile(inPipe); + } + if (outPipe != NULL) { + TclClosePipeFile(outPipe); + } + if (errFile != NULL) { + TclClosePipeFile(errFile); + } + return NULL; +} diff --git a/contrib/tcl/generic/tclInt.h b/contrib/tcl/generic/tclInt.h new file mode 100644 index 0000000000000..079f916f04601 --- /dev/null +++ b/contrib/tcl/generic/tclInt.h @@ -0,0 +1,1075 @@ +/* + * tclInt.h -- + * + * Declarations of things used internally by the Tcl interpreter. + * + * Copyright (c) 1987-1993 The Regents of the University of California. + * Copyright (c) 1994-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: @(#) tclInt.h 1.200 96/04/11 17:24:12 + */ + +#ifndef _TCLINT +#define _TCLINT + +/* + * Common include files needed by most of the Tcl source files are + * included here, so that system-dependent personalizations for the + * include files only have to be made in once place. This results + * in a few extra includes, but greater modularity. The order of + * the three groups of #includes is important. For example, stdio.h + * is needed by tcl.h, and the _ANSI_ARGS_ declaration in tcl.h is + * needed by stdlib.h in some configurations. + */ + +#include <stdio.h> + +#ifndef _TCL +#include "tcl.h" +#endif +#ifndef _REGEXP +#include "tclRegexp.h" +#endif + +#include <ctype.h> +#ifdef NO_LIMITS_H +# include "../compat/limits.h" +#else +# include <limits.h> +#endif +#ifdef NO_STDLIB_H +# include "../compat/stdlib.h" +#else +# include <stdlib.h> +#endif +#ifdef NO_STRING_H +#include "../compat/string.h" +#else +#include <string.h> +#endif +#if defined(__STDC__) || defined(HAS_STDARG) +# include <stdarg.h> +#else +# include <varargs.h> +#endif + +/* + *---------------------------------------------------------------- + * Data structures related to variables. These are used primarily + * in tclVar.c + *---------------------------------------------------------------- + */ + +/* + * The following structure defines a variable trace, which is used to + * invoke a specific C procedure whenever certain operations are performed + * on a variable. + */ + +typedef struct VarTrace { + Tcl_VarTraceProc *traceProc;/* Procedure to call when operations given + * by flags are performed on variable. */ + ClientData clientData; /* Argument to pass to proc. */ + int flags; /* What events the trace procedure is + * interested in: OR-ed combination of + * TCL_TRACE_READS, TCL_TRACE_WRITES, and + * TCL_TRACE_UNSETS. */ + struct VarTrace *nextPtr; /* Next in list of traces associated with + * a particular variable. */ +} VarTrace; + +/* + * When a variable trace is active (i.e. its associated procedure is + * executing), one of the following structures is linked into a list + * associated with the variable's interpreter. The information in + * the structure is needed in order for Tcl to behave reasonably + * if traces are deleted while traces are active. + */ + +typedef struct ActiveVarTrace { + struct Var *varPtr; /* Variable that's being traced. */ + struct ActiveVarTrace *nextPtr; + /* Next in list of all active variable + * traces for the interpreter, or NULL + * if no more. */ + VarTrace *nextTracePtr; /* Next trace to check after current + * trace procedure returns; if this + * trace gets deleted, must update pointer + * to avoid using free'd memory. */ +} ActiveVarTrace; + +/* + * The following structure describes an enumerative search in progress on + * an array variable; this are invoked with options to the "array" + * command. + */ + +typedef struct ArraySearch { + int id; /* Integer id used to distinguish among + * multiple concurrent searches for the + * same array. */ + struct Var *varPtr; /* Pointer to array variable that's being + * searched. */ + Tcl_HashSearch search; /* Info kept by the hash module about + * progress through the array. */ + Tcl_HashEntry *nextEntry; /* Non-null means this is the next element + * to be enumerated (it's leftover from + * the Tcl_FirstHashEntry call or from + * an "array anymore" command). NULL + * means must call Tcl_NextHashEntry + * to get value to return. */ + struct ArraySearch *nextPtr;/* Next in list of all active searches + * for this variable, or NULL if this is + * the last one. */ +} ArraySearch; + +/* + * The structure below defines a variable, which associates a string name + * with a string value. Pointers to these structures are kept as the + * values of hash table entries, and the name of each variable is stored + * in the hash entry. + */ + +typedef struct Var { + int valueLength; /* Holds the number of non-null bytes + * actually occupied by the variable's + * current value in value.string (extra + * space is sometimes left for expansion). + * For array and global variables this is + * meaningless. */ + int valueSpace; /* Total number of bytes of space allocated + * at value.string. 0 means there is no + * space allocated. */ + union { + char *string; /* String value of variable, used for scalar + * variables and array elements. Malloc-ed. */ + Tcl_HashTable *tablePtr;/* For array variables, this points to + * information about the hash table used + * to implement the associative array. + * Points to malloc-ed data. */ + struct Var *upvarPtr; /* If this is a global variable being + * referred to in a procedure, or a variable + * created by "upvar", this field points to + * the record for the higher-level variable. */ + } value; + Tcl_HashEntry *hPtr; /* Hash table entry that refers to this + * variable, or NULL if the variable has + * been detached from its hash table (e.g. + * an array is deleted, but some of its + * elements are still referred to in upvars). */ + int refCount; /* Counts number of active uses of this + * variable, not including its main hash + * table entry: 1 for each additional variable + * whose upVarPtr points here, 1 for each + * nested trace active on variable. This + * record can't be deleted until refCount + * becomes 0. */ + VarTrace *tracePtr; /* First in list of all traces set for this + * variable. */ + ArraySearch *searchPtr; /* First in list of all searches active + * for this variable, or NULL if none. */ + int flags; /* Miscellaneous bits of information about + * variable. See below for definitions. */ +} Var; + +/* + * Flag bits for variables: + * + * VAR_ARRAY - 1 means this is an array variable rather + * than a scalar variable. + * VAR_UPVAR - 1 means this variable just contains a + * pointer to another variable that has the + * real value. Variables like this come + * about through the "upvar" and "global" + * commands. + * VAR_UNDEFINED - 1 means that the variable is currently + * undefined. Undefined variables usually + * go away completely, but if an undefined + * variable has a trace on it, or if it is + * a global variable being used by a procedure, + * then it stays around even when undefined. + * VAR_TRACE_ACTIVE - 1 means that trace processing is currently + * underway for a read or write access, so + * new read or write accesses should not cause + * trace procedures to be called and the + * variable can't be deleted. + */ + +#define VAR_ARRAY 1 +#define VAR_UPVAR 2 +#define VAR_UNDEFINED 4 +#define VAR_TRACE_ACTIVE 0x10 + +/* + *---------------------------------------------------------------- + * Data structures related to procedures. These are used primarily + * in tclProc.c + *---------------------------------------------------------------- + */ + +/* + * The structure below defines an argument to a procedure, which + * consists of a name and an (optional) default value. + */ + +typedef struct Arg { + struct Arg *nextPtr; /* Next argument for this procedure, + * or NULL if this is the last argument. */ + char *defValue; /* Pointer to arg's default value, or NULL + * if no default value. */ + char name[4]; /* Name of argument starts here. The name + * is followed by space for the default, + * if there is one. The actual size of this + * field will be as large as necessary to + * hold both name and default value. THIS + * MUST BE THE LAST FIELD IN THE STRUCTURE!! */ +} Arg; + +/* + * The structure below defines a command procedure, which consists of + * a collection of Tcl commands plus information about arguments and + * variables. + */ + +typedef struct Proc { + struct Interp *iPtr; /* Interpreter for which this command + * is defined. */ + int refCount; /* Reference count: 1 if still present + * in command table plus 1 for each call + * to the procedure that is currently + * active. This structure can be freed + * when refCount becomes zero. */ + char *command; /* Command that constitutes the body of + * the procedure (dynamically allocated). */ + Arg *argPtr; /* Pointer to first of procedure's formal + * arguments, or NULL if none. */ +} Proc; + +/* + * The structure below defines a command trace. This is used to allow Tcl + * clients to find out whenever a command is about to be executed. + */ + +typedef struct Trace { + int level; /* Only trace commands at nesting level + * less than or equal to this. */ + Tcl_CmdTraceProc *proc; /* Procedure to call to trace command. */ + ClientData clientData; /* Arbitrary value to pass to proc. */ + struct Trace *nextPtr; /* Next in list of traces for this interp. */ +} Trace; + +/* + * The structure below defines an entry in the assocData hash table which + * is associated with an interpreter. The entry contains a pointer to a + * function to call when the interpreter is deleted, and a pointer to + * a user-defined piece of data. + */ + +typedef struct AssocData { + Tcl_InterpDeleteProc *proc; /* Proc to call when deleting. */ + ClientData clientData; /* Value to pass to proc. */ +} AssocData; + +/* + * The structure below defines a frame, which is a procedure invocation. + * These structures exist only while procedures are being executed, and + * provide a sort of call stack. + */ + +typedef struct CallFrame { + Tcl_HashTable varTable; /* Hash table containing all of procedure's + * local variables. */ + int level; /* Level of this procedure, for "uplevel" + * purposes (i.e. corresponds to nesting of + * callerVarPtr's, not callerPtr's). 1 means + * outer-most procedure, 0 means top-level. */ + int argc; /* This and argv below describe name and + * arguments for this procedure invocation. */ + char **argv; /* Array of arguments. */ + struct CallFrame *callerPtr; + /* Value of interp->framePtr when this + * procedure was invoked (i.e. next in + * stack of all active procedures). */ + struct CallFrame *callerVarPtr; + /* Value of interp->varFramePtr when this + * procedure was invoked (i.e. determines + * variable scoping within caller; same + * as callerPtr unless an "uplevel" command + * or something equivalent was active in + * the caller). */ +} CallFrame; + +/* + * The structure below defines one history event (a previously-executed + * command that can be re-executed in whole or in part). + */ + +typedef struct { + char *command; /* String containing previously-executed + * command. */ + int bytesAvl; /* Total # of bytes available at *event (not + * all are necessarily in use now). */ +} HistoryEvent; + +/* + *---------------------------------------------------------------- + * Data structures related to history. These are used primarily + * in tclHistory.c + *---------------------------------------------------------------- + */ + +/* + * The structure below defines a pending revision to the most recent + * history event. Changes are linked together into a list and applied + * during the next call to Tcl_RecordHistory. See the comments at the + * beginning of tclHistory.c for information on revisions. + */ + +typedef struct HistoryRev { + int firstIndex; /* Index of the first byte to replace in + * current history event. */ + int lastIndex; /* Index of last byte to replace in + * current history event. */ + int newSize; /* Number of bytes in newBytes. */ + char *newBytes; /* Replacement for the range given by + * firstIndex and lastIndex (malloced). */ + struct HistoryRev *nextPtr; /* Next in chain of revisions to apply, or + * NULL for end of list. */ +} HistoryRev; + +/* + *---------------------------------------------------------------- + * Data structures related to expressions. These are used only in + * tclExpr.c. + *---------------------------------------------------------------- + */ + +/* + * The data structure below defines a math function (e.g. sin or hypot) + * for use in Tcl expressions. + */ + +#define MAX_MATH_ARGS 5 +typedef struct MathFunc { + int numArgs; /* Number of arguments for function. */ + Tcl_ValueType argTypes[MAX_MATH_ARGS]; + /* Acceptable types for each argument. */ + Tcl_MathProc *proc; /* Procedure that implements this function. */ + ClientData clientData; /* Additional argument to pass to the function + * when invoking it. */ +} MathFunc; + +/* + *---------------------------------------------------------------- + * One of the following structures exists for each command in + * an interpreter. The Tcl_Command opaque type actually refers + * to these structures. + *---------------------------------------------------------------- + */ + +typedef struct Command { + Tcl_HashEntry *hPtr; /* Pointer to the hash table entry in + * interp->commandTable that refers to + * this command. Used to get a command's + * name from its Tcl_Command handle. NULL + * means that the hash table entry has + * been removed already (this can happen + * if deleteProc causes the command to be + * deleted or recreated). */ + Tcl_CmdProc *proc; /* Procedure to process command. */ + ClientData clientData; /* Arbitrary value to pass to proc. */ + Tcl_CmdDeleteProc *deleteProc; + /* Procedure to invoke when deleting + * command. */ + ClientData deleteData; /* Arbitrary value to pass to deleteProc + * (usually the same as clientData). */ + int deleted; /* Means that the command is in the process + * of being deleted (its deleteProc is + * currently executing). Any other attempts + * to delete the command should be ignored. */ +} Command; + +/* + *---------------------------------------------------------------- + * This structure defines an interpreter, which is a collection of + * commands plus other state information related to interpreting + * commands, such as variable storage. Primary responsibility for + * this data structure is in tclBasic.c, but almost every Tcl + * source file uses something in here. + *---------------------------------------------------------------- + */ + +typedef struct Interp { + + /* + * Note: the first three fields must match exactly the fields in + * a Tcl_Interp struct (see tcl.h). If you change one, be sure to + * change the other. + */ + + char *result; /* Points to result returned by last + * command. */ + Tcl_FreeProc *freeProc; /* Zero means result is statically allocated. + * 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_HashTable commandTable; /* Contains all of the commands currently + * registered in this interpreter. Indexed + * by strings; values have type (Command *). */ + Tcl_HashTable mathFuncTable;/* Contains all of the math functions currently + * defined for the interpreter. Indexed by + * strings (function names); values have + * type (MathFunc *). */ + + /* + * Information related to procedures and variables. See tclProc.c + * and tclvar.c for usage. + */ + + Tcl_HashTable globalTable; /* Contains all global variables for + * interpreter. */ + int numLevels; /* Keeps track of how many nested calls to + * Tcl_Eval are in progress for this + * interpreter. It's used to delay deletion + * of the table until all Tcl_Eval invocations + * are completed. */ + int maxNestingDepth; /* If numLevels exceeds this value then Tcl + * assumes that infinite recursion has + * occurred and it generates an error. */ + CallFrame *framePtr; /* Points to top-most in stack of all nested + * procedure invocations. NULL means there + * are no active procedures. */ + CallFrame *varFramePtr; /* Points to the call frame whose variables + * are currently in use (same as framePtr + * unless an "uplevel" command is being + * executed). NULL means no procedure is + * active or "uplevel 0" is being exec'ed. */ + ActiveVarTrace *activeTracePtr; + /* First in list of active traces for interp, + * or NULL if no active traces. */ + int returnCode; /* Completion code to return if current + * procedure exits with a TCL_RETURN code. */ + char *errorInfo; /* Value to store in errorInfo if returnCode + * is TCL_ERROR. Malloc'ed, may be NULL */ + char *errorCode; /* Value to store in errorCode if returnCode + * is TCL_ERROR. Malloc'ed, may be NULL */ + + /* + * Information related to history: + */ + + int numEvents; /* Number of previously-executed commands + * to retain. */ + HistoryEvent *events; /* Array containing numEvents entries + * (dynamically allocated). */ + int curEvent; /* Index into events of place where current + * (or most recent) command is recorded. */ + int curEventNum; /* Event number associated with the slot + * given by curEvent. */ + HistoryRev *revPtr; /* First in list of pending revisions. */ + char *historyFirst; /* First char. of current command executed + * from history module or NULL if none. */ + int revDisables; /* 0 means history revision OK; > 0 gives + * a count of number of times revision has + * been disabled. */ + char *evalFirst; /* If TCL_RECORD_BOUNDS flag set, Tcl_Eval + * sets this field to point to the first + * char. of text from which the current + * command came. Otherwise Tcl_Eval sets + * this to NULL. */ + char *evalLast; /* Similar to evalFirst, except points to + * last character of current command. */ + + /* + * Information used by Tcl_AppendResult to keep track of partial + * results. See Tcl_AppendResult code for details. + */ + + char *appendResult; /* Storage space for results generated + * by Tcl_AppendResult. Malloc-ed. NULL + * means not yet allocated. */ + int appendAvl; /* Total amount of space available at + * partialResult. */ + int appendUsed; /* Number of non-null bytes currently + * stored at partialResult. */ + + /* + * A cache of compiled regular expressions. See Tcl_RegExpCompile + * in tclUtil.c for details. + */ + +#define NUM_REGEXPS 5 + char *patterns[NUM_REGEXPS];/* Strings corresponding to compiled + * regular expression patterns. NULL + * means that this slot isn't used. + * Malloc-ed. */ + int patLengths[NUM_REGEXPS];/* Number of non-null characters in + * corresponding entry in patterns. + * -1 means entry isn't used. */ + regexp *regexps[NUM_REGEXPS]; + /* Compiled forms of above strings. Also + * malloc-ed, or NULL if not in use yet. */ + + /* + * Information about packages. Used only in tclPkg.c. + */ + + Tcl_HashTable packageTable; /* Describes all of the packages loaded + * in or available to this interpreter. + * Keys are package names, values are + * (Package *) pointers. */ + char *packageUnknown; /* Command to invoke during "package + * require" commands for packages that + * aren't described in packageTable. + * Malloc'ed, may be NULL. */ + + /* + * Information used by Tcl_PrintDouble: + */ + + char pdFormat[10]; /* Format string used by Tcl_PrintDouble. */ + int pdPrec; /* Current precision (used to restore the + * the tcl_precision variable after a bogus + * value has been put into it). */ + + /* + * Miscellaneous information: + */ + + int cmdCount; /* Total number of times a command procedure + * has been called for this interpreter. */ + int noEval; /* Non-zero means no commands should actually + * be executed: just parse only. Used in + * expressions when the result is already + * determined. */ + int evalFlags; /* Flags to control next call to Tcl_Eval. + * Normally zero, but may be set before + * calling Tcl_Eval. See below for valid + * values. */ + char *termPtr; /* Character just after the last one in + * a command. Set by Tcl_Eval before + * returning. */ + char *scriptFile; /* NULL means there is no nested source + * command active; otherwise this points to + * the name of the file being sourced (it's + * not malloc-ed: it points to an argument + * to Tcl_EvalFile. */ + int flags; /* Various flag bits. See below. */ + Trace *tracePtr; /* List of traces for this interpreter. */ + Tcl_HashTable *assocData; /* Hash table for associating data with + * this interpreter. Cleaned up when + * this interpreter is deleted. */ + char resultSpace[TCL_RESULT_SIZE+1]; + /* Static space for storing small results. */ +} Interp; + +/* + * EvalFlag bits for Interp structures: + * + * TCL_BRACKET_TERM 1 means that the current script is terminated by + * a close bracket rather than the end of the string. + * TCL_RECORD_BOUNDS Tells Tcl_Eval to record information in the + * evalFirst and evalLast fields for each command + * executed directly from the string (top-level + * commands and those from command substitution). + * TCL_ALLOW_EXCEPTIONS 1 means it's OK for the script to terminate with + * a code other than TCL_OK or TCL_ERROR; 0 means + * codes other than these should be turned into errors. + */ + +#define TCL_BRACKET_TERM 1 +#define TCL_RECORD_BOUNDS 2 +#define TCL_ALLOW_EXCEPTIONS 4 + +/* + * Flag bits for Interp structures: + * + * DELETED: Non-zero means the interpreter has been deleted: + * don't process any more commands for it, and destroy + * the structure as soon as all nested invocations of + * Tcl_Eval are done. + * ERR_IN_PROGRESS: Non-zero means an error unwind is already in progress. + * Zero means a command proc has been invoked since last + * error occured. + * ERR_ALREADY_LOGGED: Non-zero means information has already been logged + * in $errorInfo for the current Tcl_Eval instance, + * so Tcl_Eval needn't log it (used to implement the + * "error message log" command). + * ERROR_CODE_SET: Non-zero means that Tcl_SetErrorCode has been + * called to record information for the current + * error. Zero means Tcl_Eval must clear the + * errorCode variable if an error is returned. + * EXPR_INITIALIZED: 1 means initialization specific to expressions has + * been carried out. + */ + +#define DELETED 1 +#define ERR_IN_PROGRESS 2 +#define ERR_ALREADY_LOGGED 4 +#define ERROR_CODE_SET 8 +#define EXPR_INITIALIZED 0x10 + +/* + * Default value for the pdPrec and pdFormat fields of interpreters: + */ + +#define DEFAULT_PD_PREC 6 +#define DEFAULT_PD_FORMAT "%g" + +/* + *---------------------------------------------------------------- + * Data structures related to command parsing. These are used in + * tclParse.c and its clients. + *---------------------------------------------------------------- + */ + +/* + * The following data structure is used by various parsing procedures + * to hold information about where to store the results of parsing + * (e.g. the substituted contents of a quoted argument, or the result + * of a nested command). At any given time, the space available + * for output is fixed, but a procedure may be called to expand the + * space available if the current space runs out. + */ + +typedef struct ParseValue { + char *buffer; /* Address of first character in + * output buffer. */ + char *next; /* Place to store next character in + * output buffer. */ + char *end; /* Address of the last usable character + * in the buffer. */ + void (*expandProc) _ANSI_ARGS_((struct ParseValue *pvPtr, int needed)); + /* Procedure to call when space runs out; + * it will make more space. */ + ClientData clientData; /* Arbitrary information for use of + * expandProc. */ +} ParseValue; + +/* + * A table used to classify input characters to assist in parsing + * Tcl commands. The table should be indexed with a signed character + * using the CHAR_TYPE macro. The character may have a negative + * value. + */ + +extern char tclTypeTable[]; +#define CHAR_TYPE(c) (tclTypeTable+128)[c] + +/* + * Possible values returned by CHAR_TYPE: + * + * TCL_NORMAL - All characters that don't have special significance + * to the Tcl language. + * TCL_SPACE - Character is space, tab, or return. + * TCL_COMMAND_END - Character is newline or null or semicolon or + * close-bracket. + * TCL_QUOTE - Character is a double-quote. + * TCL_OPEN_BRACKET - Character is a "[". + * TCL_OPEN_BRACE - Character is a "{". + * TCL_CLOSE_BRACE - Character is a "}". + * TCL_BACKSLASH - Character is a "\". + * TCL_DOLLAR - Character is a "$". + */ + +#define TCL_NORMAL 0 +#define TCL_SPACE 1 +#define TCL_COMMAND_END 2 +#define TCL_QUOTE 3 +#define TCL_OPEN_BRACKET 4 +#define TCL_OPEN_BRACE 5 +#define TCL_CLOSE_BRACE 6 +#define TCL_BACKSLASH 7 +#define TCL_DOLLAR 8 + +/* + * Maximum number of levels of nesting permitted in Tcl commands (used + * to catch infinite recursion). + */ + +#define MAX_NESTING_DEPTH 1000 + +/* + * The macro below is used to modify a "char" value (e.g. by casting + * it to an unsigned character) so that it can be used safely with + * macros such as isspace. + */ + +#define UCHAR(c) ((unsigned char) (c)) + +/* + * Given a size or address, the macro below "aligns" it to the machine's + * memory unit size (e.g. an 8-byte boundary) so that anything can be + * placed at the aligned address without fear of an alignment error. + */ + +#define TCL_ALIGN(x) ((x + 7) & ~7) + +/* + * For each event source (created with Tcl_CreateEventSource) there + * is a structure of the following type: + */ + +typedef struct TclEventSource { + Tcl_EventSetupProc *setupProc; /* This procedure is called by + * Tcl_DoOneEvent to set up information + * for the wait operation, such as + * files to wait for or maximum + * timeout. */ + Tcl_EventCheckProc *checkProc; /* This procedure is called by + * Tcl_DoOneEvent after its wait + * operation to see what events + * are ready and queue them. */ + ClientData clientData; /* Arbitrary one-word argument to pass + * to setupProc and checkProc. */ + struct TclEventSource *nextPtr; /* Next in list of all event sources + * defined for applicaton. */ +} TclEventSource; + +/* + * The following macros are used to specify the runtime platform + * setting of the tclPlatform variable. + */ + +typedef enum { + TCL_PLATFORM_UNIX, /* Any Unix-like OS. */ + TCL_PLATFORM_MAC, /* MacOS. */ + TCL_PLATFORM_WINDOWS /* Any Microsoft Windows OS. */ +} TclPlatformType; + +/* + *---------------------------------------------------------------- + * Variables shared among Tcl modules but not used by the outside + * world: + *---------------------------------------------------------------- + */ + +extern Tcl_Time tclBlockTime; +extern int tclBlockTimeSet; +extern char * tclExecutableName; +extern TclEventSource * tclFirstEventSourcePtr; +extern Tcl_ChannelType tclFileChannelType; +extern char * tclMemDumpFileName; +extern TclPlatformType tclPlatform; + +/* + *---------------------------------------------------------------- + * Procedures shared among Tcl modules but not used by the outside + * world: + *---------------------------------------------------------------- + */ + +EXTERN void panic(); +EXTERN int TclCleanupChildren _ANSI_ARGS_((Tcl_Interp *interp, + int numPids, int *pidPtr, Tcl_Channel errorChan)); +EXTERN int TclCloseFile _ANSI_ARGS_((Tcl_File file)); +EXTERN char * TclConvertToNative _ANSI_ARGS_((Tcl_Interp *interp, + char *name, Tcl_DString *bufferPtr)); +EXTERN char * TclConvertToNetwork _ANSI_ARGS_((Tcl_Interp *interp, + char *name, Tcl_DString *bufferPtr)); +EXTERN void TclCopyAndCollapse _ANSI_ARGS_((int count, char *src, + char *dst)); +EXTERN int TclChdir _ANSI_ARGS_((Tcl_Interp *interp, + char *dirName)); +EXTERN void TclClosePipeFile _ANSI_ARGS_((Tcl_File file)); +EXTERN Tcl_Channel TclCreateCommandChannel _ANSI_ARGS_(( + Tcl_File readFile, Tcl_File writeFile, + Tcl_File errorFile, int numPids, int *pidPtr)); +EXTERN int TclCreatePipe _ANSI_ARGS_((Tcl_File *readPipe, + Tcl_File *writePipe)); +EXTERN int TclCreatePipeline _ANSI_ARGS_((Tcl_Interp *interp, + int argc, char **argv, int **pidArrayPtr, + Tcl_File *inPipePtr, + Tcl_File *outPipePtr, + Tcl_File *errFilePtr)); +EXTERN Tcl_File TclCreateTempFile _ANSI_ARGS_((char *contents)); +EXTERN void TclDeleteVars _ANSI_ARGS_((Interp *iPtr, + Tcl_HashTable *tablePtr)); +EXTERN int TclDoGlob _ANSI_ARGS_((Tcl_Interp *interp, + char *separators, Tcl_DString *headPtr, + char *tail)); +EXTERN void TclExpandParseValue _ANSI_ARGS_((ParseValue *pvPtr, + int needed)); +EXTERN void TclExprFloatError _ANSI_ARGS_((Tcl_Interp *interp, + double value)); +EXTERN int TclFindElement _ANSI_ARGS_((Tcl_Interp *interp, + char *list, char **elementPtr, char **nextPtr, + int *sizePtr, int *bracePtr)); +EXTERN Proc * TclFindProc _ANSI_ARGS_((Interp *iPtr, + char *procName)); +EXTERN void TclFreePackageInfo _ANSI_ARGS_((Interp *iPtr)); +EXTERN char * TclGetCwd _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN unsigned long TclGetClicks _ANSI_ARGS_((void)); +EXTERN char * TclGetExtension _ANSI_ARGS_((char *name)); +EXTERN void TclGetAndDetachPids _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Channel chan)); +EXTERN int TclGetDate _ANSI_ARGS_((char *p, + unsigned long now, long zone, + unsigned long *timePtr)); +EXTERN Tcl_Channel TclGetDefaultStdChannel _ANSI_ARGS_((int type)); +EXTERN char * TclGetEnv _ANSI_ARGS_((char *name)); +EXTERN int TclGetFrame _ANSI_ARGS_((Tcl_Interp *interp, + char *string, CallFrame **framePtrPtr)); +EXTERN int TclGetOpenMode _ANSI_ARGS_((Tcl_Interp *interp, + char *string, int *seekFlagPtr)); +EXTERN unsigned long TclGetSeconds _ANSI_ARGS_((void)); +EXTERN void TclGetTime _ANSI_ARGS_((Tcl_Time *time)); +EXTERN int TclGetTimeZone _ANSI_ARGS_((unsigned long time)); +EXTERN char * TclGetUserHome _ANSI_ARGS_((char *name, + Tcl_DString *bufferPtr)); +EXTERN int TclGetListIndex _ANSI_ARGS_((Tcl_Interp *interp, + char *string, int *indexPtr)); +EXTERN int TclGetLoadedPackages _ANSI_ARGS_((Tcl_Interp *interp, + char *targetName)); +EXTERN char * TclGetUserHome _ANSI_ARGS_((char *name, + Tcl_DString *bufferPtr)); +EXTERN int TclGuessPackageName _ANSI_ARGS_((char *fileName, + Tcl_DString *bufPtr)); +EXTERN int TclHasPipes _ANSI_ARGS_((void)); +EXTERN int TclHasSockets _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN int TclIdlePending _ANSI_ARGS_((void)); +EXTERN int TclInterpInit _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN Proc * TclIsProc _ANSI_ARGS_((Command *cmdPtr)); +EXTERN int TclLoadFile _ANSI_ARGS_((Tcl_Interp *interp, + char *fileName, char *sym1, char *sym2, + Tcl_PackageInitProc **proc1Ptr, + Tcl_PackageInitProc **proc2Ptr)); +EXTERN int TclMakeFileTable _ANSI_ARGS_((Tcl_Interp *interp, + int noStdio)); +EXTERN int TclMatchFiles _ANSI_ARGS_((Tcl_Interp *interp, + char *separators, Tcl_DString *dirPtr, + char *pattern, char *tail)); +EXTERN int TclNeedSpace _ANSI_ARGS_((char *start, char *end)); +EXTERN Tcl_File TclOpenFile _ANSI_ARGS_((char *fname, int mode)); +EXTERN int TclParseBraces _ANSI_ARGS_((Tcl_Interp *interp, + char *string, char **termPtr, ParseValue *pvPtr)); +EXTERN int TclParseNestedCmd _ANSI_ARGS_((Tcl_Interp *interp, + char *string, int flags, char **termPtr, + ParseValue *pvPtr)); +EXTERN int TclParseQuotes _ANSI_ARGS_((Tcl_Interp *interp, + char *string, int termChar, int flags, + char **termPtr, ParseValue *pvPtr)); +EXTERN int TclParseWords _ANSI_ARGS_((Tcl_Interp *interp, + char *string, int flags, int maxWords, + char **termPtr, int *argcPtr, char **argv, + ParseValue *pvPtr)); +EXTERN void TclPlatformExit _ANSI_ARGS_((int status)); +EXTERN void TclPlatformInit _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN char * TclPrecTraceProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, char *name1, char *name2, + int flags)); +EXTERN int TclPreventAliasLoop _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Interp *cmdInterp, char *cmdName, + Tcl_CmdProc *proc, ClientData clientData)); +EXTERN int TclReadFile _ANSI_ARGS_((Tcl_File file, + int shouldBlock, char *buf, int toRead)); +EXTERN int TclSeekFile _ANSI_ARGS_((Tcl_File file, + int offset, int whence)); +EXTERN int TclServiceIdle _ANSI_ARGS_((void)); +EXTERN void TclSetupEnv _ANSI_ARGS_((Tcl_Interp *interp)); +EXTERN int TclSockGetPort _ANSI_ARGS_((Tcl_Interp *interp, + char *string, char *proto, int *portPtr)); +EXTERN int TclSockMinimumBuffers _ANSI_ARGS_((int sock, + int size)); +EXTERN int TclSpawnPipeline _ANSI_ARGS_((Tcl_Interp *interp, + int *pidPtr, int *numPids, int argc, char **argv, + Tcl_File inputFile, + Tcl_File outputFile, + Tcl_File errorFile, + char *intIn, char *finalOut)); +EXTERN int TclTestChannelCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int TclTestChannelEventCmd _ANSI_ARGS_(( + ClientData clientData, Tcl_Interp *interp, + int argc, char **argv)); +EXTERN int TclUpdateReturnInfo _ANSI_ARGS_((Interp *iPtr)); +EXTERN int TclWaitForFile _ANSI_ARGS_((Tcl_File file, + int mask, int timeout)); +EXTERN char * TclWordEnd _ANSI_ARGS_((char *start, int nested, + int *semiPtr)); +EXTERN int TclWriteFile _ANSI_ARGS_((Tcl_File file, + int shouldBlock, char *buf, int toWrite)); + +/* + *---------------------------------------------------------------- + * Command procedures in the generic core: + *---------------------------------------------------------------- + */ + +EXTERN int Tcl_AfterCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_AppendCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_ArrayCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_BreakCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_CaseCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_CatchCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_CdCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_ClockCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_CloseCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_ConcatCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_ContinueCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_CpCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_EchoCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_EofCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_ErrorCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_EvalCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_ExecCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_ExitCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_ExprCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_FblockedCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_FconfigureCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_FileCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_FileEventCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_FlushCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_ForCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_ForeachCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_FormatCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_GetsCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_GlobalCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_GlobCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_HistoryCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_IfCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_IncrCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_InfoCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_InterpCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_JoinCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_LappendCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_LindexCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_LinsertCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_LlengthCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_ListCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_LoadCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_LrangeCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_LreplaceCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_LsCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_LsearchCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_LsortCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_MacBeepCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_MacSourceCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_MkdirCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_MvCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_OpenCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_PackageCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_PidCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_ProcCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_PutsCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_PwdCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_ReadCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_RegexpCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_RegsubCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_RenameCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_ReturnCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_RmCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_RmdirCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_ScanCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_SeekCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_SetCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_SplitCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_SocketCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_SourceCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_StringCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_SubstCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_SwitchCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_TellCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_TimeCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_TraceCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_UnsetCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_UpdateCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_UplevelCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_UpvarCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_VwaitCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int Tcl_WhileCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +EXTERN int TclUnsupported0Cmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); + +#endif /* _TCLINT */ diff --git a/contrib/tcl/generic/tclInterp.c b/contrib/tcl/generic/tclInterp.c new file mode 100644 index 0000000000000..a791fd55cd7b5 --- /dev/null +++ b/contrib/tcl/generic/tclInterp.c @@ -0,0 +1,2385 @@ +/* + * tclInterp.c -- + * + * This file implements the "interp" command which allows creation + * and manipulation of Tcl interpreters from within Tcl scripts. + * + * 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: @(#) tclInterp.c 1.66 96/04/15 17:26:10 + */ + +#include <stdio.h> +#include "tclInt.h" +#include "tclPort.h" + +/* + * Counter for how many aliases were created (global) + */ + +static int aliasCounter = 0; + +/* + * + * struct Slave: + * + * Used by the "interp" command to record and find information about slave + * interpreters. Maps from a command name in the master to information about + * a slave interpreter, e.g. what aliases are defined in it. + */ + +typedef struct { + Tcl_Interp *masterInterp; /* Master interpreter for this slave. */ + Tcl_HashEntry *slaveEntry; /* Hash entry in masters slave table for + * this slave interpreter. Used to find + * this record, and used when deleting the + * slave interpreter to delete it from the + * masters table. */ + Tcl_Interp *slaveInterp; /* The slave interpreter. */ + Tcl_Command interpCmd; /* Interpreter object command. */ + Tcl_HashTable aliasTable; /* Table which maps from names of commands + * in slave interpreter to struct Alias + * defined below. */ +} Slave; + +/* + * struct Alias: + * + * Stores information about an alias. Is stored in the slave interpreter + * and used by the source command to find the target command in the master + * when the source command is invoked. + */ + +typedef struct { + char *aliasName; /* Name of alias command. */ + char *targetName; /* Name of target command in master interp. */ + Tcl_Interp *targetInterp; /* Master interpreter. */ + int argc; /* Count of additional args to pass. */ + char **argv; /* Actual additional args to pass. */ + Tcl_HashEntry *aliasEntry; /* Entry for the alias hash table in slave. + * This is used by alias deletion to remove + * the alias from the slave interpreter + * alias table. */ + Tcl_HashEntry *targetEntry; /* Entry for target command in master. + * This is used in the master interpreter to + * map back from the target command to aliases + * redirecting to it. Random access to this + * hash table is never required - we are using + * a hash table only for convenience. */ + Tcl_Command slaveCmd; /* Source command in slave interpreter. */ +} Alias; + +/* + * struct Target: + * + * Maps from master interpreter commands back to the source commands in slave + * interpreters. This is needed because aliases can be created between sibling + * interpreters and must be deleted when the target interpreter is deleted. In + * case they would not be deleted the source interpreter would be left with a + * "dangling pointer". One such record is stored in the Master record of the + * master interpreter (in the targetTable hashtable, see below) with the + * master for each alias which directs to a command in the master. These + * records are used to remove the source command for an from a slave if/when + * the master is deleted. + */ + +typedef struct { + Tcl_Command slaveCmd; /* Command for alias in slave interp. */ + Tcl_Interp *slaveInterp; /* Slave Interpreter. */ +} Target; + +/* + * struct Master: + * + * This record is used for three purposes: First, slaveTable (a hashtable) + * maps from names of commands to slave interpreters. This hashtable is + * used to store information about slave interpreters of this interpreter, + * to map over all slaves, etc. The second purpose is to store information + * about all aliases in slaves (or siblings) which direct to target commands + * in this interpreter (using the targetTable hashtable). The third field in + * the record, isSafe, denotes whether the interpreter is safe or not. Safe + * interpreters have restricted functionality, can only create safe slave + * interpreters and can only load safe extensions. + */ + +typedef struct { + Tcl_HashTable slaveTable; /* Hash table for slave interpreters. + * Maps from command names to Slave records. */ + int isSafe; /* Am I a "safe" interpreter? */ + Tcl_HashTable targetTable; /* Hash table for Target Records. Contains + * all Target records which denote aliases + * from slaves or sibling interpreters that + * direct to commands in this interpreter. This + * table is used to remove dangling pointers + * from the slave (or sibling) interpreters + * when this interpreter is deleted. */ +} Master; + +/* + * Prototypes for local static procedures: + */ + +static int AliasCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *currentInterp, int argc, char **argv)); +static void AliasCmdDeleteProc _ANSI_ARGS_(( + ClientData clientData)); +static int AliasHelper _ANSI_ARGS_((Tcl_Interp *curInterp, + Tcl_Interp *slaveInterp, Tcl_Interp *masterInterp, + Master *masterPtr, char *aliasName, + char *targetName, int argc, char **argv)); +static int CreateInterpObject _ANSI_ARGS_((Tcl_Interp *interp, + int argc, char **argv)); +static Tcl_Interp *CreateSlave _ANSI_ARGS_((Tcl_Interp *interp, + char *slavePath, int safe)); +static int DeleteAlias _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Interp *slaveInterp, char *aliasName)); +static int DescribeAlias _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Interp *slaveInterp, char *aliasName)); +static int DeleteInterpObject _ANSI_ARGS_((Tcl_Interp *interp, + int argc, char **argv)); +static int DeleteOneInterpObject _ANSI_ARGS_((Tcl_Interp *interp, + char *path)); +static Tcl_Interp *GetInterp _ANSI_ARGS_((Tcl_Interp *interp, + Master *masterPtr, char *path, + Master **masterPtrPtr)); +static int GetTarget _ANSI_ARGS_((Tcl_Interp *interp, char *path, + char *aliasName)); +static void MasterRecordDeleteProc _ANSI_ARGS_(( + ClientData clientData, Tcl_Interp *interp)); +static int MakeSafe _ANSI_ARGS_((Tcl_Interp *interp)); +static int SlaveAliasHelper _ANSI_ARGS_((Tcl_Interp *interp, + int argc, char **argv)); +static int SlaveObjectCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static void SlaveObjectDeleteProc _ANSI_ARGS_(( + ClientData clientData)); +static void SlaveRecordDeleteProc _ANSI_ARGS_(( + ClientData clientData, Tcl_Interp *interp)); + +/* + * These are all the Tcl core commands which are available in a safe + * interpeter: + */ + +static char *TclCommandsToKeep[] = { + "after", "append", "array", + "break", + "case", "catch", "clock", "close", "concat", "continue", + "eof", "error", "eval", "expr", + "fblocked", "fconfigure", "flush", "for", "foreach", "format", + "gets", "global", + "history", + "if", "incr", "info", "interp", + "join", + "lappend", "lindex", "linsert", "list", "llength", "lower", "lrange", + "lreplace", "lsearch", "lsort", + "package", "pid", "proc", "puts", + "read", "regexp", "regsub", "rename", "return", + "scan", "seek", "set", "split", "string", "switch", + "tell", "trace", + "unset", "update", "uplevel", "upvar", + "vwait", + "while", + NULL}; +static int TclCommandsToKeepCt = + (sizeof (TclCommandsToKeep) / sizeof (char *)) -1 ; + +/* + *---------------------------------------------------------------------- + * + * TclPreventAliasLoop -- + * + * When defining an alias or renaming a command, prevent an alias + * loop from being formed. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * If TCL_ERROR is returned, the function also sets interp->result + * to an error message. + * + * NOTE: + * This function is public internal (instead of being static to + * this file) because it is also used from Tcl_RenameCmd. + * + *---------------------------------------------------------------------- + */ + +int +TclPreventAliasLoop(interp, cmdInterp, cmdName, proc, clientData) + Tcl_Interp *interp; /* Interp in which to report errors. */ + Tcl_Interp *cmdInterp; /* Interp in which the command is + * being defined. */ + char *cmdName; /* Name of Tcl command we are + * attempting to define. */ + Tcl_CmdProc *proc; /* The command procedure for the + * command being created. */ + ClientData clientData; /* The client data associated with the + * command to be created. */ +{ + Alias *aliasPtr, *nextAliasPtr; + Tcl_CmdInfo cmdInfo; + + /* + * If we are not creating or renaming an alias, then it is + * always OK to create or rename the command. + */ + + if (proc != AliasCmd) { + return TCL_OK; + } + + /* + * OK, we are dealing with an alias, so traverse the chain of aliases. + * If we encounter the alias we are defining (or renaming to) any in + * the chain then we have a loop. + */ + + aliasPtr = (Alias *) clientData; + nextAliasPtr = aliasPtr; + while (1) { + + /* + * If the target of the next alias in the chain is the same as the + * source alias, we have a loop. + */ + + if ((strcmp(nextAliasPtr->targetName, cmdName) == 0) && + (nextAliasPtr->targetInterp == cmdInterp)) { + Tcl_AppendResult(interp, "cannot define or rename alias \"", + aliasPtr->aliasName, "\": would create a loop", + (char *) NULL); + return TCL_ERROR; + } + + /* + * Otherwise, follow the chain one step further. If the target + * command is undefined then there is no loop. + */ + + if (Tcl_GetCommandInfo(nextAliasPtr->targetInterp, + nextAliasPtr->targetName, &cmdInfo) == 0) { + return TCL_OK; + } + + /* + * See if the target command is an alias - if so, follow the + * loop to its target command. Otherwise we do not have a loop. + */ + + if (cmdInfo.proc != AliasCmd) { + return TCL_OK; + } + nextAliasPtr = (Alias *) cmdInfo.clientData; + } + + /* NOTREACHED */ +} + +/* + *---------------------------------------------------------------------- + * + * MakeSafe -- + * + * Makes its argument interpreter contain only functionality that is + * defined to be part of Safe Tcl. + * + * Results: + * None. + * + * Side effects: + * Removes commands from its argument interpreter. + * + *---------------------------------------------------------------------- + */ + +static int +MakeSafe(interp) + Tcl_Interp *interp; /* Interpreter to be made safe. */ +{ + char **argv; /* Args for Tcl_Eval. */ + int argc, keep, i, j; /* Loop indices. */ + char *cmdGetGlobalCmds = "info commands"; /* What command to run. */ + char *cmdNoEnv = "unset env"; /* How to get rid of env. */ + Master *masterPtr; /* Master record of interp + * to be made safe. */ + Tcl_Channel chan; /* Channel to remove from + * safe interpreter. */ + + /* + * Below, Tcl_Eval sets interp->result, so we do not. + */ + + Tcl_ResetResult(interp); + if ((Tcl_Eval(interp, cmdGetGlobalCmds) == TCL_ERROR) || + (Tcl_SplitList(interp, interp->result, &argc, &argv) != TCL_OK)) { + return TCL_ERROR; + } + for (i = 0; i < argc; i++) { + for (keep = 0, j = 0; j < TclCommandsToKeepCt; j++) { + if (strcmp(TclCommandsToKeep[j], argv[i]) == 0) { + keep = 1; + break; + } + } + if (keep == 0) { + (void) Tcl_DeleteCommand(interp, argv[i]); + } + } + ckfree((char *) argv); + masterPtr = (Master *) Tcl_GetAssocData(interp, "tclMasterRecord", + NULL); + if (masterPtr == (Master *) NULL) { + panic("MakeSafe: could not find master record"); + } + masterPtr->isSafe = 1; + if (Tcl_Eval(interp, cmdNoEnv) == TCL_ERROR) { + return TCL_ERROR; + } + + /* + * Remove the standard channels from the interpreter; safe interpreters + * do not ordinarily have access to stdin, stdout and stderr. + */ + + chan = Tcl_GetStdChannel(TCL_STDIN); + if (chan != (Tcl_Channel) NULL) { + Tcl_UnregisterChannel(interp, chan); + } + chan = Tcl_GetStdChannel(TCL_STDOUT); + if (chan != (Tcl_Channel) NULL) { + Tcl_UnregisterChannel(interp, chan); + } + chan = Tcl_GetStdChannel(TCL_STDERR); + if (chan != (Tcl_Channel) NULL) { + Tcl_UnregisterChannel(interp, chan); + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * GetInterp -- + * + * Helper function to find a slave interpreter given a pathname. + * + * Results: + * Returns the slave interpreter known by that name in the calling + * interpreter, or NULL if no interpreter known by that name exists. + * + * Side effects: + * Assigns to the pointer variable passed in, if not NULL. + * + *---------------------------------------------------------------------- + */ + +static Tcl_Interp * +GetInterp(interp, masterPtr, path, masterPtrPtr) + Tcl_Interp *interp; /* Interp. to start search from. */ + Master *masterPtr; /* Its master record. */ + char *path; /* The path (name) of interp. to be found. */ + Master **masterPtrPtr; /* (Return) its master record. */ +{ + Tcl_HashEntry *hPtr; /* Search element. */ + Slave *slavePtr; /* Interim slave record. */ + char **argv; /* Split-up path (name) for interp to find. */ + int argc, i; /* Loop indices. */ + Tcl_Interp *searchInterp; /* Interim storage for interp. to find. */ + + if (masterPtrPtr != (Master **) NULL) *masterPtrPtr = masterPtr; + + if (Tcl_SplitList(interp, path, &argc, &argv) != TCL_OK) { + return (Tcl_Interp *) NULL; + } + + for (searchInterp = interp, i = 0; i < argc; i++) { + + hPtr = Tcl_FindHashEntry(&(masterPtr->slaveTable), argv[i]); + if (hPtr == (Tcl_HashEntry *) NULL) { + ckfree((char *) argv); + return (Tcl_Interp *) NULL; + } + slavePtr = (Slave *) Tcl_GetHashValue(hPtr); + searchInterp = slavePtr->slaveInterp; + if (searchInterp == (Tcl_Interp *) NULL) { + ckfree((char *) argv); + return (Tcl_Interp *) NULL; + } + masterPtr = (Master *) Tcl_GetAssocData(searchInterp, + "tclMasterRecord", NULL); + if (masterPtrPtr != (Master **) NULL) *masterPtrPtr = masterPtr; + if (masterPtr == (Master *) NULL) { + ckfree((char *) argv); + return (Tcl_Interp *) NULL; + } + } + ckfree((char *) argv); + return searchInterp; +} + +/* + *---------------------------------------------------------------------- + * + * CreateSlave -- + * + * Helper function to do the actual work of creating a slave interp + * and new object command. Also optionally makes the new slave + * interpreter "safe". + * + * Results: + * Returns the new Tcl_Interp * if successful or NULL if not. If failed, + * the result of the invoking interpreter contains an error message. + * + * Side effects: + * Creates a new slave interpreter and a new object command. + * + *---------------------------------------------------------------------- + */ + +static Tcl_Interp * +CreateSlave(interp, slavePath, safe) + Tcl_Interp *interp; /* Interp. to start search from. */ + char *slavePath; /* Path (name) of slave to create. */ + int safe; /* Should we make it "safe"? */ +{ + Master *masterPtr; /* Master record. */ + Tcl_Interp *slaveInterp; /* Ptr to slave interpreter. */ + Tcl_Interp *masterInterp; /* Ptr to master interp for slave. */ + Slave *slavePtr; /* Slave record. */ + Tcl_HashEntry *hPtr; /* Entry into interp hashtable. */ + int new; /* Indicates whether new entry. */ + int argc; /* Count of elements in slavePath. */ + char **argv; /* Elements in slavePath. */ + char *masterPath; /* Path to its master. */ + + masterPtr = (Master *) Tcl_GetAssocData(interp, "tclMasterRecord", + NULL); + if (masterPtr == (Master *) NULL) { + panic("CreatSlave: could not find master record"); + } + + if (Tcl_SplitList(interp, slavePath, &argc, &argv) != TCL_OK) { + return (Tcl_Interp *) NULL; + } + + if (argc < 2) { + masterInterp = interp; + if (argc == 1) { + slavePath = argv[0]; + } + } else { + masterPath = Tcl_Merge(argc-1, argv); + masterInterp = GetInterp(interp, masterPtr, masterPath, &masterPtr); + if (masterInterp == (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "interpreter named \"", masterPath, + "\" not found", (char *) NULL); + ckfree((char *) argv); + ckfree((char *) masterPath); + return (Tcl_Interp *) NULL; + } + ckfree((char *) masterPath); + slavePath = argv[argc-1]; + if (!safe) { + safe = masterPtr->isSafe; + } + } + hPtr = Tcl_CreateHashEntry(&(masterPtr->slaveTable), slavePath, &new); + if (new == 0) { + Tcl_AppendResult(interp, "interpreter named \"", slavePath, + "\" already exists, cannot create", (char *) NULL); + ckfree((char *) argv); + return (Tcl_Interp *) NULL; + } + slaveInterp = Tcl_CreateInterp(); + if (slaveInterp == (Tcl_Interp *) NULL) { + panic("CreateSlave: out of memory while creating a new interpreter"); + } + slavePtr = (Slave *) ckalloc((unsigned) sizeof(Slave)); + slavePtr->masterInterp = masterInterp; + slavePtr->slaveEntry = hPtr; + slavePtr->slaveInterp = slaveInterp; + slavePtr->interpCmd = Tcl_CreateCommand(masterInterp, slavePath, + SlaveObjectCmd, (ClientData) slaveInterp, SlaveObjectDeleteProc); + Tcl_InitHashTable(&(slavePtr->aliasTable), TCL_STRING_KEYS); + (void) Tcl_SetAssocData(slaveInterp, "tclSlaveRecord", + SlaveRecordDeleteProc, (ClientData) slavePtr); + Tcl_SetHashValue(hPtr, (ClientData) slavePtr); + Tcl_SetVar(slaveInterp, "tcl_interactive", "0", TCL_GLOBAL_ONLY); + + if (((safe) && (MakeSafe(slaveInterp) == TCL_ERROR)) || + ((!safe) && (Tcl_Init(slaveInterp) == TCL_ERROR))) { + Tcl_ResetResult(interp); + Tcl_AddErrorInfo(interp, Tcl_GetVar2(slaveInterp, "errorInfo", (char *) + NULL, TCL_GLOBAL_ONLY)); + Tcl_SetVar2(interp, "errorCode", (char *) NULL, + Tcl_GetVar2(slaveInterp, "errorCode", (char *) NULL, + TCL_GLOBAL_ONLY), + TCL_GLOBAL_ONLY); + if (slaveInterp->freeProc != NULL) { + interp->result = slaveInterp->result; + interp->freeProc = slaveInterp->freeProc; + slaveInterp->freeProc = 0; + } else { + Tcl_SetResult(interp, slaveInterp->result, TCL_VOLATILE); + } + Tcl_ResetResult(slaveInterp); + (void) Tcl_DeleteCommand(masterInterp, slavePath); + slaveInterp = (Tcl_Interp *) NULL; + } + ckfree((char *) argv); + return slaveInterp; +} + +/* + *---------------------------------------------------------------------- + * + * CreateInterpObject - + * + * Helper function to do the actual work of creating a new interpreter + * and an object command. + * + * Results: + * A Tcl result. + * + * Side effects: + * See user documentation for details. + * + *---------------------------------------------------------------------- + */ + +static int +CreateInterpObject(interp, argc, argv) + Tcl_Interp *interp; /* Invoking interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int safe; /* Create a safe interpreter? */ + Master *masterPtr; /* Master record. */ + int moreFlags; /* Expecting more flag args? */ + char *slavePath; /* Name of slave. */ + char localSlaveName[200]; /* Local area for creating names. */ + int i; /* Loop counter. */ + size_t len; /* Length of option argument. */ + static int interpCounter = 0; /* Unique id for created names. */ + + masterPtr = (Master *) Tcl_GetAssocData(interp, "tclMasterRecord", NULL); + if (masterPtr == (Master *) NULL) { + panic("CreateInterpObject: could not find master record"); + } + moreFlags = 1; + slavePath = NULL; + safe = masterPtr->isSafe; + + if (argc < 2 || argc > 5) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " create ?-safe? ?--? ?path?\"", (char *) NULL); + return TCL_ERROR; + } + for (i = 2; i < argc; i++) { + len = strlen(argv[i]); + if ((argv[i][0] == '-') && (moreFlags != 0)) { + if ((argv[i][1] == 's') && (strncmp(argv[i], "-safe", len) == 0) + && (len > 1)){ + safe = 1; + } else if ((strncmp(argv[i], "--", len) == 0) && (len > 1)) { + moreFlags = 0; + } else { + Tcl_AppendResult(interp, "bad option \"", argv[i], + "\": should be -safe", (char *) NULL); + return TCL_ERROR; + } + } else { + slavePath = argv[i]; + } + } + if (slavePath == (char *) NULL) { + sprintf(localSlaveName, "interp%d", interpCounter); + interpCounter++; + slavePath = localSlaveName; + } + if (CreateSlave(interp, slavePath, safe) != NULL) { + Tcl_AppendResult(interp, slavePath, (char *) NULL); + return TCL_OK; + } else { + /* + * CreateSlave already set interp->result if there was an error, + * so we do not do it here. + */ + return TCL_ERROR; + } +} + +/* + *---------------------------------------------------------------------- + * + * DeleteOneInterpObject -- + * + * Helper function for DeleteInterpObject. It deals with deleting one + * interpreter at a time. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Deletes an interpreter and its interpreter object command. + * + *---------------------------------------------------------------------- + */ + +static int +DeleteOneInterpObject(interp, path) + Tcl_Interp *interp; /* Interpreter for reporting errors. */ + char *path; /* Path of interpreter to delete. */ +{ + Master *masterPtr; /* Interim storage for master record.*/ + Slave *slavePtr; /* Interim storage for slave record. */ + Tcl_Interp *masterInterp; /* Master of interp. to delete. */ + Tcl_HashEntry *hPtr; /* Search element. */ + int localArgc; /* Local copy of count of elements in + * path (name) of interp. to delete. */ + char **localArgv; /* Local copy of path. */ + char *slaveName; /* Last component in path. */ + char *masterPath; /* One-before-last component in path.*/ + + masterPtr = (Master *) Tcl_GetAssocData(interp, "tclMasterRecord", NULL); + if (masterPtr == (Master *) NULL) { + panic("DeleteInterpObject: could not find master record"); + } + if (Tcl_SplitList(interp, path, &localArgc, &localArgv) != TCL_OK) { + Tcl_AppendResult(interp, "bad interpreter path \"", path, + "\"", (char *) NULL); + return TCL_ERROR; + } + if (localArgc < 2) { + masterInterp = interp; + if (localArgc == 0) { + slaveName = ""; + } else { + slaveName = localArgv[0]; + } + } else { + masterPath = Tcl_Merge(localArgc-1, localArgv); + masterInterp = GetInterp(interp, masterPtr, masterPath, &masterPtr); + if (masterInterp == (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "interpreter named \"", masterPath, + "\" not found", (char *) NULL); + ckfree((char *) localArgv); + ckfree((char *) masterPath); + return TCL_ERROR; + } + ckfree((char *) masterPath); + slaveName = localArgv[localArgc-1]; + } + hPtr = Tcl_FindHashEntry(&(masterPtr->slaveTable), slaveName); + if (hPtr == (Tcl_HashEntry *) NULL) { + ckfree((char *) localArgv); + Tcl_AppendResult(interp, "interpreter named \"", path, + "\" not found", (char *) NULL); + return TCL_ERROR; + } + slavePtr = (Slave *) Tcl_GetHashValue(hPtr); + slaveName = Tcl_GetCommandName(masterInterp, slavePtr->interpCmd); + if (Tcl_DeleteCommand(masterInterp, slaveName) != 0) { + ckfree((char *) localArgv); + Tcl_AppendResult(interp, "interpreter named \"", path, + "\" not found", (char *) NULL); + return TCL_ERROR; + } + ckfree((char *) localArgv); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * DeleteInterpObject -- + * + * Helper function to do the work of deleting zero or more + * interpreters and their interpreter object commands. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Deletes interpreters and their interpreter object command. + * + *---------------------------------------------------------------------- + */ + +static int +DeleteInterpObject(interp, argc, argv) + Tcl_Interp *interp; /* Interpreter start search from. */ + int argc; /* Number of arguments in vector. */ + char **argv; /* Contains path to interps to + * delete. */ +{ + int i; + + for (i = 2; i < argc; i++) { + if (DeleteOneInterpObject(interp, argv[i]) != TCL_OK) { + return TCL_ERROR; + } + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * AliasHelper -- + * + * Helper function to do the work to actually create an alias or + * delete an alias. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * An alias command is created and entered into the alias table + * for the slave interpreter. + * + *---------------------------------------------------------------------- + */ + +static int +AliasHelper(curInterp, slaveInterp, masterInterp, masterPtr, + aliasName, targetName, argc, argv) + Tcl_Interp *curInterp; /* Interp that invoked this proc. */ + Tcl_Interp *slaveInterp; /* Interp where alias cmd will live + * or from which alias will be + * deleted. */ + Tcl_Interp *masterInterp; /* Interp where target cmd will be. */ + Master *masterPtr; /* Master record for target interp. */ + char *aliasName; /* Name of alias cmd. */ + char *targetName; /* Name of target cmd. */ + int argc; /* Additional arguments to store */ + char **argv; /* with alias. */ +{ + Alias *aliasPtr; /* Storage for alias data. */ + Alias *tmpAliasPtr; /* Temp storage for alias to delete. */ + Tcl_HashEntry *hPtr; /* Entry into interp hashtable. */ + int i; /* Loop index. */ + int new; /* Is it a new hash entry? */ + Target *targetPtr; /* Maps from target command in master + * to source command in slave. */ + Slave *slavePtr; /* Maps from source command in slave + * to target command in master. */ + + slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, "tclSlaveRecord", NULL); + + /* + * Fix it up if there is no slave record. This can happen if someone + * uses "" as the source for an alias. + */ + + if (slavePtr == (Slave *) NULL) { + slavePtr = (Slave *) ckalloc((unsigned) sizeof(Slave)); + slavePtr->masterInterp = (Tcl_Interp *) NULL; + slavePtr->slaveEntry = (Tcl_HashEntry *) NULL; + slavePtr->slaveInterp = slaveInterp; + slavePtr->interpCmd = (Tcl_Command) NULL; + Tcl_InitHashTable(&(slavePtr->aliasTable), TCL_STRING_KEYS); + (void) Tcl_SetAssocData(slaveInterp, "tclSlaveRecord", + SlaveRecordDeleteProc, (ClientData) slavePtr); + } + + if ((targetName == (char *) NULL) || (targetName[0] == '\0')) { + if (argc != 0) { + Tcl_AppendResult(curInterp, "malformed command: should be", + " \"alias ", aliasName, " {}\"", (char *) NULL); + return TCL_ERROR; + } + + return DeleteAlias(curInterp, slaveInterp, aliasName); + } + + aliasPtr = (Alias *) ckalloc((unsigned) sizeof(Alias)); + aliasPtr->aliasName = (char *) ckalloc((unsigned) strlen(aliasName)+1); + aliasPtr->targetName = (char *) ckalloc((unsigned) strlen(targetName)+1); + strcpy(aliasPtr->aliasName, aliasName); + strcpy(aliasPtr->targetName, targetName); + aliasPtr->targetInterp = masterInterp; + + aliasPtr->argv = (char **) NULL; + aliasPtr->argc = argc; + if (aliasPtr->argc > 0) { + aliasPtr->argv = (char **) ckalloc((unsigned) sizeof(char *) * + aliasPtr->argc); + for (i = 0; i < argc; i++) { + aliasPtr->argv[i] = (char *) ckalloc((unsigned) strlen(argv[i])+1); + strcpy(aliasPtr->argv[i], argv[i]); + } + } + + if (TclPreventAliasLoop(curInterp, slaveInterp, aliasName, AliasCmd, + (ClientData) aliasPtr) != TCL_OK) { + for (i = 0; i < argc; i++) { + ckfree(aliasPtr->argv[i]); + } + if (aliasPtr->argv != (char **) NULL) { + ckfree((char *) aliasPtr->argv); + } + ckfree(aliasPtr->aliasName); + ckfree(aliasPtr->targetName); + ckfree((char *) aliasPtr); + + return TCL_ERROR; + } + + aliasPtr->slaveCmd = Tcl_CreateCommand(slaveInterp, aliasName, AliasCmd, + (ClientData) aliasPtr, AliasCmdDeleteProc); + + /* + * Make an entry in the alias table. If it already exists delete + * the alias command. Then retry. + */ + + do { + hPtr = Tcl_CreateHashEntry(&(slavePtr->aliasTable), aliasName, &new); + if (new == 0) { + tmpAliasPtr = (Alias *) Tcl_GetHashValue(hPtr); + (void) Tcl_DeleteCommand(slaveInterp, tmpAliasPtr->aliasName); + Tcl_DeleteHashEntry(hPtr); + } + } while (new == 0); + aliasPtr->aliasEntry = hPtr; + Tcl_SetHashValue(hPtr, (ClientData) aliasPtr); + + targetPtr = (Target *) ckalloc((unsigned) sizeof(Target)); + targetPtr->slaveCmd = aliasPtr->slaveCmd; + targetPtr->slaveInterp = slaveInterp; + + do { + hPtr = Tcl_CreateHashEntry(&(masterPtr->targetTable), + (char *) aliasCounter, &new); + aliasCounter++; + } while (new == 0); + + Tcl_SetHashValue(hPtr, (ClientData) targetPtr); + + aliasPtr->targetEntry = hPtr; + + curInterp->result = aliasPtr->aliasName; + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * SlaveAliasHelper - + * + * Handles the different forms of the "interp alias" command: + * - interp alias slavePath aliasName + * Describes an alias. + * - interp alias slavePath aliasName {} + * Deletes an alias. + * - interp alias slavePath srcCmd masterPath targetCmd args... + * Creates an alias. + * + * Results: + * A Tcl result. + * + * Side effects: + * See user documentation for details. + * + *---------------------------------------------------------------------- + */ + +static int +SlaveAliasHelper(interp, argc, argv) + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Master *masterPtr; /* Master record for current interp. */ + Tcl_Interp *slaveInterp, /* Interpreters used when */ + *masterInterp; /* creating an alias btn siblings. */ + Master *masterMasterPtr; /* Master record for master interp. */ + + masterPtr = (Master *) Tcl_GetAssocData(interp, "tclMasterRecord", NULL); + if (masterPtr == (Master *) NULL) { + panic("SlaveAliasHelper: could not find master record"); + } + if (argc < 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " alias slavePath slaveCmd masterPath masterCmd ?args ..?\"", + (char *) NULL); + return TCL_ERROR; + } + slaveInterp = GetInterp(interp, masterPtr, argv[2], NULL); + if (slaveInterp == (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "could not find interpreter \"", + argv[2], "\"", (char *) NULL); + return TCL_ERROR; + } + if (argc == 4) { + return DescribeAlias(interp, slaveInterp, argv[3]); + } + if (argc == 5 && strcmp(argv[4], "") == 0) { + return DeleteAlias(interp, slaveInterp, argv[3]); + } + if (argc < 6) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " alias slavePath slaveCmd masterPath masterCmd ?args ..?\"", + (char *) NULL); + return TCL_ERROR; + } + masterInterp = GetInterp(interp, masterPtr, argv[4], &masterMasterPtr); + if (masterInterp == (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "could not find interpreter \"", + argv[4], "\"", (char *) NULL); + return TCL_ERROR; + } + return AliasHelper(interp, slaveInterp, masterInterp, masterMasterPtr, + argv[3], argv[5], argc-6, argv+6); +} + +/* + *---------------------------------------------------------------------- + * + * DescribeAlias -- + * + * Sets interp->result to a Tcl list describing the given alias in the + * given interpreter: its target command and the additional arguments + * to prepend to any invocation of the alias. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +DescribeAlias(interp, slaveInterp, aliasName) + Tcl_Interp *interp; /* Interpreter for result and errors. */ + Tcl_Interp *slaveInterp; /* Interpreter defining alias. */ + char *aliasName; /* Name of alias to describe. */ +{ + Slave *slavePtr; /* Slave record for slave interpreter. */ + Tcl_HashEntry *hPtr; /* Search variable. */ + Alias *aliasPtr; /* Structure describing alias. */ + int i; /* Loop variable. */ + + slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, "tclSlaveRecord", + NULL); + if (slavePtr == (Slave *) NULL) { + panic("DescribeAlias: could not find slave record"); + } + hPtr = Tcl_FindHashEntry(&(slavePtr->aliasTable), aliasName); + if (hPtr == (Tcl_HashEntry *) NULL) { + return TCL_OK; + } + aliasPtr = (Alias *) Tcl_GetHashValue(hPtr); + Tcl_AppendResult(interp, aliasPtr->targetName, (char *) NULL); + for (i = 0; i < aliasPtr->argc; i++) { + Tcl_AppendElement(interp, aliasPtr->argv[i]); + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * DeleteAlias -- + * + * Deletes the given alias from the slave interpreter given. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Deletes the alias from the slave interpreter. + * + *---------------------------------------------------------------------- + */ + +static int +DeleteAlias(interp, slaveInterp, aliasName) + Tcl_Interp *interp; /* Interpreter for result and errors. */ + Tcl_Interp *slaveInterp; /* Interpreter defining alias. */ + char *aliasName; /* Name of alias to delete. */ +{ + Slave *slavePtr; /* Slave record for slave interpreter. */ + Tcl_HashEntry *hPtr; /* Search variable. */ + Alias *aliasPtr; /* Structure describing alias to delete. */ + + slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, "tclSlaveRecord", + NULL); + if (slavePtr == (Slave *) NULL) { + panic("DeleteAlias: could not find slave record"); + } + + /* + * Get the alias from the alias table, determine the current + * true name of the alias (it may have been renamed!) and then + * delete the true command name. The deleteProc on the alias + * command will take care of removing the entry from the alias + * table. + */ + + hPtr = Tcl_FindHashEntry(&(slavePtr->aliasTable), aliasName); + if (hPtr == (Tcl_HashEntry *) NULL) { + Tcl_AppendResult(interp, "alias \"", aliasName, "\" not found", + (char *) NULL); + return TCL_ERROR; + } + aliasPtr = (Alias *) Tcl_GetHashValue(hPtr); + aliasName = Tcl_GetCommandName(slaveInterp, aliasPtr->slaveCmd); + + /* + * NOTE: The deleteProc for this command will delete the + * alias from the hash table. The deleteProc will also + * delete the target information from the master interpreter + * target table. + */ + + if (Tcl_DeleteCommand(slaveInterp, aliasName) != 0) { + panic("DeleteAlias: did not find alias to be deleted"); + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetInterpPath -- + * + * Sets the result of the asking interpreter to a proper Tcl list + * containing the names of interpreters between the asking and + * target interpreters. The target interpreter must be either the + * same as the asking interpreter or one of its slaves (including + * recursively). + * + * Results: + * TCL_OK if the target interpreter is the same as, or a descendant + * of, the asking interpreter; TCL_ERROR else. This way one can + * distinguish between the case where the asking and target interps + * are the same (an empty list is the result, and TCL_OK is returned) + * and when the target is not a descendant of the asking interpreter + * (in which case the Tcl result is an error message and the function + * returns TCL_ERROR). + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetInterpPath(askingInterp, targetInterp) + Tcl_Interp *askingInterp; /* Interpreter to start search from. */ + Tcl_Interp *targetInterp; /* Interpreter to find. */ +{ + Master *masterPtr; /* Interim storage for Master record. */ + Slave *slavePtr; /* Interim storage for Slave record. */ + + if (targetInterp == askingInterp) { + return TCL_OK; + } + if (targetInterp == (Tcl_Interp *) NULL) { + return TCL_ERROR; + } + slavePtr = (Slave *) Tcl_GetAssocData(targetInterp, "tclSlaveRecord", + NULL); + if (slavePtr == (Slave *) NULL) { + return TCL_ERROR; + } + if (Tcl_GetInterpPath(askingInterp, slavePtr->masterInterp) == TCL_ERROR) { + /* + * AskingInterp->result was set by recursive call. + */ + return TCL_ERROR; + } + masterPtr = (Master *) Tcl_GetAssocData(slavePtr->masterInterp, + "tclMasterRecord", NULL); + if (masterPtr == (Master *) NULL) { + panic("Tcl_GetInterpPath: could not find master record"); + } + Tcl_AppendElement(askingInterp, Tcl_GetHashKey(&(masterPtr->slaveTable), + slavePtr->slaveEntry)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * GetTarget -- + * + * Sets the result of the invoking interpreter to a path name for + * the target interpreter of an alias in one of the slaves. + * + * Results: + * TCL_OK if the target interpreter of the alias is a slave of the + * invoking interpreter, TCL_ERROR else. + * + * Side effects: + * Sets the result of the invoking interpreter. + * + *---------------------------------------------------------------------- + */ + +static int +GetTarget(askingInterp, path, aliasName) + Tcl_Interp *askingInterp; /* Interpreter to start search from. */ + char *path; /* The path of the interp to find. */ + char *aliasName; /* The target of this allias. */ +{ + Tcl_Interp *slaveInterp; /* Interim storage for slave. */ + Slave *slaveSlavePtr; /* Its Slave record. */ + Master *masterPtr; /* Interim storage for Master record. */ + Tcl_HashEntry *hPtr; /* Search element. */ + Alias *aliasPtr; /* Data describing the alias. */ + + Tcl_ResetResult(askingInterp); + + masterPtr = (Master *) Tcl_GetAssocData(askingInterp, "tclMasterRecord", + NULL); + if (masterPtr == (Master *) NULL) { + panic("GetTarget: could not find master record"); + } + slaveInterp = GetInterp(askingInterp, masterPtr, path, NULL); + if (slaveInterp == (Tcl_Interp *) NULL) { + Tcl_AppendResult(askingInterp, "could not find interpreter \"", + path, "\"", (char *) NULL); + return TCL_ERROR; + } + slaveSlavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, "tclSlaveRecord", + NULL); + if (slaveSlavePtr == (Slave *) NULL) { + panic("GetTarget: could not find slave record"); + } + hPtr = Tcl_FindHashEntry(&(slaveSlavePtr->aliasTable), aliasName); + if (hPtr == (Tcl_HashEntry *) NULL) { + Tcl_AppendResult(askingInterp, "alias \"", aliasName, "\" in path \"", + path, "\" not found", (char *) NULL); + return TCL_ERROR; + } + aliasPtr = (Alias *) Tcl_GetHashValue(hPtr); + if (aliasPtr == (Alias *) NULL) { + panic("GetTarget: could not find alias record"); + } + if (Tcl_GetInterpPath(askingInterp, aliasPtr->targetInterp) == TCL_ERROR) { + Tcl_ResetResult(askingInterp); + Tcl_AppendResult(askingInterp, "target interpreter for alias \"", + aliasName, "\" in path \"", path, "\" is not my descendant", + (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_InterpCmd -- + * + * This procedure is invoked to process the "interp" 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_InterpCmd(clientData, interp, argc, argv) + ClientData clientData; /* Unused. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tcl_Interp *slaveInterp; /* A slave. */ + Tcl_Interp *masterInterp; /* A master. */ + Master *masterPtr; /* Master record for current interp. */ + Slave *slavePtr; /* Record for slave interp. */ + Tcl_HashEntry *hPtr; + Tcl_HashSearch hSearch; + size_t len; /* Length of command name. */ + int result; /* Result of eval. */ + char *cmdName; /* Name of sub command to do. */ + char *cmd; /* Command to eval. */ + Tcl_Channel chan; /* Channel to share or transfer. */ + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " cmd ?arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + cmdName = argv[1]; + + masterPtr = (Master *) Tcl_GetAssocData(interp, "tclMasterRecord", NULL); + if (masterPtr == (Master *) NULL) { + panic("Tcl_InterpCmd: could not find master record"); + } + + len = strlen(cmdName); + + if (cmdName[0] == 'a') { + if ((strncmp(cmdName, "alias", len) == 0) && (len <= 5)) { + return SlaveAliasHelper(interp, argc, argv); + } + + if (strcmp(cmdName, "aliases") == 0) { + if (argc != 2 && argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " aliases ?path?\"", (char *) NULL); + return TCL_ERROR; + } + if (argc == 3) { + slaveInterp = GetInterp(interp, masterPtr, argv[2], NULL); + if (slaveInterp == (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "interpreter \"", + argv[2], "\" not found", (char *) NULL); + return TCL_ERROR; + } + } else { + slaveInterp = interp; + } + slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, + "tclSlaveRecord", NULL); + if (slavePtr == (Slave *) NULL) { + return TCL_OK; + } + for (hPtr = Tcl_FirstHashEntry(&(slavePtr->aliasTable), &hSearch); + hPtr != NULL; + hPtr = Tcl_NextHashEntry(&hSearch)) { + Tcl_AppendElement(interp, + Tcl_GetHashKey(&(slavePtr->aliasTable), hPtr)); + } + return TCL_OK; + } + } + + if ((cmdName[0] == 'c') && (strncmp(cmdName, "create", len) == 0)) { + return CreateInterpObject(interp, argc, argv); + } + + if ((cmdName[0] == 'd') && (strncmp(cmdName, "delete", len) == 0)) { + return DeleteInterpObject(interp, argc, argv); + } + + if (cmdName[0] == 'e') { + if ((strncmp(cmdName, "exists", len) == 0) && (len > 1)) { + if (argc > 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " exists ?path?\"", (char *) NULL); + return TCL_ERROR; + } + if (argc == 3) { + if (GetInterp(interp, masterPtr, argv[2], NULL) == + (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "0", (char *) NULL); + } else { + Tcl_AppendResult(interp, "1", (char *) NULL); + } + } else { + Tcl_AppendResult(interp, "1", (char *) NULL); + } + return TCL_OK; + } + if ((strncmp(cmdName, "eval", len) == 0) && (len > 1)) { + if (argc < 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " eval path arg ?arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + slaveInterp = GetInterp(interp, masterPtr, argv[2], NULL); + if (slaveInterp == (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "interpreter named \"", argv[2], + "\" not found", (char *) NULL); + return TCL_ERROR; + } + cmd = Tcl_Concat(argc-3, argv+3); + Tcl_Preserve((ClientData) slaveInterp); + result = Tcl_Eval(slaveInterp, cmd); + ckfree((char *) cmd); + + /* + * Now make the result and any error information accessible. We + * have to be careful because the slave interpreter and the current + * interpreter can be the same - do not destroy the result.. This + * can happen if an interpreter contains an alias which is directed + * at a target command in the same interpreter. + */ + + if (interp != slaveInterp) { + if (result == TCL_ERROR) { + + /* + * An error occurred, so transfer error information from + * the target interpreter back to our interpreter. Must + * clear interp's result before calling Tcl_AddErrorInfo, + * since Tcl_AddErrorInfo will store the interp's result in + * errorInfo before appending slaveInterp's $errorInfo; + * we've already got everything we need in the slave + * interpreter's $errorInfo. + */ + + Tcl_ResetResult(interp); + Tcl_AddErrorInfo(interp, Tcl_GetVar2(slaveInterp, + "errorInfo", (char *) NULL, TCL_GLOBAL_ONLY)); + Tcl_SetVar2(interp, "errorCode", (char *) NULL, + Tcl_GetVar2(slaveInterp, "errorCode", (char *) + NULL, TCL_GLOBAL_ONLY), + TCL_GLOBAL_ONLY); + } + if (slaveInterp->freeProc != NULL) { + interp->result = slaveInterp->result; + interp->freeProc = slaveInterp->freeProc; + slaveInterp->freeProc = 0; + } else { + Tcl_SetResult(interp, slaveInterp->result, TCL_VOLATILE); + } + Tcl_ResetResult(slaveInterp); + } + Tcl_Release((ClientData) slaveInterp); + return result; + } + } + + if ((cmdName[0] == 'i') && (strncmp(cmdName, "issafe", len) == 0)) { + if (argc > 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " issafe ?path?\"", (char *) NULL); + return TCL_ERROR; + } + if (argc == 3) { + slaveInterp = GetInterp(interp, masterPtr, argv[2], &masterPtr); + if (slaveInterp == (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "interpreter \"", argv[2], + "\" not found", (char *) NULL); + return TCL_ERROR; + } + } + if (masterPtr->isSafe == 0) { + Tcl_AppendResult(interp, "0", (char *) NULL); + } else { + Tcl_AppendResult(interp, "1", (char *) NULL); + } + return TCL_OK; + } + + if (cmdName[0] == 's') { + if ((strncmp(cmdName, "slaves", len) == 0) && (len > 1)) { + if (argc != 2 && argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " slaves ?path?\"", (char *) NULL); + return TCL_ERROR; + } + if (argc == 3) { + if (GetInterp(interp, masterPtr, argv[2], &masterPtr) == + (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "interpreter \"", argv[2], + "\" not found", (char *) NULL); + return TCL_ERROR; + } + } + for (hPtr = Tcl_FirstHashEntry(&(masterPtr->slaveTable), &hSearch); + hPtr != NULL; + hPtr = Tcl_NextHashEntry(&hSearch)) { + Tcl_AppendElement(interp, + Tcl_GetHashKey(&(masterPtr->slaveTable), hPtr)); + } + return TCL_OK; + } + if ((strncmp(cmdName, "share", len) == 0) && (len > 1)) { + if (argc != 5) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " share srcPath channelId destPath\"", (char *) NULL); + return TCL_ERROR; + } + masterInterp = GetInterp(interp, masterPtr, argv[2], NULL); + if (masterInterp == (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "interpreter \"", argv[2], + "\" not found", (char *) NULL); + return TCL_ERROR; + } + slaveInterp = GetInterp(interp, masterPtr, argv[4], NULL); + if (slaveInterp == (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "interpreter \"", argv[4], + "\" not found", (char *) NULL); + return TCL_ERROR; + } + chan = Tcl_GetChannel(masterInterp, argv[3], NULL); + if (chan == (Tcl_Channel) NULL) { + if (interp != masterInterp) { + Tcl_AppendResult(interp, masterInterp->result, + (char *) NULL); + Tcl_ResetResult(masterInterp); + } + return TCL_ERROR; + } + Tcl_RegisterChannel(slaveInterp, chan); + return TCL_OK; + } + } + + if ((cmdName[0] == 't') && (strncmp(cmdName, "target", len) == 0)) { + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " target path alias\"", (char *) NULL); + return TCL_ERROR; + } + return GetTarget(interp, argv[2], argv[3]); + } + + if ((cmdName[0] == 't') && (strncmp(cmdName, "transfer", len) == 0)) { + if (argc != 5) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " transfer srcPath channelId destPath\"", (char *) NULL); + return TCL_ERROR; + } + masterInterp = GetInterp(interp, masterPtr, argv[2], NULL); + if (masterInterp == (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "interpreter \"", argv[2], + "\" not found", (char *) NULL); + return TCL_ERROR; + } + slaveInterp = GetInterp(interp, masterPtr, argv[4], NULL); + if (slaveInterp == (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "interpreter \"", argv[4], + "\" not found", (char *) NULL); + return TCL_ERROR; + } + chan = Tcl_GetChannel(masterInterp, argv[3], NULL); + if (chan == (Tcl_Channel) NULL) { + if (interp != masterInterp) { + Tcl_AppendResult(interp, masterInterp->result, (char *) NULL); + Tcl_ResetResult(masterInterp); + } + return TCL_ERROR; + } + Tcl_RegisterChannel(slaveInterp, chan); + if (Tcl_UnregisterChannel(masterInterp, chan) != TCL_OK) { + if (interp != masterInterp) { + Tcl_AppendResult(interp, masterInterp->result, (char *) NULL); + Tcl_ResetResult(masterInterp); + } + return TCL_ERROR; + } + + return TCL_OK; + } + + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": should be alias, aliases, create, delete, exists, eval, ", + "issafe, share, slaves, target or transfer", (char *) NULL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * SlaveObjectCmd -- + * + * Command to manipulate an interpreter, e.g. to send commands to it + * to be evaluated. One such command exists for each slave interpreter. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See user documentation for details. + * + *---------------------------------------------------------------------- + */ + +static int +SlaveObjectCmd(clientData, interp, argc, argv) + ClientData clientData; /* Slave interpreter. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Master *masterPtr; /* Master record for slave interp. */ + Slave *slavePtr; /* Slave record. */ + Tcl_Interp *slaveInterp; /* Slave interpreter. */ + char *cmdName; /* Name of command to do. */ + char *cmd; /* Command to evaluate in slave + * interpreter. */ + Alias *aliasPtr; /* Alias information. */ + Tcl_HashEntry *hPtr; /* For local searches. */ + Tcl_HashSearch hSearch; /* For local searches. */ + int result; /* Loop counter, status return. */ + size_t len; /* Length of command name. */ + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " cmd ?arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + + slaveInterp = (Tcl_Interp *) clientData; + if (slaveInterp == (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "interpreter ", argv[0], " has been deleted", + (char *) NULL); + return TCL_ERROR; + } + + slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, + "tclSlaveRecord", NULL); + if (slavePtr == (Slave *) NULL) { + panic("SlaveObjectCmd: could not find slave record"); + } + + cmdName = argv[1]; + len = strlen(cmdName); + + if (cmdName[0] == 'a') { + if (strncmp(cmdName, "alias", len) == 0) { + switch (argc-2) { + case 0: + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " alias aliasName ?targetName? ?args..?", + (char *) NULL); + return TCL_ERROR; + + case 1: + + /* + * Return the name of the command in the current + * interpreter for which the argument is an alias in the + * slave interpreter, and the list of saved arguments + */ + + return DescribeAlias(interp, slaveInterp, argv[2]); + + default: + masterPtr = (Master *) Tcl_GetAssocData(interp, + "tclMasterRecord", NULL); + if (masterPtr == (Master *) NULL) { + panic("SlaveObjectCmd: could not find master record"); + } + return AliasHelper(interp, slaveInterp, interp, masterPtr, + argv[2], argv[3], argc-4, argv+4); + } + } + + if (strncmp(cmdName, "aliases", len) == 0) { + + /* + * Return the names of all the aliases created in the + * slave interpreter. + */ + + for (hPtr = Tcl_FirstHashEntry(&(slavePtr->aliasTable), + &hSearch); + hPtr != (Tcl_HashEntry *) NULL; + hPtr = Tcl_NextHashEntry(&hSearch)) { + aliasPtr = (Alias *) Tcl_GetHashValue(hPtr); + Tcl_AppendElement(interp, aliasPtr->aliasName); + } + return TCL_OK; + } + } + + + if ((cmdName[0] == 'e') && (strncmp(cmdName, "eval", len) == 0)) { + if (argc < 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " eval arg ?arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + + cmd = Tcl_Concat(argc-2, argv+2); + Tcl_Preserve((ClientData) slaveInterp); + result = Tcl_Eval(slaveInterp, cmd); + ckfree((char *) cmd); + + /* + * Now make the result and any error information accessible. We have + * to be careful because the slave interpreter and the current + * interpreter can be the same - do not destroy the result.. This + * can happen if an interpreter contains an alias which is directed + * at a target command in the same interpreter. + */ + + if (interp != slaveInterp) { + if (result == TCL_ERROR) { + + /* + * An error occurred, so transfer error information from the + * destination interpreter back to our interpreter. Must clear + * interp's result before calling Tcl_AddErrorInfo, since + * Tcl_AddErrorInfo will store the interp's result in errorInfo + * before appending slaveInterp's $errorInfo; + * we've already got everything we need in the slave + * interpreter's $errorInfo. + */ + + Tcl_ResetResult(interp); + Tcl_AddErrorInfo(interp, Tcl_GetVar2(slaveInterp, + "errorInfo", (char *) NULL, TCL_GLOBAL_ONLY)); + Tcl_SetVar2(interp, "errorCode", (char *) NULL, + Tcl_GetVar2(slaveInterp, "errorCode", (char *) NULL, + TCL_GLOBAL_ONLY), TCL_GLOBAL_ONLY); + } + if (slaveInterp->freeProc != NULL) { + interp->result = slaveInterp->result; + interp->freeProc = slaveInterp->freeProc; + slaveInterp->freeProc = 0; + } else { + Tcl_SetResult(interp, slaveInterp->result, TCL_VOLATILE); + } + Tcl_ResetResult(slaveInterp); + } + Tcl_Release((ClientData) slaveInterp); + return result; + } + + if ((cmdName[0] == 'i') && (strncmp(cmdName, "issafe", len) == 0)) { + if (argc > 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " issafe\"", (char *) NULL); + return TCL_ERROR; + } + masterPtr = (Master *) Tcl_GetAssocData(slaveInterp, + "tclMasterRecord", NULL); + if (masterPtr == (Master *) NULL) { + panic("SlaveObjectCmd: could not find master record"); + } + if (masterPtr->isSafe == 1) { + Tcl_AppendResult(interp, "1", (char *) NULL); + } else { + Tcl_AppendResult(interp, "0", (char *) NULL); + } + return TCL_OK; + } + + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": should be alias, aliases, eval or issafe", (char *) NULL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * SlaveObjectDeleteProc -- + * + * Invoked when an object command for a slave interpreter is deleted; + * cleans up all state associated with the slave interpreter and destroys + * the slave interpreter. + * + * Results: + * None. + * + * Side effects: + * Cleans up all state associated with the slave interpreter and + * destroys the slave interpreter. + * + *---------------------------------------------------------------------- + */ + +static void +SlaveObjectDeleteProc(clientData) + ClientData clientData; /* The SlaveRecord for the command. */ +{ + Slave *slavePtr; /* Interim storage for Slave record. */ + Tcl_Interp *slaveInterp; /* And for a slave interp. */ + + slaveInterp = (Tcl_Interp *) clientData; + slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, "tclSlaveRecord",NULL); + if (slavePtr == (Slave *) NULL) { + panic("SlaveObjectDeleteProc: could not find slave record"); + } + + /* + * Delete the entry in the slave table in the master interpreter now. + * This is to avoid an infinite loop in the Master hash table cleanup in + * the master interpreter. This can happen if this slave is being deleted + * because the master is being deleted and the slave deletion is deferred + * because it is still active. + */ + + Tcl_DeleteHashEntry(slavePtr->slaveEntry); + + /* + * Set to NULL so that when the slave record is cleaned up in the slave + * it does not try to delete the command causing all sorts of grief. + * See SlaveRecordDeleteProc(). + */ + + slavePtr->interpCmd = NULL; + + /* + * Destroy the interpreter - this will cause all the deleteProcs for + * all commands (including aliases) to run. + * + * NOTE: WE ASSUME THAT THE INTERPRETER HAS NOT BEEN DELETED YET!! + */ + + Tcl_DeleteInterp(slavePtr->slaveInterp); +} + +/* + *---------------------------------------------------------------------- + * + * AliasCmd -- + * + * This is the procedure that services invocations of aliases in a + * slave interpreter. One such command exists for each alias. When + * invoked, this procedure redirects the invocation to the target + * command in the master interpreter as designated by the Alias + * record associated with this command. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Causes forwarding of the invocation; all possible side effects + * may occur as a result of invoking the command to which the + * invocation is forwarded. + * + *---------------------------------------------------------------------- + */ + +static int +AliasCmd(clientData, interp, argc, argv) + ClientData clientData; /* Alias record. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Alias *aliasPtr; /* Describes the alias. */ + Tcl_CmdInfo cmdInfo; /* Info about target command. */ + int result; /* Result of execution. */ + int i, j, addArgc; /* Loop counters. */ + int localArgc; /* Local argument count. */ + char **localArgv; /* Local argument vector. */ + Interp *iPtr; /* The target interpreter. */ + + aliasPtr = (Alias *) clientData; + + result = Tcl_GetCommandInfo(aliasPtr->targetInterp, aliasPtr->targetName, + &cmdInfo); + if (result == 0) { + Tcl_AppendResult(interp, "aliased target \"", aliasPtr->targetName, + "\" for \"", argv[0], "\" not found", (char *) NULL); + return TCL_ERROR; + } + if (aliasPtr->argc <= 0) { + localArgv = argv; + localArgc = argc; + } else { + addArgc = aliasPtr->argc; + localArgc = argc + addArgc; + localArgv = (char **) ckalloc((unsigned) sizeof(char *) * localArgc); + localArgv[0] = argv[0]; + for (i = 0, j = 1; i < addArgc; i++, j++) { + localArgv[j] = aliasPtr->argv[i]; + } + for (i = 1; i < argc; i++, j++) { + localArgv[j] = argv[i]; + } + } + + /* + * Invoke the redirected command in the target interpreter. Note + * that we are not calling eval because of possible security holes with + * $ substitution and bracketed command evaluation. + * + * We duplicate some code here from Tcl_Eval to implement recursion + * level counting and correct deletion of the target interpreter if + * that was requested but delayed because of in-progress evaluations. + */ + + iPtr = (Interp *) aliasPtr->targetInterp; + iPtr->numLevels++; + Tcl_Preserve((ClientData) iPtr); + Tcl_ResetResult((Tcl_Interp *) iPtr); + result = (cmdInfo.proc)(cmdInfo.clientData, (Tcl_Interp *) iPtr, + localArgc, localArgv); + iPtr->numLevels--; + if (iPtr->numLevels == 0) { + if (result == TCL_RETURN) { + result = TclUpdateReturnInfo(iPtr); + } + if ((result != TCL_OK) && (result != TCL_ERROR)) { + Tcl_ResetResult((Tcl_Interp *) iPtr); + 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; + } + } + + /* + * Clean up any locally allocated argument vector structure. + */ + + if (localArgv != argv) { + ckfree((char *) localArgv); + } + + /* + * + * NOTE: Need to be careful if the target interpreter and the current + * interpreter are the same - must not destroy result. This may happen + * if an alias is created which redirects to a command in the same + * interpreter as the one in which the source command will be defined. + * Also: We cannot use aliasPtr any more because the alias may have + * been deleted. + */ + + if (interp != (Tcl_Interp *) iPtr) { + if (result == TCL_ERROR) { + /* + * An error occurred, so transfer error information from the + * destination interpreter back to our interpreter. Some tricky + * points: + * 1. Must call Tcl_AddErrorInfo in destination interpreter to + * make sure that the errorInfo variable has been initialized + * (it's initialized lazily and might not have been initialized + * yet). + * 2. Must clear interp's result before calling Tcl_AddErrorInfo, + * since Tcl_AddErrorInfo will store the interp's result in + * errorInfo before appending aliasPtr->interp's $errorInfo; + * we've already got everything we need in the redirected + * interpreter's $errorInfo. + */ + + if (!(iPtr->flags & ERR_ALREADY_LOGGED)) { + Tcl_AddErrorInfo((Tcl_Interp *) iPtr, ""); + } + iPtr->flags &= ~ERR_ALREADY_LOGGED; + Tcl_ResetResult(interp); + Tcl_AddErrorInfo(interp, Tcl_GetVar2((Tcl_Interp *) iPtr, + "errorInfo", (char *) NULL, TCL_GLOBAL_ONLY)); + Tcl_SetVar2(interp, "errorCode", (char *) NULL, + Tcl_GetVar2((Tcl_Interp *) iPtr, "errorCode", + (char *) NULL, TCL_GLOBAL_ONLY), TCL_GLOBAL_ONLY); + } + if (iPtr->freeProc != NULL) { + interp->result = iPtr->result; + interp->freeProc = iPtr->freeProc; + iPtr->freeProc = 0; + } else { + Tcl_SetResult(interp, iPtr->result, TCL_VOLATILE); + } + Tcl_ResetResult((Tcl_Interp *) iPtr); + } + Tcl_Release((ClientData) iPtr); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * AliasCmdDeleteProc -- + * + * Is invoked when an alias command is deleted in a slave. Cleans up + * all storage associated with this alias. + * + * Results: + * None. + * + * Side effects: + * Deletes the alias record and its entry in the alias table for + * the interpreter. + * + *---------------------------------------------------------------------- + */ + +static void +AliasCmdDeleteProc(clientData) + ClientData clientData; /* The alias record for this alias. */ +{ + Alias *aliasPtr; /* Alias record for alias to delete. */ + Target *targetPtr; /* Record for target of this alias. */ + int i; /* Loop counter. */ + + aliasPtr = (Alias *) clientData; + + targetPtr = (Target *) Tcl_GetHashValue(aliasPtr->targetEntry); + ckfree((char *) targetPtr); + Tcl_DeleteHashEntry(aliasPtr->targetEntry); + + ckfree((char *) aliasPtr->targetName); + ckfree((char *) aliasPtr->aliasName); + for (i = 0; i < aliasPtr->argc; i++) { + ckfree((char *) aliasPtr->argv[i]); + } + if (aliasPtr->argv != (char **) NULL) { + ckfree((char *) aliasPtr->argv); + } + + Tcl_DeleteHashEntry(aliasPtr->aliasEntry); + + ckfree((char *) aliasPtr); +} + +/* + *---------------------------------------------------------------------- + * + * MasterRecordDeleteProc - + * + * Is invoked when an interpreter (which is using the "interp" facility) + * is deleted, and it cleans up the storage associated with the + * "tclMasterRecord" assoc-data entry. + * + * Results: + * None. + * + * Side effects: + * Cleans up storage. + * + *---------------------------------------------------------------------- + */ + +static void +MasterRecordDeleteProc(clientData, interp) + ClientData clientData; /* Master record for deleted interp. */ + Tcl_Interp *interp; /* Interpreter being deleted. */ +{ + Target *targetPtr; /* Loop variable. */ + Tcl_HashEntry *hPtr; /* Search element. */ + Tcl_HashSearch hSearch; /* Search record (internal). */ + Slave *slavePtr; /* Loop variable. */ + char *cmdName; /* Name of command to delete. */ + Master *masterPtr; /* Interim storage. */ + + masterPtr = (Master *) clientData; + for (hPtr = Tcl_FirstHashEntry(&(masterPtr->slaveTable), &hSearch); + hPtr != NULL; + hPtr = Tcl_NextHashEntry(&hSearch)) { + slavePtr = (Slave *) Tcl_GetHashValue(hPtr); + cmdName = Tcl_GetCommandName(interp, slavePtr->interpCmd); + (void) Tcl_DeleteCommand(interp, cmdName); + } + Tcl_DeleteHashTable(&(masterPtr->slaveTable)); + + for (hPtr = Tcl_FirstHashEntry(&(masterPtr->targetTable), &hSearch); + hPtr != NULL; + hPtr = Tcl_FirstHashEntry(&(masterPtr->targetTable), &hSearch)) { + targetPtr = (Target *) Tcl_GetHashValue(hPtr); + cmdName = Tcl_GetCommandName(targetPtr->slaveInterp, + targetPtr->slaveCmd); + (void) Tcl_DeleteCommand(targetPtr->slaveInterp, cmdName); + } + Tcl_DeleteHashTable(&(masterPtr->targetTable)); + + ckfree((char *) masterPtr); +} + +/* + *---------------------------------------------------------------------- + * + * SlaveRecordDeleteProc -- + * + * Is invoked when an interpreter (which is using the interp facility) + * is deleted, and it cleans up the storage associated with the + * tclSlaveRecord assoc-data entry. + * + * Results: + * None + * + * Side effects: + * Cleans up storage. + * + *---------------------------------------------------------------------- + */ + +static void +SlaveRecordDeleteProc(clientData, interp) + ClientData clientData; /* Slave record for deleted interp. */ + Tcl_Interp *interp; /* Interpreter being deleted. */ +{ + Slave *slavePtr; /* Interim storage. */ + Alias *aliasPtr; + Tcl_HashTable *hTblPtr; + Tcl_HashEntry *hPtr; + Tcl_HashSearch hSearch; + + slavePtr = (Slave *) clientData; + + /* + * In every case that we call SetAssocData on "tclSlaveRecord", + * slavePtr is not NULL. Otherwise we panic. + */ + + if (slavePtr == NULL) { + panic("SlaveRecordDeleteProc: NULL slavePtr"); + } + + if (slavePtr->interpCmd != (Tcl_Command) NULL) { + Command *cmdPtr = (Command *) slavePtr->interpCmd; + + /* + * The interpCmd has not been deleted in the master yet, since + * it's callback sets interpCmd to NULL. + * + * Probably Tcl_DeleteInterp() was called on this interpreter directly, + * rather than via "interp delete", or equivalent (deletion of the + * command in the master). + * + * Perform the cleanup done by SlaveObjectDeleteProc() directly, + * and turn off the callback now (since we are about to free slavePtr + * and this interpreter is going away, while the deletion of commands + * in the master may be deferred). + */ + + Tcl_DeleteHashEntry(slavePtr->slaveEntry); + cmdPtr->clientData = NULL; + cmdPtr->deleteProc = NULL; + cmdPtr->deleteData = NULL; + + /* + * Get the command name from the master interpreter instead of + * relying on the stored name; the command may have been renamed. + */ + + Tcl_DeleteCommand(slavePtr->masterInterp, + Tcl_GetCommandName(slavePtr->masterInterp, + slavePtr->interpCmd)); + } + + /* + * If there are any aliases, delete those now. This removes any + * dependency on the order of deletion between commands and the + * slave record. + */ + + hTblPtr = (Tcl_HashTable *) &(slavePtr->aliasTable); + for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); + hPtr != (Tcl_HashEntry *) NULL; + hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch)) { + aliasPtr = (Alias *) Tcl_GetHashValue(hPtr); + + /* + * The call to Tcl_DeleteCommand will release the storage + * occuppied by the hash entry and the alias record. + * NOTE that we cannot use the alias name directly because its + * storage will be deleted in the command deletion callback. Hence + * we must use the name for the command as stored in the hash table. + */ + + Tcl_DeleteCommand(interp, + Tcl_GetCommandName(interp, aliasPtr->slaveCmd)); + } + + /* + * Finally dispose of the slave record itself. + */ + + ckfree((char *) slavePtr); +} + +/* + *---------------------------------------------------------------------- + * + * TclInterpInit -- + * + * Initializes the invoking interpreter for using the "interp" + * facility. This is called from inside Tcl_Init. + * + * Results: + * None. + * + * Side effects: + * Adds the "interp" command to an interpreter and initializes several + * records in the associated data of the invoking interpreter. + * + *---------------------------------------------------------------------- + */ + +int +TclInterpInit(interp) + Tcl_Interp *interp; /* Interpreter to initialize. */ +{ + Master *masterPtr; /* Its Master record. */ + + masterPtr = (Master *) ckalloc((unsigned) sizeof(Master)); + masterPtr->isSafe = 0; + Tcl_InitHashTable(&(masterPtr->slaveTable), TCL_STRING_KEYS); + Tcl_InitHashTable(&(masterPtr->targetTable), TCL_ONE_WORD_KEYS); + + (void) Tcl_SetAssocData(interp, "tclMasterRecord", MasterRecordDeleteProc, + (ClientData) masterPtr); + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_IsSafe -- + * + * Determines whether an interpreter is safe + * + * Results: + * 1 if it is safe, 0 if it is not. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_IsSafe(interp) + Tcl_Interp *interp; /* Is this interpreter "safe" ? */ +{ + Master *masterPtr; /* Its master record. */ + + if (interp == (Tcl_Interp *) NULL) { + return 0; + } + masterPtr = (Master *) Tcl_GetAssocData(interp, "tclMasterRecord", NULL); + if (masterPtr == (Master *) NULL) { + panic("Tcl_IsSafe: could not find master record"); + } + return masterPtr->isSafe; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_MakeSafe -- + * + * Makes an interpreter safe. + * + * Results: + * TCL_OK if it succeeds, TCL_ERROR else. + * + * Side effects: + * Removes functionality from an interpreter. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_MakeSafe(interp) + Tcl_Interp *interp; /* Make this interpreter "safe". */ +{ + if (interp == (Tcl_Interp *) NULL) { + return TCL_ERROR; + } + return MakeSafe(interp); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CreateSlave -- + * + * Creates a slave interpreter. The slavePath argument denotes the + * name of the new slave relative to the current interpreter; the + * slave is a direct descendant of the one-before-last component of + * the path, e.g. it is a descendant of the current interpreter if + * the slavePath argument contains only one component. Optionally makes + * the slave interpreter safe. + * + * Results: + * Returns the interpreter structure created, or NULL if an error + * occurred. + * + * Side effects: + * Creates a new interpreter and a new interpreter object command in + * the interpreter indicated by the slavePath argument. + * + *---------------------------------------------------------------------- + */ + +Tcl_Interp * +Tcl_CreateSlave(interp, slavePath, isSafe) + Tcl_Interp *interp; /* Interpreter to start search at. */ + char *slavePath; /* Name of slave to create. */ + int isSafe; /* Should new slave be "safe" ? */ +{ + if ((interp == (Tcl_Interp *) NULL) || (slavePath == (char *) NULL)) { + return NULL; + } + return CreateSlave(interp, slavePath, isSafe); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetSlave -- + * + * Finds a slave interpreter by its path name. + * + * Results: + * Returns a Tcl_Interp * for the named interpreter or NULL if not + * found. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_Interp * +Tcl_GetSlave(interp, slavePath) + Tcl_Interp *interp; /* Interpreter to start search from. */ + char *slavePath; /* Path of slave to find. */ +{ + Master *masterPtr; /* Interim storage for Master record. */ + + if ((interp == (Tcl_Interp *) NULL) || (slavePath == (char *) NULL)) { + return NULL; + } + masterPtr = (Master *) Tcl_GetAssocData(interp, "tclMasterRecord", NULL); + if (masterPtr == (Master *) NULL) { + panic("Tcl_GetSlave: could not find master record"); + } + return GetInterp(interp, masterPtr, slavePath, NULL); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetMaster -- + * + * Finds the master interpreter of a slave interpreter. + * + * Results: + * Returns a Tcl_Interp * for the master interpreter or NULL if none. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_Interp * +Tcl_GetMaster(interp) + Tcl_Interp *interp; /* Get the master of this interpreter. */ +{ + Slave *slavePtr; /* Slave record of this interpreter. */ + + if (interp == (Tcl_Interp *) NULL) { + return NULL; + } + slavePtr = (Slave *) Tcl_GetAssocData(interp, "tclSlaveRecord", NULL); + if (slavePtr == (Slave *) NULL) { + return NULL; + } + return slavePtr->masterInterp; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CreateAlias -- + * + * Creates an alias between two interpreters. + * + * Results: + * TCL_OK if successful, TCL_ERROR if failed. If TCL_ERROR is returned + * the result of slaveInterp will contain an error message. + * + * Side effects: + * Creates a new alias, manipulates the result field of slaveInterp. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_CreateAlias(slaveInterp, slaveCmd, targetInterp, targetCmd, argc, argv) + Tcl_Interp *slaveInterp; /* Interpreter for source command. */ + char *slaveCmd; /* Command to install in slave. */ + Tcl_Interp *targetInterp; /* Interpreter for target command. */ + char *targetCmd; /* Name of target command. */ + int argc; /* How many additional arguments? */ + char **argv; /* These are the additional args. */ +{ + Master *masterPtr; /* Master record for target interp. */ + + if ((slaveInterp == (Tcl_Interp *) NULL) || + (targetInterp == (Tcl_Interp *) NULL) || + (slaveCmd == (char *) NULL) || + (targetCmd == (char *) NULL)) { + return TCL_ERROR; + } + masterPtr = (Master *) Tcl_GetAssocData(targetInterp, "tclMasterRecord", + NULL); + if (masterPtr == (Master *) NULL) { + panic("Tcl_CreateAlias: could not find master record"); + } + return AliasHelper(slaveInterp, slaveInterp, targetInterp, masterPtr, + slaveCmd, targetCmd, argc, argv); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetAlias -- + * + * Gets information about an alias. + * + * Results: + * TCL_OK if successful, TCL_ERROR else. If TCL_ERROR is returned, the + * result field of the interpreter given as argument will contain an + * error message. + * + * Side effects: + * Manipulates the result field of the interpreter given as argument. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetAlias(interp, aliasName, targetInterpPtr, targetNamePtr, argcPtr, + argvPtr) + Tcl_Interp *interp; /* Interp to start search from. */ + char *aliasName; /* Name of alias to find. */ + Tcl_Interp **targetInterpPtr; /* (Return) target interpreter. */ + char **targetNamePtr; /* (Return) name of target command. */ + int *argcPtr; /* (Return) count of addnl args. */ + char ***argvPtr; /* (Return) additional arguments. */ +{ + Slave *slavePtr; /* Slave record for slave interp. */ + Tcl_HashEntry *hPtr; /* Search element. */ + Alias *aliasPtr; /* Storage for alias found. */ + + if ((interp == (Tcl_Interp *) NULL) || (aliasName == (char *) NULL)) { + return TCL_ERROR; + } + slavePtr = (Slave *) Tcl_GetAssocData(interp, "tclSlaveRecord", NULL); + if (slavePtr == (Slave *) NULL) { + panic("Tcl_GetAlias: could not find slave record"); + } + hPtr = Tcl_FindHashEntry(&(slavePtr->aliasTable), aliasName); + if (hPtr == (Tcl_HashEntry *) NULL) { + Tcl_AppendResult(interp, "alias \"", aliasName, "\" not found", + (char *) NULL); + return TCL_ERROR; + } + aliasPtr = (Alias *) Tcl_GetHashValue(hPtr); + if (targetInterpPtr != (Tcl_Interp **) NULL) { + *targetInterpPtr = aliasPtr->targetInterp; + } + if (targetNamePtr != (char **) NULL) { + *targetNamePtr = aliasPtr->targetName; + } + if (argcPtr != (int *) NULL) { + *argcPtr = aliasPtr->argc; + } + if (argvPtr != (char ***) NULL) { + *argvPtr = aliasPtr->argv; + } + return TCL_OK; +} diff --git a/contrib/tcl/generic/tclLink.c b/contrib/tcl/generic/tclLink.c new file mode 100644 index 0000000000000..1726c5dcb14b7 --- /dev/null +++ b/contrib/tcl/generic/tclLink.c @@ -0,0 +1,390 @@ +/* + * tclLink.c -- + * + * This file implements linked variables (a C variable that is + * tied to a Tcl variable). The idea of linked variables was + * first suggested by Andreas Stolcke and this implementation is + * based heavily on a prototype implementation provided by + * him. + * + * Copyright (c) 1993 The Regents of the University of California. + * Copyright (c) 1994 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclLink.c 1.12 96/02/15 11:50:26 + */ + +#include "tclInt.h" + +/* + * For each linked variable there is a data structure of the following + * type, which describes the link and is the clientData for the trace + * set on the Tcl variable. + */ + +typedef struct Link { + Tcl_Interp *interp; /* Interpreter containing Tcl variable. */ + char *varName; /* Name of variable (must be global). This + * is needed during trace callbacks, since + * the actual variable may be aliased at + * that time via upvar. */ + char *addr; /* Location of C variable. */ + int type; /* Type of link (TCL_LINK_INT, etc.). */ + int writable; /* Zero means Tcl variable is read-only. */ + union { + int i; + double d; + } lastValue; /* Last known value of C variable; used to + * avoid string conversions. */ +} Link; + +/* + * Forward references to procedures defined later in this file: + */ + +static char * LinkTraceProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, char *name1, char *name2, + int flags)); +static char * StringValue _ANSI_ARGS_((Link *linkPtr, + char *buffer)); + +/* + *---------------------------------------------------------------------- + * + * Tcl_LinkVar -- + * + * Link a C variable to a Tcl variable so that changes to either + * one causes the other to change. + * + * Results: + * The return value is TCL_OK if everything went well or TCL_ERROR + * if an error occurred (interp->result is also set after errors). + * + * Side effects: + * The value at *addr is linked to the Tcl variable "varName", + * using "type" to convert between string values for Tcl and + * binary values for *addr. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_LinkVar(interp, varName, addr, type) + Tcl_Interp *interp; /* Interpreter in which varName exists. */ + char *varName; /* Name of a global variable in interp. */ + char *addr; /* Address of a C variable to be linked + * to varName. */ + int type; /* Type of C variable: TCL_LINK_INT, etc. + * Also may have TCL_LINK_READ_ONLY + * OR'ed in. */ +{ + Link *linkPtr; + char buffer[TCL_DOUBLE_SPACE]; + int code; + + linkPtr = (Link *) ckalloc(sizeof(Link)); + linkPtr->interp = interp; + linkPtr->varName = (char *) ckalloc((unsigned) (strlen(varName) + 1)); + strcpy(linkPtr->varName, varName); + linkPtr->addr = addr; + linkPtr->type = type & ~TCL_LINK_READ_ONLY; + linkPtr->writable = (type & TCL_LINK_READ_ONLY) == 0; + if (Tcl_SetVar(interp, varName, StringValue(linkPtr, buffer), + TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) { + ckfree(linkPtr->varName); + ckfree((char *) linkPtr); + return TCL_ERROR; + } + code = Tcl_TraceVar(interp, varName, TCL_GLOBAL_ONLY|TCL_TRACE_READS + |TCL_TRACE_WRITES|TCL_TRACE_UNSETS, LinkTraceProc, + (ClientData) linkPtr); + if (code != TCL_OK) { + ckfree(linkPtr->varName); + ckfree((char *) linkPtr); + } + return code; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_UnlinkVar -- + * + * Destroy the link between a Tcl variable and a C variable. + * + * Results: + * None. + * + * Side effects: + * If "varName" was previously linked to a C variable, the link + * is broken to make the variable independent. If there was no + * previous link for "varName" then nothing happens. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_UnlinkVar(interp, varName) + Tcl_Interp *interp; /* Interpreter containing variable to unlink. */ + char *varName; /* Global variable in interp to unlink. */ +{ + Link *linkPtr; + + linkPtr = (Link *) Tcl_VarTraceInfo(interp, varName, TCL_GLOBAL_ONLY, + LinkTraceProc, (ClientData) NULL); + if (linkPtr == NULL) { + return; + } + Tcl_UntraceVar(interp, varName, + TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + LinkTraceProc, (ClientData) linkPtr); + ckfree(linkPtr->varName); + ckfree((char *) linkPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_UpdateLinkedVar -- + * + * This procedure is invoked after a linked variable has been + * changed by C code. It updates the Tcl variable so that + * traces on the variable will trigger. + * + * Results: + * None. + * + * Side effects: + * The Tcl variable "varName" is updated from its C value, + * causing traces on the variable to trigger. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_UpdateLinkedVar(interp, varName) + Tcl_Interp *interp; /* Interpreter containing variable. */ + char *varName; /* Name of global variable that is linked. */ +{ + Link *linkPtr; + char buffer[TCL_DOUBLE_SPACE]; + + linkPtr = (Link *) Tcl_VarTraceInfo(interp, varName, TCL_GLOBAL_ONLY, + LinkTraceProc, (ClientData) NULL); + if (linkPtr == NULL) { + return; + } + Tcl_SetVar(interp, linkPtr->varName, StringValue(linkPtr, buffer), + TCL_GLOBAL_ONLY); +} + +/* + *---------------------------------------------------------------------- + * + * LinkTraceProc -- + * + * This procedure is invoked when a linked Tcl variable is read, + * written, or unset from Tcl. It's responsible for keeping the + * C variable in sync with the Tcl variable. + * + * Results: + * If all goes well, NULL is returned; otherwise an error message + * is returned. + * + * Side effects: + * The C variable may be updated to make it consistent with the + * Tcl variable, or the Tcl variable may be overwritten to reject + * a modification. + * + *---------------------------------------------------------------------- + */ + +static char * +LinkTraceProc(clientData, interp, name1, name2, flags) + ClientData clientData; /* Contains information about the link. */ + Tcl_Interp *interp; /* Interpreter containing Tcl variable. */ + char *name1; /* First part of variable name. */ + char *name2; /* Second part of variable name. */ + int flags; /* Miscellaneous additional information. */ +{ + Link *linkPtr = (Link *) clientData; + int changed; + char buffer[TCL_DOUBLE_SPACE]; + char *value, **pp; + Tcl_DString savedResult; + + /* + * If the variable is being unset, then just re-create it (with a + * trace) unless the whole interpreter is going away. + */ + + if (flags & TCL_TRACE_UNSETS) { + if (flags & TCL_INTERP_DESTROYED) { + ckfree(linkPtr->varName); + ckfree((char *) linkPtr); + } else if (flags & TCL_TRACE_DESTROYED) { + Tcl_SetVar(interp, linkPtr->varName, StringValue(linkPtr, buffer), + TCL_GLOBAL_ONLY); + Tcl_TraceVar(interp, linkPtr->varName, TCL_GLOBAL_ONLY + |TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + LinkTraceProc, (ClientData) linkPtr); + } + return NULL; + } + + /* + * For read accesses, update the Tcl variable if the C variable + * has changed since the last time we updated the Tcl variable. + */ + + if (flags & TCL_TRACE_READS) { + switch (linkPtr->type) { + case TCL_LINK_INT: + case TCL_LINK_BOOLEAN: + changed = *(int *)(linkPtr->addr) != linkPtr->lastValue.i; + break; + case TCL_LINK_DOUBLE: + changed = *(double *)(linkPtr->addr) != linkPtr->lastValue.d; + break; + case TCL_LINK_STRING: + changed = 1; + break; + default: + return "internal error: bad linked variable type"; + } + if (changed) { + Tcl_SetVar(interp, linkPtr->varName, StringValue(linkPtr, buffer), + TCL_GLOBAL_ONLY); + } + return NULL; + } + + /* + * For writes, first make sure that the variable is writable. Then + * convert the Tcl value to C if possible. If the variable isn't + * writable or can't be converted, then restore the varaible's old + * value and return an error. Another tricky thing: we have to save + * and restore the interpreter's result, since the variable access + * could occur when the result has been partially set. + */ + + if (!linkPtr->writable) { + Tcl_SetVar(interp, linkPtr->varName, StringValue(linkPtr, buffer), + TCL_GLOBAL_ONLY); + return "linked variable is read-only"; + } + value = Tcl_GetVar(interp, linkPtr->varName, TCL_GLOBAL_ONLY); + if (value == NULL) { + /* + * This shouldn't ever happen. + */ + return "internal error: linked variable couldn't be read"; + } + Tcl_DStringInit(&savedResult); + Tcl_DStringAppend(&savedResult, interp->result, -1); + Tcl_ResetResult(interp); + switch (linkPtr->type) { + case TCL_LINK_INT: + if (Tcl_GetInt(interp, value, &linkPtr->lastValue.i) != TCL_OK) { + Tcl_DStringResult(interp, &savedResult); + Tcl_SetVar(interp, linkPtr->varName, + StringValue(linkPtr, buffer), TCL_GLOBAL_ONLY); + return "variable must have integer value"; + } + *(int *)(linkPtr->addr) = linkPtr->lastValue.i; + break; + case TCL_LINK_DOUBLE: + if (Tcl_GetDouble(interp, value, &linkPtr->lastValue.d) + != TCL_OK) { + Tcl_DStringResult(interp, &savedResult); + Tcl_SetVar(interp, linkPtr->varName, + StringValue(linkPtr, buffer), TCL_GLOBAL_ONLY); + return "variable must have real value"; + } + *(double *)(linkPtr->addr) = linkPtr->lastValue.d; + break; + case TCL_LINK_BOOLEAN: + if (Tcl_GetBoolean(interp, value, &linkPtr->lastValue.i) + != TCL_OK) { + Tcl_DStringResult(interp, &savedResult); + Tcl_SetVar(interp, linkPtr->varName, + StringValue(linkPtr, buffer), TCL_GLOBAL_ONLY); + return "variable must have boolean value"; + } + *(int *)(linkPtr->addr) = linkPtr->lastValue.i; + break; + case TCL_LINK_STRING: + pp = (char **)(linkPtr->addr); + if (*pp != NULL) { + ckfree(*pp); + } + *pp = (char *) ckalloc((unsigned) (strlen(value) + 1)); + strcpy(*pp, value); + break; + default: + return "internal error: bad linked variable type"; + } + Tcl_DStringResult(interp, &savedResult); + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * StringValue -- + * + * Converts the value of a C variable to a string for use in a + * Tcl variable to which it is linked. + * + * Results: + * The return value is a pointer + to a string that represents + * the value of the C variable given by linkPtr. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static char * +StringValue(linkPtr, buffer) + Link *linkPtr; /* Structure describing linked variable. */ + char *buffer; /* Small buffer to use for converting + * values. Must have TCL_DOUBLE_SPACE + * bytes or more. */ +{ + char *p; + + switch (linkPtr->type) { + case TCL_LINK_INT: + linkPtr->lastValue.i = *(int *)(linkPtr->addr); + sprintf(buffer, "%d", linkPtr->lastValue.i); + return buffer; + case TCL_LINK_DOUBLE: + linkPtr->lastValue.d = *(double *)(linkPtr->addr); + Tcl_PrintDouble(linkPtr->interp, linkPtr->lastValue.d, buffer); + return buffer; + case TCL_LINK_BOOLEAN: + linkPtr->lastValue.i = *(int *)(linkPtr->addr); + if (linkPtr->lastValue.i != 0) { + return "1"; + } + return "0"; + case TCL_LINK_STRING: + p = *(char **)(linkPtr->addr); + if (p == NULL) { + return "NULL"; + } + return p; + } + + /* + * This code only gets executed if the link type is unknown + * (shouldn't ever happen). + */ + + return "??"; +} diff --git a/contrib/tcl/generic/tclLoad.c b/contrib/tcl/generic/tclLoad.c new file mode 100644 index 0000000000000..f14856bae5ab7 --- /dev/null +++ b/contrib/tcl/generic/tclLoad.c @@ -0,0 +1,600 @@ +/* + * tclLoad.c -- + * + * This file provides the generic portion (those that are the same + * on all platforms) of Tcl's dynamic loading facilities. + * + * 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: @(#) tclLoad.c 1.10 96/04/02 18:44:22 + */ + +#include "tclInt.h" + +/* + * The following structure describes a package that has been loaded + * either dynamically (with the "load" command) or statically (as + * indicated by a call to Tcl_PackageLoaded). All such packages + * are linked together into a single list for the process. Packages + * are never unloaded, so these structures are never freed. + */ + +typedef struct LoadedPackage { + char *fileName; /* Name of the file from which the + * package was loaded. An empty string + * means the package is loaded statically. + * Malloc-ed. */ + char *packageName; /* Name of package prefix for the package, + * properly capitalized (first letter UC, + * others LC), no "_", as in "Net". + * Malloc-ed. */ + Tcl_PackageInitProc *initProc; + /* Initialization procedure to call to + * incorporate this package into a trusted + * interpreter. */ + Tcl_PackageInitProc *safeInitProc; + /* Initialization procedure to call to + * incorporate this package into a safe + * interpreter (one that will execute + * untrusted scripts). NULL means the + * package can't be used in unsafe + * interpreters. */ + struct LoadedPackage *nextPtr; + /* Next in list of all packages loaded into + * this application process. NULL means + * end of list. */ +} LoadedPackage; + +static LoadedPackage *firstPackagePtr = NULL; + /* First in list of all packages loaded into + * this process. */ + +/* + * The following structure represents a particular package that has + * been incorporated into a particular interpreter (by calling its + * initialization procedure). There is a list of these structures for + * each interpreter, with an AssocData value (key "load") for the + * interpreter that points to the first package (if any). + */ + +typedef struct InterpPackage { + LoadedPackage *pkgPtr; /* Points to detailed information about + * package. */ + struct InterpPackage *nextPtr; + /* Next package in this interpreter, or + * NULL for end of list. */ +} InterpPackage; + +/* + * Prototypes for procedures that are private to this file: + */ + +static void LoadCleanupProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp)); +static void LoadExitProc _ANSI_ARGS_((ClientData clientData)); + +/* + *---------------------------------------------------------------------- + * + * Tcl_LoadCmd -- + * + * This procedure is invoked to process the "load" 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_LoadCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tcl_Interp *target; + LoadedPackage *pkgPtr; + Tcl_DString pkgName, initName, safeInitName, fileName; + Tcl_PackageInitProc *initProc, *safeInitProc; + InterpPackage *ipFirstPtr, *ipPtr; + int code, c, gotPkgName; + char *p, *fullFileName; + + if ((argc < 2) || (argc > 4)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " fileName ?packageName? ?interp?\"", (char *) NULL); + return TCL_ERROR; + } + fullFileName = Tcl_TranslateFileName(interp, argv[1], &fileName); + if (fullFileName == NULL) { + return TCL_ERROR; + } + Tcl_DStringInit(&pkgName); + Tcl_DStringInit(&initName); + Tcl_DStringInit(&safeInitName); + if ((argc >= 3) && (argv[2][0] != 0)) { + gotPkgName = 1; + } else { + gotPkgName = 0; + } + if ((fullFileName[0] == 0) && !gotPkgName) { + interp->result = "must specify either file name or package name"; + code = TCL_ERROR; + goto done; + } + + /* + * Figure out which interpreter we're going to load the package into. + */ + + target = interp; + if (argc == 4) { + target = Tcl_GetSlave(interp, argv[3]); + if (target == NULL) { + Tcl_AppendResult(interp, "couldn't find slave interpreter named \"", + argv[3], "\"", (char *) NULL); + return TCL_ERROR; + } + } + + /* + * See if the desired file is already loaded. If so, its package + * name must agree with ours (if we have one). + */ + + for (pkgPtr = firstPackagePtr; pkgPtr != NULL; pkgPtr = pkgPtr->nextPtr) { + if (strcmp(pkgPtr->fileName, fullFileName) != 0) { + continue; + } + if (gotPkgName) { + char *p1, *p2; + for (p1 = argv[2], p2 = pkgPtr->packageName; ; p1++, p2++) { + if ((isupper(*p1) ? tolower(*p1) : *p1) + != (isupper(*p2) ? tolower(*p2) : *p2)) { + if (fullFileName[0] == 0) { + /* + * We're looking for a statically loaded package; + * the file name is basically irrelevant here, so + * don't get upset that there's some other package + * with the same (empty string) file name. Just + * skip this package and go on to the next. + */ + + goto nextPackage; + } + Tcl_AppendResult(interp, "file \"", fullFileName, + "\" is already loaded for package \"", + pkgPtr->packageName, "\"", (char *) NULL); + code = TCL_ERROR; + goto done; + } + if (*p1 == 0) { + goto gotPkg; + } + } + nextPackage: + continue; + } + break; + } + gotPkg: + + /* + * If the file is already loaded in the target interpreter then + * there's nothing for us to do. + */ + + ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(target, "tclLoad", + (Tcl_InterpDeleteProc **) NULL); + if (pkgPtr != NULL) { + for (ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { + if (ipPtr->pkgPtr == pkgPtr) { + code = TCL_OK; + goto done; + } + } + } + + if (pkgPtr == NULL) { + /* + * The desired file isn't currently loaded, so load it. It's an + * error if the desired package is a static one. + */ + + if (fullFileName[0] == 0) { + Tcl_AppendResult(interp, "package \"", argv[2], + "\" isn't loaded statically", (char *) NULL); + code = TCL_ERROR; + goto done; + } + + /* + * Figure out the module name if it wasn't provided explicitly. + */ + + if (gotPkgName) { + Tcl_DStringAppend(&pkgName, argv[2], -1); + } else { + if (!TclGuessPackageName(fullFileName, &pkgName)) { + int pargc; + char **pargv, *pkgGuess; + + /* + * The platform-specific code couldn't figure out the + * module name. Make a guess by taking the last element + * of the file name, stripping off any leading "lib", and + * then using all of the alphabetic characters that follow + * that. + */ + + Tcl_SplitPath(fullFileName, &pargc, &pargv); + pkgGuess = pargv[pargc-1]; + if ((pkgGuess[0] == 'l') && (pkgGuess[1] == 'i') + && (pkgGuess[2] == 'b')) { + pkgGuess += 3; + } + for (p = pkgGuess; isalpha(*p); p++) { + /* Empty loop body. */ + } + if (p == pkgGuess) { + ckfree((char *)pargv); + Tcl_AppendResult(interp, + "couldn't figure out package name for ", + fullFileName, (char *) NULL); + code = TCL_ERROR; + goto done; + } + Tcl_DStringAppend(&pkgName, pkgGuess, (p - pkgGuess)); + ckfree((char *)pargv); + } + } + + /* + * Fix the capitalization in the package name so that the first + * character is in caps but the others are all lower-case. + */ + + p = Tcl_DStringValue(&pkgName); + c = UCHAR(*p); + if (c != 0) { + if (islower(c)) { + *p = (char) toupper(c); + } + p++; + while (1) { + c = UCHAR(*p); + if (c == 0) { + break; + } + if (isupper(c)) { + *p = (char) tolower(c); + } + p++; + } + } + + /* + * Compute the names of the two initialization procedures, + * based on the package name. + */ + + Tcl_DStringAppend(&initName, Tcl_DStringValue(&pkgName), -1); + Tcl_DStringAppend(&initName, "_Init", 5); + Tcl_DStringAppend(&safeInitName, Tcl_DStringValue(&pkgName), -1); + Tcl_DStringAppend(&safeInitName, "_SafeInit", 9); + + /* + * Call platform-specific code to load the package and find the + * two initialization procedures. + */ + + code = TclLoadFile(interp, fullFileName, Tcl_DStringValue(&initName), + Tcl_DStringValue(&safeInitName), &initProc, &safeInitProc); + if (code != TCL_OK) { + goto done; + } + if (initProc == NULL) { + Tcl_AppendResult(interp, "couldn't find procedure ", + Tcl_DStringValue(&initName), (char *) NULL); + code = TCL_ERROR; + goto done; + } + + /* + * Create a new record to describe this package. + */ + + if (firstPackagePtr == NULL) { + Tcl_CreateExitHandler(LoadExitProc, (ClientData) NULL); + } + pkgPtr = (LoadedPackage *) ckalloc(sizeof(LoadedPackage)); + pkgPtr->fileName = (char *) ckalloc((unsigned) + (strlen(fullFileName) + 1)); + strcpy(pkgPtr->fileName, fullFileName); + pkgPtr->packageName = (char *) ckalloc((unsigned) + (Tcl_DStringLength(&pkgName) + 1)); + strcpy(pkgPtr->packageName, Tcl_DStringValue(&pkgName)); + pkgPtr->initProc = initProc; + pkgPtr->safeInitProc = safeInitProc; + pkgPtr->nextPtr = firstPackagePtr; + firstPackagePtr = pkgPtr; + } + + /* + * Invoke the package's initialization procedure (either the + * normal one or the safe one, depending on whether or not the + * interpreter is safe). + */ + + if (Tcl_IsSafe(target)) { + if (pkgPtr->safeInitProc != NULL) { + code = (*pkgPtr->safeInitProc)(target); + } else { + Tcl_AppendResult(interp, + "can't use package in a safe interpreter: ", + "no ", pkgPtr->packageName, "_SafeInit procedure", + (char *) NULL); + code = TCL_ERROR; + goto done; + } + } else { + code = (*pkgPtr->initProc)(target); + } + if ((code == TCL_ERROR) && (target != interp)) { + /* + * An error occurred, so transfer error information from the + * destination interpreter back to our interpreter. Must clear + * interp's result before calling Tcl_AddErrorInfo, since + * Tcl_AddErrorInfo will store the interp's result in errorInfo + * before appending target's $errorInfo; we've already got + * everything we need in target's $errorInfo. + */ + + Tcl_ResetResult(interp); + Tcl_AddErrorInfo(interp, Tcl_GetVar2(target, + "errorInfo", (char *) NULL, TCL_GLOBAL_ONLY)); + Tcl_SetVar2(interp, "errorCode", (char *) NULL, + Tcl_GetVar2(target, "errorCode", (char *) NULL, + TCL_GLOBAL_ONLY), TCL_GLOBAL_ONLY); + Tcl_SetResult(interp, target->result, TCL_VOLATILE); + } + + /* + * Record the fact that the package has been loaded in the + * target interpreter. + */ + + if (code == TCL_OK) { + ipPtr = (InterpPackage *) ckalloc(sizeof(InterpPackage)); + ipPtr->pkgPtr = pkgPtr; + ipPtr->nextPtr = ipFirstPtr; + Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc, + (ClientData) ipPtr); + } + + done: + Tcl_DStringFree(&pkgName); + Tcl_DStringFree(&initName); + Tcl_DStringFree(&safeInitName); + Tcl_DStringFree(&fileName); + return code; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_StaticPackage -- + * + * This procedure is invoked to indicate that a particular + * package has been linked statically with an application. + * + * Results: + * None. + * + * Side effects: + * Once this procedure completes, the package becomes loadable + * via the "load" command with an empty file name. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_StaticPackage(interp, pkgName, initProc, safeInitProc) + Tcl_Interp *interp; /* If not NULL, it means that the + * package has already been loaded + * into the given interpreter by + * calling the appropriate init proc. */ + char *pkgName; /* Name of package (must be properly + * capitalized: first letter upper + * case, others lower case). */ + Tcl_PackageInitProc *initProc; /* Procedure to call to incorporate + * this package into a trusted + * interpreter. */ + Tcl_PackageInitProc *safeInitProc; /* Procedure to call to incorporate + * this package into a safe interpreter + * (one that will execute untrusted + * scripts). NULL means the package + * can't be used in safe + * interpreters. */ +{ + LoadedPackage *pkgPtr; + InterpPackage *ipPtr, *ipFirstPtr; + + if (firstPackagePtr == NULL) { + Tcl_CreateExitHandler(LoadExitProc, (ClientData) NULL); + } + pkgPtr = (LoadedPackage *) ckalloc(sizeof(LoadedPackage)); + pkgPtr->fileName = (char *) ckalloc((unsigned) 1); + pkgPtr->fileName[0] = 0; + pkgPtr->packageName = (char *) ckalloc((unsigned) + (strlen(pkgName) + 1)); + strcpy(pkgPtr->packageName, pkgName); + pkgPtr->initProc = initProc; + pkgPtr->safeInitProc = safeInitProc; + pkgPtr->nextPtr = firstPackagePtr; + firstPackagePtr = pkgPtr; + + if (interp != NULL) { + ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(interp, "tclLoad", + (Tcl_InterpDeleteProc **) NULL); + ipPtr = (InterpPackage *) ckalloc(sizeof(InterpPackage)); + ipPtr->pkgPtr = pkgPtr; + ipPtr->nextPtr = ipFirstPtr; + Tcl_SetAssocData(interp, "tclLoad", LoadCleanupProc, + (ClientData) ipPtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * TclGetLoadedPackages -- + * + * This procedure returns information about all of the files + * that are loaded (either in a particular intepreter, or + * for all interpreters). + * + * Results: + * The return value is a standard Tcl completion code. If + * successful, a list of lists is placed in interp->result. + * Each sublist corresponds to one loaded file; its first + * element is the name of the file (or an empty string for + * something that's statically loaded) and the second element + * is the name of the package in that file. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclGetLoadedPackages(interp, targetName) + Tcl_Interp *interp; /* Interpreter in which to return + * information or error message. */ + char *targetName; /* Name of target interpreter or NULL. + * If NULL, return info about all interps; + * otherwise, just return info about this + * interpreter. */ +{ + Tcl_Interp *target; + LoadedPackage *pkgPtr; + InterpPackage *ipPtr; + char *prefix; + + if (targetName == NULL) { + /* + * Return information about all of the available packages. + */ + + prefix = "{"; + for (pkgPtr = firstPackagePtr; pkgPtr != NULL; + pkgPtr = pkgPtr->nextPtr) { + Tcl_AppendResult(interp, prefix, (char *) NULL); + Tcl_AppendElement(interp, pkgPtr->fileName); + Tcl_AppendElement(interp, pkgPtr->packageName); + Tcl_AppendResult(interp, "}", (char *) NULL); + prefix = " {"; + } + return TCL_OK; + } + + /* + * Return information about only the packages that are loaded in + * a given interpreter. + */ + + target = Tcl_GetSlave(interp, targetName); + if (target == NULL) { + Tcl_AppendResult(interp, "couldn't find slave interpreter named \"", + targetName, "\"", (char *) NULL); + return TCL_ERROR; + } + ipPtr = (InterpPackage *) Tcl_GetAssocData(target, "tclLoad", + (Tcl_InterpDeleteProc **) NULL); + prefix = "{"; + for ( ; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { + pkgPtr = ipPtr->pkgPtr; + Tcl_AppendResult(interp, prefix, (char *) NULL); + Tcl_AppendElement(interp, pkgPtr->fileName); + Tcl_AppendElement(interp, pkgPtr->packageName); + Tcl_AppendResult(interp, "}", (char *) NULL); + prefix = " {"; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * LoadCleanupProc -- + * + * This procedure is called to delete all of the InterpPackage + * structures for an interpreter when the interpreter is deleted. + * It gets invoked via the Tcl AssocData mechanism. + * + * Results: + * None. + * + * Side effects: + * Storage for all of the InterpPackage procedures for interp + * get deleted. + * + *---------------------------------------------------------------------- + */ + +static void +LoadCleanupProc(clientData, interp) + ClientData clientData; /* Pointer to first InterpPackage structure + * for interp. */ + Tcl_Interp *interp; /* Interpreter that is being deleted. */ +{ + InterpPackage *ipPtr, *nextPtr; + + ipPtr = (InterpPackage *) clientData; + while (ipPtr != NULL) { + nextPtr = ipPtr->nextPtr; + ckfree((char *) ipPtr); + ipPtr = nextPtr; + } +} + +/* + *---------------------------------------------------------------------- + * + * LoadExitProc -- + * + * This procedure is invoked just before the application exits. + * It frees all of the LoadedPackage structures. + * + * Results: + * None. + * + * Side effects: + * Memory is freed. + * + *---------------------------------------------------------------------- + */ + +static void +LoadExitProc(clientData) + ClientData clientData; /* Not used. */ +{ + LoadedPackage *pkgPtr; + + while (firstPackagePtr != NULL) { + pkgPtr = firstPackagePtr; + firstPackagePtr = pkgPtr->nextPtr; + ckfree(pkgPtr->fileName); + ckfree(pkgPtr->packageName); + ckfree((char *) pkgPtr); + } +} diff --git a/contrib/tcl/generic/tclLoadNone.c b/contrib/tcl/generic/tclLoadNone.c new file mode 100644 index 0000000000000..87b56e062a00c --- /dev/null +++ b/contrib/tcl/generic/tclLoadNone.c @@ -0,0 +1,81 @@ +/* + * tclLoadNone.c -- + * + * This procedure provides a version of the TclLoadFile for use + * in systems that don't support dynamic loading; it just returns + * an error. + * + * 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: @(#) tclLoadNone.c 1.5 96/02/15 11:43:01 + */ + +#include "tclInt.h" + +/* + *---------------------------------------------------------------------- + * + * TclLoadFile -- + * + * This procedure is called to carry out dynamic loading of binary + * code; it is intended for use only on systems that don't support + * dynamic loading (it returns an error). + * + * Results: + * The result is TCL_ERROR, and an error message is left in + * interp->result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr) + Tcl_Interp *interp; /* Used for error reporting. */ + char *fileName; /* Name of the file containing the desired + * code. */ + char *sym1, *sym2; /* Names of two procedures to look up in + * the file's symbol table. */ + Tcl_PackageInitProc **proc1Ptr, **proc2Ptr; + /* Where to return the addresses corresponding + * to sym1 and sym2. */ +{ + interp->result = + "dynamic loading is not currently available on this system"; + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * TclGuessPackageName -- + * + * If the "load" command is invoked without providing a package + * name, this procedure is invoked to try to figure it out. + * + * Results: + * Always returns 0 to indicate that we couldn't figure out a + * package name; generic code will then try to guess the package + * from the file name. A return value of 1 would have meant that + * we figured out the package name and put it in bufPtr. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclGuessPackageName(fileName, bufPtr) + char *fileName; /* Name of file containing package (already + * translated to local form if needed). */ + Tcl_DString *bufPtr; /* Initialized empty dstring. Append + * package name to this if possible. */ +{ + return 0; +} diff --git a/contrib/tcl/generic/tclMain.c b/contrib/tcl/generic/tclMain.c new file mode 100644 index 0000000000000..d7b029db7ce12 --- /dev/null +++ b/contrib/tcl/generic/tclMain.c @@ -0,0 +1,347 @@ +/* + * tclMain.c -- + * + * Main program for Tcl shells and other Tcl-based applications. + * + * Copyright (c) 1988-1994 The Regents of the University of California. + * Copyright (c) 1994-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: @(#) tclMain.c 1.50 96/04/10 16:40:57 + */ + +#include "tcl.h" +#include "tclInt.h" + +/* + * The following code ensures that tclLink.c is linked whenever + * Tcl is linked. Without this code there's no reference to the + * code in that file from anywhere in Tcl, so it may not be + * linked into the application. + */ + +EXTERN int Tcl_LinkVar(); +int (*tclDummyLinkVarPtr)() = Tcl_LinkVar; + +/* + * Declarations for various library procedures and variables (don't want + * to include tclPort.h here, because people might copy this file out of + * the Tcl source directory to make their own modified versions). + * Note: "exit" should really be declared here, but there's no way to + * declare it without causing conflicts with other definitions elsewher + * on some systems, so it's better just to leave it out. + */ + +extern int isatty _ANSI_ARGS_((int fd)); +extern char * strcpy _ANSI_ARGS_((char *dst, CONST char *src)); + +static Tcl_Interp *interp; /* Interpreter for application. */ +static Tcl_DString command; /* Used to buffer incomplete commands being + * read from stdin. */ +#ifdef TCL_MEM_DEBUG +static char dumpFile[100]; /* Records where to dump memory allocation + * information. */ +static int quitFlag = 0; /* 1 means the "checkmem" command was + * invoked, so the application should quit + * and dump memory allocation information. */ +#endif + +/* + * Forward references for procedures defined later in this file: + */ + +#ifdef TCL_MEM_DEBUG +static int CheckmemCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char *argv[])); +#endif + +/* + *---------------------------------------------------------------------- + * + * Tcl_Main -- + * + * Main program for tclsh and most other Tcl-based applications. + * + * Results: + * None. This procedure never returns (it exits the process when + * it's done. + * + * Side effects: + * This procedure initializes the Tk world and then starts + * interpreting commands; almost anything could happen, depending + * on the script being interpreted. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_Main(argc, argv, appInitProc) + int argc; /* Number of arguments. */ + char **argv; /* Array of argument strings. */ + Tcl_AppInitProc *appInitProc; /* Application-specific initialization + * procedure to call after most + * initialization but before starting + * to execute commands. */ +{ + char buffer[1000], *cmd, *args, *fileName; + int code, gotPartial, tty, length; + int exitCode = 0; + Tcl_Channel inChannel, outChannel, errChannel; + Tcl_DString temp; + + Tcl_FindExecutable(argv[0]); + interp = Tcl_CreateInterp(); +#ifdef TCL_MEM_DEBUG + Tcl_InitMemory(interp); + Tcl_CreateCommand(interp, "checkmem", CheckmemCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); +#endif + + /* + * Make command-line arguments available in the Tcl variables "argc" + * and "argv". If the first argument doesn't start with a "-" then + * strip it off and use it as the name of a script file to process. + */ + + fileName = NULL; + if ((argc > 1) && (argv[1][0] != '-')) { + fileName = argv[1]; + argc--; + argv++; + } + args = Tcl_Merge(argc-1, argv+1); + Tcl_SetVar(interp, "argv", args, TCL_GLOBAL_ONLY); + ckfree(args); + sprintf(buffer, "%d", argc-1); + Tcl_SetVar(interp, "argc", buffer, TCL_GLOBAL_ONLY); + Tcl_SetVar(interp, "argv0", (fileName != NULL) ? fileName : argv[0], + TCL_GLOBAL_ONLY); + + /* + * Set the "tcl_interactive" variable. + */ + + tty = isatty(0); + Tcl_SetVar(interp, "tcl_interactive", + ((fileName == NULL) && tty) ? "1" : "0", TCL_GLOBAL_ONLY); + + /* + * Invoke application-specific initialization. + */ + + if ((*appInitProc)(interp) != TCL_OK) { + errChannel = Tcl_GetStdChannel(TCL_STDERR); + if (errChannel) { + Tcl_Write(errChannel, + "application-specific initialization failed: ", -1); + Tcl_Write(errChannel, interp->result, -1); + Tcl_Write(errChannel, "\n", 1); + } + } + + /* + * If a script file was specified then just source that file + * and quit. + */ + + if (fileName != NULL) { + code = Tcl_EvalFile(interp, fileName); + if (code != TCL_OK) { + errChannel = Tcl_GetStdChannel(TCL_STDERR); + if (errChannel) { + /* + * The following statement guarantees that the errorInfo + * variable is set properly. + */ + + Tcl_AddErrorInfo(interp, ""); + Tcl_Write(errChannel, + Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY), -1); + Tcl_Write(errChannel, "\n", 1); + } + exitCode = 1; + } + goto done; + } + + /* + * We're running interactively. Source a user-specific startup + * file if the application specified one and if the file exists. + */ + + fileName = Tcl_GetVar(interp, "tcl_rcFileName", TCL_GLOBAL_ONLY); + + if (fileName != NULL) { + Tcl_Channel c; + char *fullName; + + Tcl_DStringInit(&temp); + fullName = Tcl_TranslateFileName(interp, fileName, &temp); + if (fullName == NULL) { + errChannel = Tcl_GetStdChannel(TCL_STDERR); + if (errChannel) { + Tcl_Write(errChannel, interp->result, -1); + Tcl_Write(errChannel, "\n", 1); + } + } else { + + /* + * Test for the existence of the rc file before trying to read it. + */ + + c = Tcl_OpenFileChannel(NULL, fullName, "r", 0); + if (c != (Tcl_Channel) NULL) { + Tcl_Close(NULL, c); + if (Tcl_EvalFile(interp, fullName) != TCL_OK) { + errChannel = Tcl_GetStdChannel(TCL_STDERR); + if (errChannel) { + Tcl_Write(errChannel, interp->result, -1); + Tcl_Write(errChannel, "\n", 1); + } + } + } + } + Tcl_DStringFree(&temp); + } + + /* + * Process commands from stdin until there's an end-of-file. Note + * that we need to fetch the standard channels again after every + * eval, since they may have been changed. + */ + + gotPartial = 0; + Tcl_DStringInit(&command); + inChannel = Tcl_GetStdChannel(TCL_STDIN); + outChannel = Tcl_GetStdChannel(TCL_STDOUT); + while (1) { + if (tty) { + char *promptCmd; + + promptCmd = Tcl_GetVar(interp, + gotPartial ? "tcl_prompt2" : "tcl_prompt1", TCL_GLOBAL_ONLY); + if (promptCmd == NULL) { +defaultPrompt: + if (!gotPartial && outChannel) { + Tcl_Write(outChannel, "% ", 2); + } + } else { + code = Tcl_Eval(interp, promptCmd); + inChannel = Tcl_GetStdChannel(TCL_STDIN); + outChannel = Tcl_GetStdChannel(TCL_STDOUT); + errChannel = Tcl_GetStdChannel(TCL_STDERR); + if (code != TCL_OK) { + if (errChannel) { + Tcl_Write(errChannel, interp->result, -1); + Tcl_Write(errChannel, "\n", 1); + } + Tcl_AddErrorInfo(interp, + "\n (script that generates prompt)"); + goto defaultPrompt; + } + } + if (outChannel) { + Tcl_Flush(outChannel); + } + } + if (!inChannel) { + goto done; + } + length = Tcl_Gets(inChannel, &command); + if (length < 0) { + goto done; + } + if ((length == 0) && Tcl_Eof(inChannel) && (!gotPartial)) { + goto done; + } + + /* + * Add the newline removed by Tcl_Gets back to the string. + */ + + (void) Tcl_DStringAppend(&command, "\n", -1); + + cmd = Tcl_DStringValue(&command); + if (!Tcl_CommandComplete(cmd)) { + gotPartial = 1; + continue; + } + + gotPartial = 0; + code = Tcl_RecordAndEval(interp, cmd, 0); + inChannel = Tcl_GetStdChannel(TCL_STDIN); + outChannel = Tcl_GetStdChannel(TCL_STDOUT); + errChannel = Tcl_GetStdChannel(TCL_STDERR); + Tcl_DStringFree(&command); + if (code != TCL_OK) { + if (errChannel) { + Tcl_Write(errChannel, interp->result, -1); + Tcl_Write(errChannel, "\n", 1); + } + } else if (tty && (*interp->result != 0)) { + if (outChannel) { + Tcl_Write(outChannel, interp->result, -1); + Tcl_Write(outChannel, "\n", 1); + } + } +#ifdef TCL_MEM_DEBUG + if (quitFlag) { + Tcl_DeleteInterp(interp); + Tcl_Exit(0); + } +#endif + } + + /* + * Rather than calling exit, invoke the "exit" command so that + * users can replace "exit" with some other command to do additional + * cleanup on exit. The Tcl_Eval call should never return. + */ + +done: + sprintf(buffer, "exit %d", exitCode); + Tcl_Eval(interp, buffer); +} + +/* + *---------------------------------------------------------------------- + * + * CheckmemCmd -- + * + * This is the command procedure for the "checkmem" command, which + * causes the application to exit after printing information about + * memory usage to the file passed to this command as its first + * argument. + * + * Results: + * Returns a standard Tcl completion code. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ +#ifdef TCL_MEM_DEBUG + + /* ARGSUSED */ +static int +CheckmemCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Interpreter for evaluation. */ + int argc; /* Number of arguments. */ + char *argv[]; /* String values of arguments. */ +{ + extern char *tclMemDumpFileName; + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " fileName\"", (char *) NULL); + return TCL_ERROR; + } + strcpy(dumpFile, argv[1]); + tclMemDumpFileName = dumpFile; + quitFlag = 1; + return TCL_OK; +} +#endif diff --git a/contrib/tcl/generic/tclNotify.c b/contrib/tcl/generic/tclNotify.c new file mode 100644 index 0000000000000..0745591835faa --- /dev/null +++ b/contrib/tcl/generic/tclNotify.c @@ -0,0 +1,578 @@ +/* + * tclNotify.c -- + * + * This file provides the parts of the Tcl event notifier that are + * the same on all platforms, plus a few other parts that are used + * on more than one platform but not all. + * + * The notifier is the lowest-level part of the event system. It + * manages an event queue that holds Tcl_Event structures and a list + * of event sources that can add events to the queue. It also + * contains the procedure Tcl_DoOneEvent that invokes the event + * sources and blocks to wait for new events, but Tcl_DoOneEvent + * is in the platform-specific part of the notifier (in files like + * tclUnixNotify.c). + * + * 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: @(#) tclNotify.c 1.6 96/02/29 09:20:10 + */ + +#include "tclInt.h" +#include "tclPort.h" + +/* + * The following variable records the address of the first event + * source in the list of all event sources for the application. + * This variable is accessed by the notifier to traverse the list + * and invoke each event source. + */ + +TclEventSource *tclFirstEventSourcePtr = NULL; + +/* + * The following variables indicate how long to block in the event + * notifier the next time it blocks (default: block forever). + */ + +static int blockTimeSet = 0; /* 0 means there is no maximum block + * time: block forever. */ +static Tcl_Time blockTime; /* If blockTimeSet is 1, gives the + * maximum elapsed time for the next block. */ + +/* + * The following variables keep track of the event queue. In addition + * to the first (next to be serviced) and last events in the queue, + * we keep track of a "marker" event. This provides a simple priority + * mechanism whereby events can be inserted at the front of the queue + * but behind all other high-priority events already in the queue (this + * is used for things like a sequence of Enter and Leave events generated + * during a grab in Tk). + */ + +static Tcl_Event *firstEventPtr = NULL; + /* First pending event, or NULL if none. */ +static Tcl_Event *lastEventPtr = NULL; + /* Last pending event, or NULL if none. */ +static Tcl_Event *markerEventPtr = NULL; + /* Last high-priority event in queue, or + * NULL if none. */ + +/* + * Prototypes for procedures used only in this file: + */ + +static int ServiceEvent _ANSI_ARGS_((int flags)); + +/* + *---------------------------------------------------------------------- + * + * Tcl_CreateEventSource -- + * + * This procedure is invoked to create a new source of events. + * The source is identified by a procedure that gets invoked + * during Tcl_DoOneEvent to check for events on that source + * and queue them. + * + * + * Results: + * None. + * + * Side effects: + * SetupProc and checkProc will be invoked each time that Tcl_DoOneEvent + * runs out of things to do. SetupProc will be invoked before + * Tcl_DoOneEvent calls select or whatever else it uses to wait + * for events. SetupProc typically calls functions like Tcl_WatchFile + * or Tcl_SetMaxBlockTime to indicate what to wait for. + * + * CheckProc is called after select or whatever operation was actually + * used to wait. It figures out whether anything interesting actually + * happened (e.g. by calling Tcl_FileReady), and then calls + * Tcl_QueueEvent to queue any events that are ready. + * + * Each of these procedures is passed two arguments, e.g. + * (*checkProc)(ClientData clientData, int flags)); + * ClientData is the same as the clientData argument here, and flags + * is a combination of things like TCL_FILE_EVENTS that indicates + * what events are of interest: setupProc and checkProc use flags + * to figure out whether their events are relevant or not. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_CreateEventSource(setupProc, checkProc, clientData) + Tcl_EventSetupProc *setupProc; /* Procedure to invoke to figure out + * what to wait for. */ + Tcl_EventCheckProc *checkProc; /* Procedure to call after waiting + * to see what happened. */ + ClientData clientData; /* One-word argument to pass to + * setupProc and checkProc. */ +{ + TclEventSource *sourcePtr; + + sourcePtr = (TclEventSource *) ckalloc(sizeof(TclEventSource)); + sourcePtr->setupProc = setupProc; + sourcePtr->checkProc = checkProc; + sourcePtr->clientData = clientData; + sourcePtr->nextPtr = tclFirstEventSourcePtr; + tclFirstEventSourcePtr = sourcePtr; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DeleteEventSource -- + * + * This procedure is invoked to delete the source of events + * given by proc and clientData. + * + * Results: + * None. + * + * Side effects: + * The given event source is cancelled, so its procedure will + * never again be called. If no such source exists, nothing + * happens. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DeleteEventSource(setupProc, checkProc, clientData) + Tcl_EventSetupProc *setupProc; /* Procedure to invoke to figure out + * what to wait for. */ + Tcl_EventCheckProc *checkProc; /* Procedure to call after waiting + * to see what happened. */ + ClientData clientData; /* One-word argument to pass to + * setupProc and checkProc. */ +{ + TclEventSource *sourcePtr, *prevPtr; + + for (sourcePtr = tclFirstEventSourcePtr, prevPtr = NULL; + sourcePtr != NULL; + prevPtr = sourcePtr, sourcePtr = sourcePtr->nextPtr) { + if ((sourcePtr->setupProc != setupProc) + || (sourcePtr->checkProc != checkProc) + || (sourcePtr->clientData != clientData)) { + continue; + } + if (prevPtr == NULL) { + tclFirstEventSourcePtr = sourcePtr->nextPtr; + } else { + prevPtr->nextPtr = sourcePtr->nextPtr; + } + ckfree((char *) sourcePtr); + return; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_QueueEvent -- + * + * Insert an event into the Tk event queue at one of three + * positions: the head, the tail, or before a floating marker. + * Events inserted before the marker will be processed in + * first-in-first-out order, but before any events inserted at + * the tail of the queue. Events inserted at the head of the + * queue will be processed in last-in-first-out order. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_QueueEvent(evPtr, position) + Tcl_Event* evPtr; /* Event to add to queue. The storage + * space must have been allocated the caller + * with malloc (ckalloc), and it becomes + * the property of the event queue. It + * will be freed after the event has been + * handled. */ + Tcl_QueuePosition position; /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, + * TCL_QUEUE_MARK. */ +{ + if (position == TCL_QUEUE_TAIL) { + /* + * Append the event on the end of the queue. + */ + + evPtr->nextPtr = NULL; + if (firstEventPtr == NULL) { + firstEventPtr = evPtr; + } else { + lastEventPtr->nextPtr = evPtr; + } + lastEventPtr = evPtr; + } else if (position == TCL_QUEUE_HEAD) { + /* + * Push the event on the head of the queue. + */ + + evPtr->nextPtr = firstEventPtr; + if (firstEventPtr == NULL) { + lastEventPtr = evPtr; + } + firstEventPtr = evPtr; + } else if (position == TCL_QUEUE_MARK) { + /* + * Insert the event after the current marker event and advance + * the marker to the new event. + */ + + if (markerEventPtr == NULL) { + evPtr->nextPtr = firstEventPtr; + firstEventPtr = evPtr; + } else { + evPtr->nextPtr = markerEventPtr->nextPtr; + markerEventPtr->nextPtr = evPtr; + } + markerEventPtr = evPtr; + if (evPtr->nextPtr == NULL) { + lastEventPtr = evPtr; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DeleteEvents -- + * + * Calls a procedure for each event in the queue and deletes those + * for which the procedure returns 1. Events for which the + * procedure returns 0 are left in the queue. + * + * Results: + * None. + * + * Side effects: + * Potentially removes one or more events from the event queue. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DeleteEvents(proc, clientData) + Tcl_EventDeleteProc *proc; /* The procedure to call. */ + ClientData clientData; /* type-specific data. */ +{ + Tcl_Event *evPtr, *prevPtr, *hold; + + for (prevPtr = (Tcl_Event *) NULL, evPtr = firstEventPtr; + evPtr != (Tcl_Event *) NULL; + ) { + if ((*proc) (evPtr, clientData) == 1) { + if (firstEventPtr == evPtr) { + firstEventPtr = evPtr->nextPtr; + if (evPtr->nextPtr == (Tcl_Event *) NULL) { + lastEventPtr = (Tcl_Event *) NULL; + } + } else { + prevPtr->nextPtr = evPtr->nextPtr; + } + hold = evPtr; + evPtr = evPtr->nextPtr; + ckfree((char *) hold); + } else { + prevPtr = evPtr; + evPtr = evPtr->nextPtr; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * ServiceEvent -- + * + * Process one event from the event queue. This routine is called + * by the notifier whenever it wants Tk to process an event. + * + * Results: + * The return value is 1 if the procedure actually found an event + * to process. If no processing occurred, then 0 is returned. + * + * Side effects: + * Invokes all of the event handlers for the highest priority + * event in the event queue. May collapse some events into a + * single event or discard stale events. + * + *---------------------------------------------------------------------- + */ + +static int +ServiceEvent(flags) + int flags; /* Indicates what events should be processed. + * May be any combination of TCL_WINDOW_EVENTS + * TCL_FILE_EVENTS, TCL_TIMER_EVENTS, or other + * flags defined elsewhere. Events not + * matching this will be skipped for processing + * later. */ +{ + Tcl_Event *evPtr, *prevPtr; + Tcl_EventProc *proc; + + /* + * No event flags is equivalent to TCL_ALL_EVENTS. + */ + + if ((flags & TCL_ALL_EVENTS) == 0) { + flags |= TCL_ALL_EVENTS; + } + + /* + * Loop through all the events in the queue until we find one + * that can actually be handled. + */ + + for (evPtr = firstEventPtr; evPtr != NULL; evPtr = evPtr->nextPtr) { + /* + * Call the handler for the event. If it actually handles the + * event then free the storage for the event. There are two + * tricky things here, but stemming from the fact that the event + * code may be re-entered while servicing the event: + * + * 1. Set the "proc" field to NULL. This is a signal to ourselves + * that we shouldn't reexecute the handler if the event loop + * is re-entered. + * 2. When freeing the event, must search the queue again from the + * front to find it. This is because the event queue could + * change almost arbitrarily while handling the event, so we + * can't depend on pointers found now still being valid when + * the handler returns. + */ + + proc = evPtr->proc; + evPtr->proc = NULL; + if ((proc != NULL) && (*proc)(evPtr, flags)) { + if (firstEventPtr == evPtr) { + firstEventPtr = evPtr->nextPtr; + if (evPtr->nextPtr == NULL) { + lastEventPtr = NULL; + } + } else { + for (prevPtr = firstEventPtr; prevPtr->nextPtr != evPtr; + prevPtr = prevPtr->nextPtr) { + /* Empty loop body. */ + } + prevPtr->nextPtr = evPtr->nextPtr; + if (evPtr->nextPtr == NULL) { + lastEventPtr = prevPtr; + } + } + if (markerEventPtr == evPtr) { + markerEventPtr = NULL; + } + ckfree((char *) evPtr); + return 1; + } else { + /* + * The event wasn't actually handled, so we have to restore + * the proc field to allow the event to be attempted again. + */ + + evPtr->proc = proc; + } + + /* + * The handler for this event asked to defer it. Just go on to + * the next event. + */ + + continue; + } + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetMaxBlockTime -- + * + * This procedure is invoked by event sources to tell the notifier + * how long it may block the next time it blocks. The timePtr + * argument gives a maximum time; the actual time may be less if + * some other event source requested a smaller time. + * + * Results: + * None. + * + * Side effects: + * May reduce the length of the next sleep in the notifier. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SetMaxBlockTime(timePtr) + Tcl_Time *timePtr; /* Specifies a maximum elapsed time for + * the next blocking operation in the + * event notifier. */ +{ + if (!blockTimeSet || (timePtr->sec < blockTime.sec) + || ((timePtr->sec == blockTime.sec) + && (timePtr->usec < blockTime.usec))) { + blockTime = *timePtr; + blockTimeSet = 1; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DoOneEvent -- + * + * Process a single event of some sort. If there's no work to + * do, wait for an event to occur, then process it. + * + * Results: + * The return value is 1 if the procedure actually found an event + * to process. If no processing occurred, then 0 is returned (this + * can happen if the TCL_DONT_WAIT flag is set or if there are no + * event handlers to wait for in the set specified by flags). + * + * Side effects: + * May delay execution of process while waiting for an event, + * unless TCL_DONT_WAIT is set in the flags argument. Event + * sources are invoked to check for and queue events. Event + * handlers may produce arbitrary side effects. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_DoOneEvent(flags) + int flags; /* Miscellaneous flag values: may be any + * combination of TCL_DONT_WAIT, + * TCL_WINDOW_EVENTS, TCL_FILE_EVENTS, + * TCL_TIMER_EVENTS, TCL_IDLE_EVENTS, or + * others defined by event sources. */ +{ + TclEventSource *sourcePtr; + Tcl_Time *timePtr; + + /* + * No event flags is equivalent to TCL_ALL_EVENTS. + */ + + if ((flags & TCL_ALL_EVENTS) == 0) { + flags |= TCL_ALL_EVENTS; + } + + /* + * The core of this procedure is an infinite loop, even though + * we only service one event. The reason for this is that we + * might think we have an event ready (e.g. the connection to + * the server becomes readable), but then we might discover that + * there's nothing interesting on that connection, so no event + * was serviced. Or, the select operation could return prematurely + * due to a signal. The easiest thing in both these cases is + * just to loop back and try again. + */ + + while (1) { + + /* + * The first thing we do is to service any asynchronous event + * handlers. + */ + + if (Tcl_AsyncReady()) { + (void) Tcl_AsyncInvoke((Tcl_Interp *) NULL, 0); + return 1; + } + + /* + * If idle events are the only things to service, skip the + * main part of the loop and go directly to handle idle + * events (i.e. don't wait even if TCL_DONT_WAIT isn't set. + */ + + if (flags == TCL_IDLE_EVENTS) { + flags = TCL_IDLE_EVENTS|TCL_DONT_WAIT; + goto idleEvents; + } + + /* + * Ask Tk to service a queued event, if there are any. + */ + + if (ServiceEvent(flags)) { + return 1; + } + + /* + * There are no events already queued. Invoke all of the + * event sources to give them a chance to setup for the wait. + */ + + blockTimeSet = 0; + for (sourcePtr = tclFirstEventSourcePtr; sourcePtr != NULL; + sourcePtr = sourcePtr->nextPtr) { + (*sourcePtr->setupProc)(sourcePtr->clientData, flags); + } + if ((flags & TCL_DONT_WAIT) || + ((flags & TCL_IDLE_EVENTS) && TclIdlePending())) { + /* + * Don't block: there are idle events waiting, or we don't + * care about idle events anyway, or the caller asked us not + * to block. + */ + + blockTime.sec = 0; + blockTime.usec = 0; + timePtr = &blockTime; + } else if (blockTimeSet) { + timePtr = &blockTime; + } else { + timePtr = NULL; + } + + /* + * Wait until an event occurs or the timer expires. + */ + + if (Tcl_WaitForEvent(timePtr) == TCL_ERROR) { + return 0; + } + + /* + * Give each of the event sources a chance to queue events, + * then call ServiceEvent and give it another chance to + * service events. + */ + + for (sourcePtr = tclFirstEventSourcePtr; sourcePtr != NULL; + sourcePtr = sourcePtr->nextPtr) { + (*sourcePtr->checkProc)(sourcePtr->clientData, flags); + } + if (ServiceEvent(flags)) { + return 1; + } + + /* + * We've tried everything at this point, but nobody had anything + * to do. Check for idle events. If none, either quit or go back + * to the top and try again. + */ + + idleEvents: + if ((flags & TCL_IDLE_EVENTS) && TclServiceIdle()) { + return 1; + } + if (flags & TCL_DONT_WAIT) { + return 0; + } + } +} diff --git a/contrib/tcl/generic/tclParse.c b/contrib/tcl/generic/tclParse.c new file mode 100644 index 0000000000000..656e218600b1c --- /dev/null +++ b/contrib/tcl/generic/tclParse.c @@ -0,0 +1,1386 @@ +/* + * tclParse.c -- + * + * This file contains a collection of procedures that are used + * to parse Tcl commands or parts of commands (like quoted + * strings or nested sub-commands). + * + * Copyright (c) 1987-1993 The Regents of the University of California. + * Copyright (c) 1994-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: @(#) tclParse.c 1.50 96/03/02 14:46:55 + */ + +#include "tclInt.h" +#include "tclPort.h" + +/* + * The following table assigns a type to each character. Only types + * meaningful to Tcl parsing are represented here. The table is + * designed to be referenced with either signed or unsigned characters, + * so it has 384 entries. The first 128 entries correspond to negative + * character values, the next 256 correspond to positive character + * values. The last 128 entries are identical to the first 128. The + * table is always indexed with a 128-byte offset (the 128th entry + * corresponds to a 0 character value). + */ + +char tclTypeTable[] = { + /* + * Negative character values, from -128 to -1: + */ + + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + + /* + * Positive character values, from 0-127: + */ + + TCL_COMMAND_END, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_SPACE, TCL_COMMAND_END, TCL_SPACE, + TCL_SPACE, TCL_SPACE, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_SPACE, TCL_NORMAL, TCL_QUOTE, TCL_NORMAL, + TCL_DOLLAR, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_COMMAND_END, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_OPEN_BRACKET, + TCL_BACKSLASH, TCL_COMMAND_END, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_OPEN_BRACE, + TCL_NORMAL, TCL_CLOSE_BRACE, TCL_NORMAL, TCL_NORMAL, + + /* + * Large unsigned character values, from 128-255: + */ + + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, + TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, +}; + +/* + * Function prototypes for procedures local to this file: + */ + +static char * QuoteEnd _ANSI_ARGS_((char *string, int term)); +static char * ScriptEnd _ANSI_ARGS_((char *p, int nested)); +static char * VarNameEnd _ANSI_ARGS_((char *string)); + +/* + *---------------------------------------------------------------------- + * + * Tcl_Backslash -- + * + * Figure out how to handle a backslash sequence. + * + * Results: + * The return value is the character that should be substituted + * in place of the backslash sequence that starts at src. If + * readPtr isn't NULL then it is filled in with a count of the + * number of characters in the backslash sequence. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char +Tcl_Backslash(src, readPtr) + char *src; /* Points to the backslash character of + * a backslash sequence. */ + int *readPtr; /* Fill in with number of characters read + * from src, unless NULL. */ +{ + register char *p = src+1; + char result; + int count; + + count = 2; + + switch (*p) { + case 'a': + result = 0x7; /* Don't say '\a' here, since some compilers */ + break; /* don't support it. */ + case 'b': + result = '\b'; + break; + case 'f': + result = '\f'; + break; + case 'n': + result = '\n'; + break; + case 'r': + result = '\r'; + break; + case 't': + result = '\t'; + break; + case 'v': + result = '\v'; + break; + case 'x': + if (isxdigit(UCHAR(p[1]))) { + char *end; + + result = (char) strtoul(p+1, &end, 16); + count = end - src; + } else { + count = 2; + result = 'x'; + } + break; + case '\n': + do { + p++; + } while ((*p == ' ') || (*p == '\t')); + result = ' '; + count = p - src; + break; + case 0: + result = '\\'; + count = 1; + break; + default: + if (isdigit(UCHAR(*p))) { + result = (char)(*p - '0'); + p++; + if (!isdigit(UCHAR(*p))) { + break; + } + count = 3; + result = (char)((result << 3) + (*p - '0')); + p++; + if (!isdigit(UCHAR(*p))) { + break; + } + count = 4; + result = (char)((result << 3) + (*p - '0')); + break; + } + result = *p; + count = 2; + break; + } + + if (readPtr != NULL) { + *readPtr = count; + } + return result; +} + +/* + *-------------------------------------------------------------- + * + * TclParseQuotes -- + * + * This procedure parses a double-quoted string such as a + * quoted Tcl command argument or a quoted value in a Tcl + * expression. This procedure is also used to parse array + * element names within parentheses, or anything else that + * needs all the substitutions that happen in quotes. + * + * Results: + * The return value is a standard Tcl result, which is + * TCL_OK unless there was an error while parsing the + * quoted string. If an error occurs then interp->result + * contains a standard error message. *TermPtr is filled + * in with the address of the character just after the + * last one successfully processed; this is usually the + * character just after the matching close-quote. The + * fully-substituted contents of the quotes are stored in + * standard fashion in *pvPtr, null-terminated with + * pvPtr->next pointing to the terminating null character. + * + * Side effects: + * The buffer space in pvPtr may be enlarged by calling its + * expandProc. + * + *-------------------------------------------------------------- + */ + +int +TclParseQuotes(interp, string, termChar, flags, termPtr, pvPtr) + Tcl_Interp *interp; /* Interpreter to use for nested command + * evaluations and error messages. */ + char *string; /* Character just after opening double- + * quote. */ + int termChar; /* Character that terminates "quoted" string + * (usually double-quote, but sometimes + * right-paren or something else). */ + int flags; /* Flags to pass to nested Tcl_Eval calls. */ + char **termPtr; /* Store address of terminating character + * here. */ + ParseValue *pvPtr; /* Information about where to place + * fully-substituted result of parse. */ +{ + register char *src, *dst, c; + + src = string; + dst = pvPtr->next; + + while (1) { + if (dst == pvPtr->end) { + /* + * Target buffer space is about to run out. Make more space. + */ + + pvPtr->next = dst; + (*pvPtr->expandProc)(pvPtr, 1); + dst = pvPtr->next; + } + + c = *src; + src++; + if (c == termChar) { + *dst = '\0'; + pvPtr->next = dst; + *termPtr = src; + return TCL_OK; + } else if (CHAR_TYPE(c) == TCL_NORMAL) { + copy: + *dst = c; + dst++; + continue; + } else if (c == '$') { + int length; + char *value; + + value = Tcl_ParseVar(interp, src-1, termPtr); + if (value == NULL) { + return TCL_ERROR; + } + src = *termPtr; + length = strlen(value); + if ((pvPtr->end - dst) <= length) { + pvPtr->next = dst; + (*pvPtr->expandProc)(pvPtr, length); + dst = pvPtr->next; + } + strcpy(dst, value); + dst += length; + continue; + } else if (c == '[') { + int result; + + pvPtr->next = dst; + result = TclParseNestedCmd(interp, src, flags, termPtr, pvPtr); + if (result != TCL_OK) { + return result; + } + src = *termPtr; + dst = pvPtr->next; + continue; + } else if (c == '\\') { + int numRead; + + src--; + *dst = Tcl_Backslash(src, &numRead); + dst++; + src += numRead; + continue; + } else if (c == '\0') { + Tcl_ResetResult(interp); + sprintf(interp->result, "missing %c", termChar); + *termPtr = string-1; + return TCL_ERROR; + } else { + goto copy; + } + } +} + +/* + *-------------------------------------------------------------- + * + * TclParseNestedCmd -- + * + * This procedure parses a nested Tcl command between + * brackets, returning the result of the command. + * + * Results: + * The return value is a standard Tcl result, which is + * TCL_OK unless there was an error while executing the + * nested command. If an error occurs then interp->result + * contains a standard error message. *TermPtr is filled + * in with the address of the character just after the + * last one processed; this is usually the character just + * after the matching close-bracket, or the null character + * at the end of the string if the close-bracket was missing + * (a missing close bracket is an error). The result returned + * by the command is stored in standard fashion in *pvPtr, + * null-terminated, with pvPtr->next pointing to the null + * character. + * + * Side effects: + * The storage space at *pvPtr may be expanded. + * + *-------------------------------------------------------------- + */ + +int +TclParseNestedCmd(interp, string, flags, termPtr, pvPtr) + Tcl_Interp *interp; /* Interpreter to use for nested command + * evaluations and error messages. */ + char *string; /* Character just after opening bracket. */ + int flags; /* Flags to pass to nested Tcl_Eval. */ + char **termPtr; /* Store address of terminating character + * here. */ + register ParseValue *pvPtr; /* Information about where to place + * result of command. */ +{ + int result, length, shortfall; + Interp *iPtr = (Interp *) interp; + + iPtr->evalFlags = flags | TCL_BRACKET_TERM; + result = Tcl_Eval(interp, string); + *termPtr = iPtr->termPtr; + if (result != TCL_OK) { + /* + * The increment below results in slightly cleaner message in + * the errorInfo variable (the close-bracket will appear). + */ + + if (**termPtr == ']') { + *termPtr += 1; + } + return result; + } + (*termPtr) += 1; + length = strlen(iPtr->result); + shortfall = length + 1 - (pvPtr->end - pvPtr->next); + if (shortfall > 0) { + (*pvPtr->expandProc)(pvPtr, shortfall); + } + strcpy(pvPtr->next, iPtr->result); + pvPtr->next += length; + Tcl_FreeResult(iPtr); + iPtr->result = iPtr->resultSpace; + iPtr->resultSpace[0] = '\0'; + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * TclParseBraces -- + * + * This procedure scans the information between matching + * curly braces. + * + * Results: + * The return value is a standard Tcl result, which is + * TCL_OK unless there was an error while parsing string. + * If an error occurs then interp->result contains a + * standard error message. *TermPtr is filled + * in with the address of the character just after the + * last one successfully processed; this is usually the + * character just after the matching close-brace. The + * information between curly braces is stored in standard + * fashion in *pvPtr, null-terminated with pvPtr->next + * pointing to the terminating null character. + * + * Side effects: + * The storage space at *pvPtr may be expanded. + * + *-------------------------------------------------------------- + */ + +int +TclParseBraces(interp, string, termPtr, pvPtr) + Tcl_Interp *interp; /* Interpreter to use for nested command + * evaluations and error messages. */ + char *string; /* Character just after opening bracket. */ + char **termPtr; /* Store address of terminating character + * here. */ + register ParseValue *pvPtr; /* Information about where to place + * result of command. */ +{ + int level; + register char *src, *dst, *end; + register char c; + + src = string; + dst = pvPtr->next; + end = pvPtr->end; + level = 1; + + /* + * Copy the characters one at a time to the result area, stopping + * when the matching close-brace is found. + */ + + while (1) { + c = *src; + src++; + if (dst == end) { + pvPtr->next = dst; + (*pvPtr->expandProc)(pvPtr, 20); + dst = pvPtr->next; + end = pvPtr->end; + } + *dst = c; + dst++; + if (CHAR_TYPE(c) == TCL_NORMAL) { + continue; + } else if (c == '{') { + level++; + } else if (c == '}') { + level--; + if (level == 0) { + dst--; /* Don't copy the last close brace. */ + break; + } + } else if (c == '\\') { + int count; + + /* + * Must always squish out backslash-newlines, even when in + * braces. This is needed so that this sequence can appear + * anywhere in a command, such as the middle of an expression. + */ + + if (*src == '\n') { + dst[-1] = Tcl_Backslash(src-1, &count); + src += count - 1; + } else { + (void) Tcl_Backslash(src-1, &count); + while (count > 1) { + if (dst == end) { + pvPtr->next = dst; + (*pvPtr->expandProc)(pvPtr, 20); + dst = pvPtr->next; + end = pvPtr->end; + } + *dst = *src; + dst++; + src++; + count--; + } + } + } else if (c == '\0') { + Tcl_SetResult(interp, "missing close-brace", TCL_STATIC); + *termPtr = string-1; + return TCL_ERROR; + } + } + + *dst = '\0'; + pvPtr->next = dst; + *termPtr = src; + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * TclParseWords -- + * + * This procedure parses one or more words from a command + * string and creates argv-style pointers to fully-substituted + * copies of those words. + * + * Results: + * The return value is a standard Tcl result. + * + * *argcPtr is modified to hold a count of the number of words + * successfully parsed, which may be 0. At most maxWords words + * will be parsed. If 0 <= *argcPtr < maxWords then it + * means that a command separator was seen. If *argcPtr + * is maxWords then it means that a command separator was + * not seen yet. + * + * *TermPtr is filled in with the address of the character + * just after the last one successfully processed in the + * last word. This is either the command terminator (if + * *argcPtr < maxWords), the character just after the last + * one in a word (if *argcPtr is maxWords), or the vicinity + * of an error (if the result is not TCL_OK). + * + * The pointers at *argv are filled in with pointers to the + * fully-substituted words, and the actual contents of the + * words are copied to the buffer at pvPtr. + * + * If an error occurrs then an error message is left in + * interp->result and the information at *argv, *argcPtr, + * and *pvPtr may be incomplete. + * + * Side effects: + * The buffer space in pvPtr may be enlarged by calling its + * expandProc. + * + *-------------------------------------------------------------- + */ + +int +TclParseWords(interp, string, flags, maxWords, termPtr, argcPtr, argv, pvPtr) + Tcl_Interp *interp; /* Interpreter to use for nested command + * evaluations and error messages. */ + char *string; /* First character of word. */ + int flags; /* Flags to control parsing (same values as + * passed to Tcl_Eval). */ + int maxWords; /* Maximum number of words to parse. */ + char **termPtr; /* Store address of terminating character + * here. */ + int *argcPtr; /* Filled in with actual number of words + * parsed. */ + char **argv; /* Store addresses of individual words here. */ + register ParseValue *pvPtr; /* Information about where to place + * fully-substituted word. */ +{ + register char *src, *dst; + register char c; + int type, result, argc; + char *oldBuffer; /* Used to detect when pvPtr's buffer gets + * reallocated, so we can adjust all of the + * argv pointers. */ + + src = string; + oldBuffer = pvPtr->buffer; + dst = pvPtr->next; + for (argc = 0; argc < maxWords; argc++) { + argv[argc] = dst; + + /* + * Skip leading space. + */ + + skipSpace: + c = *src; + type = CHAR_TYPE(c); + while (type == TCL_SPACE) { + src++; + c = *src; + type = CHAR_TYPE(c); + } + + /* + * Handle the normal case (i.e. no leading double-quote or brace). + */ + + if (type == TCL_NORMAL) { + normalArg: + while (1) { + if (dst == pvPtr->end) { + /* + * Target buffer space is about to run out. Make + * more space. + */ + + pvPtr->next = dst; + (*pvPtr->expandProc)(pvPtr, 1); + dst = pvPtr->next; + } + + if (type == TCL_NORMAL) { + copy: + *dst = c; + dst++; + src++; + } else if (type == TCL_SPACE) { + goto wordEnd; + } else if (type == TCL_DOLLAR) { + int length; + char *value; + + value = Tcl_ParseVar(interp, src, termPtr); + if (value == NULL) { + return TCL_ERROR; + } + src = *termPtr; + length = strlen(value); + if ((pvPtr->end - dst) <= length) { + pvPtr->next = dst; + (*pvPtr->expandProc)(pvPtr, length); + dst = pvPtr->next; + } + strcpy(dst, value); + dst += length; + } else if (type == TCL_COMMAND_END) { + if ((c == ']') && !(flags & TCL_BRACKET_TERM)) { + goto copy; + } + + /* + * End of command; simulate a word-end first, so + * that the end-of-command can be processed as the + * first thing in a new word. + */ + + goto wordEnd; + } else if (type == TCL_OPEN_BRACKET) { + pvPtr->next = dst; + result = TclParseNestedCmd(interp, src+1, flags, termPtr, + pvPtr); + if (result != TCL_OK) { + return result; + } + src = *termPtr; + dst = pvPtr->next; + } else if (type == TCL_BACKSLASH) { + int numRead; + + *dst = Tcl_Backslash(src, &numRead); + + /* + * The following special check allows a backslash-newline + * to be treated as a word-separator, as if the backslash + * and newline had been collapsed before command parsing + * began. + */ + + if (src[1] == '\n') { + src += numRead; + goto wordEnd; + } + src += numRead; + dst++; + } else { + goto copy; + } + c = *src; + type = CHAR_TYPE(c); + } + } else { + + /* + * Check for the end of the command. + */ + + if (type == TCL_COMMAND_END) { + if (flags & TCL_BRACKET_TERM) { + if (c == '\0') { + Tcl_SetResult(interp, "missing close-bracket", + TCL_STATIC); + return TCL_ERROR; + } + } else { + if (c == ']') { + goto normalArg; + } + } + goto done; + } + + /* + * Now handle the special cases: open braces, double-quotes, + * and backslash-newline. + */ + + pvPtr->next = dst; + if (type == TCL_QUOTE) { + result = TclParseQuotes(interp, src+1, '"', flags, + termPtr, pvPtr); + } else if (type == TCL_OPEN_BRACE) { + result = TclParseBraces(interp, src+1, termPtr, pvPtr); + } else if ((type == TCL_BACKSLASH) && (src[1] == '\n')) { + /* + * This code is needed so that a backslash-newline at the + * very beginning of a word is treated as part of the white + * space between words and not as a space within the word. + */ + + src += 2; + goto skipSpace; + } else { + goto normalArg; + } + if (result != TCL_OK) { + return result; + } + + /* + * Back from quotes or braces; make sure that the terminating + * character was the end of the word. + */ + + c = **termPtr; + if ((c == '\\') && ((*termPtr)[1] == '\n')) { + /* + * Line is continued on next line; the backslash-newline + * sequence turns into space, which is OK. No need to do + * anything here. + */ + } else { + type = CHAR_TYPE(c); + if ((type != TCL_SPACE) && (type != TCL_COMMAND_END)) { + if (*src == '"') { + Tcl_SetResult(interp, + "extra characters after close-quote", + TCL_STATIC); + } else { + Tcl_SetResult(interp, + "extra characters after close-brace", + TCL_STATIC); + } + return TCL_ERROR; + } + } + src = *termPtr; + dst = pvPtr->next; + } + + /* + * We're at the end of a word, so add a null terminator. Then + * see if the buffer was re-allocated during this word. If so, + * update all of the argv pointers. + */ + + wordEnd: + *dst = '\0'; + dst++; + if (oldBuffer != pvPtr->buffer) { + int i; + + for (i = 0; i <= argc; i++) { + argv[i] = pvPtr->buffer + (argv[i] - oldBuffer); + } + oldBuffer = pvPtr->buffer; + } + } + + done: + pvPtr->next = dst; + *termPtr = src; + *argcPtr = argc; + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * TclExpandParseValue -- + * + * This procedure is commonly used as the value of the + * expandProc in a ParseValue. It uses malloc to allocate + * more space for the result of a parse. + * + * Results: + * The buffer space in *pvPtr is reallocated to something + * larger, and if pvPtr->clientData is non-zero the old + * buffer is freed. Information is copied from the old + * buffer to the new one. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +void +TclExpandParseValue(pvPtr, needed) + register ParseValue *pvPtr; /* Information about buffer that + * must be expanded. If the clientData + * in the structure is non-zero, it + * means that the current buffer is + * dynamically allocated. */ + int needed; /* Minimum amount of additional space + * to allocate. */ +{ + int newSpace; + char *new; + + /* + * Either double the size of the buffer or add enough new space + * to meet the demand, whichever produces a larger new buffer. + */ + + newSpace = (pvPtr->end - pvPtr->buffer) + 1; + if (newSpace < needed) { + newSpace += needed; + } else { + newSpace += newSpace; + } + new = (char *) ckalloc((unsigned) newSpace); + + /* + * Copy from old buffer to new, free old buffer if needed, and + * mark new buffer as malloc-ed. + */ + + memcpy((VOID *) new, (VOID *) pvPtr->buffer, + (size_t) (pvPtr->next - pvPtr->buffer)); + pvPtr->next = new + (pvPtr->next - pvPtr->buffer); + if (pvPtr->clientData != 0) { + ckfree(pvPtr->buffer); + } + pvPtr->buffer = new; + pvPtr->end = new + newSpace - 1; + pvPtr->clientData = (ClientData) 1; +} + +/* + *---------------------------------------------------------------------- + * + * TclWordEnd -- + * + * Given a pointer into a Tcl command, find the end of the next + * word of the command. + * + * Results: + * The return value is a pointer to the last character that's part + * of the word pointed to by "start". If the word doesn't end + * properly within the string then the return value is the address + * of the null character at the end of the string. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +TclWordEnd(start, nested, semiPtr) + char *start; /* Beginning of a word of a Tcl command. */ + int nested; /* Zero means this is a top-level command. + * One means this is a nested command (close + * bracket is a word terminator). */ + int *semiPtr; /* Set to 1 if word ends with a command- + * terminating semi-colon, zero otherwise. + * If NULL then ignored. */ +{ + register char *p; + int count; + + if (semiPtr != NULL) { + *semiPtr = 0; + } + + /* + * Skip leading white space (backslash-newline must be treated like + * white-space, except that it better not be the last thing in the + * command). + */ + + for (p = start; ; p++) { + if (isspace(UCHAR(*p))) { + continue; + } + if ((p[0] == '\\') && (p[1] == '\n')) { + if (p[2] == 0) { + return p+2; + } + continue; + } + break; + } + + /* + * Handle words beginning with a double-quote or a brace. + */ + + if (*p == '"') { + p = QuoteEnd(p+1, '"'); + if (*p == 0) { + return p; + } + p++; + } else if (*p == '{') { + int braces = 1; + while (braces != 0) { + p++; + while (*p == '\\') { + (void) Tcl_Backslash(p, &count); + p += count; + } + if (*p == '}') { + braces--; + } else if (*p == '{') { + braces++; + } else if (*p == 0) { + return p; + } + } + p++; + } + + /* + * Handle words that don't start with a brace or double-quote. + * This code is also invoked if the word starts with a brace or + * double-quote and there is garbage after the closing brace or + * quote. This is an error as far as Tcl_Eval is concerned, but + * for here the garbage is treated as part of the word. + */ + + while (1) { + if (*p == '[') { + p = ScriptEnd(p+1, 1); + if (*p == 0) { + return p; + } + p++; + } else if (*p == '\\') { + if (p[1] == '\n') { + /* + * Backslash-newline: it maps to a space character + * that is a word separator, so the word ends just before + * the backslash. + */ + + return p-1; + } + (void) Tcl_Backslash(p, &count); + p += count; + } else if (*p == '$') { + p = VarNameEnd(p); + if (*p == 0) { + return p; + } + p++; + } else if (*p == ';') { + /* + * Include the semi-colon in the word that is returned. + */ + + if (semiPtr != NULL) { + *semiPtr = 1; + } + return p; + } else if (isspace(UCHAR(*p))) { + return p-1; + } else if ((*p == ']') && nested) { + return p-1; + } else if (*p == 0) { + if (nested) { + /* + * Nested commands can't end because of the end of the + * string. + */ + return p; + } + return p-1; + } else { + p++; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * QuoteEnd -- + * + * Given a pointer to a string that obeys the parsing conventions + * for quoted things in Tcl, find the end of that quoted thing. + * The actual thing may be a quoted argument or a parenthesized + * index name. + * + * Results: + * The return value is a pointer to the last character that is + * part of the quoted string (i.e the character that's equal to + * term). If the quoted string doesn't terminate properly then + * the return value is a pointer to the null character at the + * end of the string. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static char * +QuoteEnd(string, term) + char *string; /* Pointer to character just after opening + * "quote". */ + int term; /* This character will terminate the + * quoted string (e.g. '"' or ')'). */ +{ + register char *p = string; + int count; + + while (*p != term) { + if (*p == '\\') { + (void) Tcl_Backslash(p, &count); + p += count; + } else if (*p == '[') { + for (p++; *p != ']'; p++) { + p = TclWordEnd(p, 1, (int *) NULL); + if (*p == 0) { + return p; + } + } + p++; + } else if (*p == '$') { + p = VarNameEnd(p); + if (*p == 0) { + return p; + } + p++; + } else if (*p == 0) { + return p; + } else { + p++; + } + } + return p-1; +} + +/* + *---------------------------------------------------------------------- + * + * VarNameEnd -- + * + * Given a pointer to a variable reference using $-notation, find + * the end of the variable name spec. + * + * Results: + * The return value is a pointer to the last character that + * is part of the variable name. If the variable name doesn't + * terminate properly then the return value is a pointer to the + * null character at the end of the string. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static char * +VarNameEnd(string) + char *string; /* Pointer to dollar-sign character. */ +{ + register char *p = string+1; + + if (*p == '{') { + for (p++; (*p != '}') && (*p != 0); p++) { + /* Empty loop body. */ + } + return p; + } + while (isalnum(UCHAR(*p)) || (*p == '_')) { + p++; + } + if ((*p == '(') && (p != string+1)) { + return QuoteEnd(p+1, ')'); + } + return p-1; +} + + +/* + *---------------------------------------------------------------------- + * + * ScriptEnd -- + * + * Given a pointer to the beginning of a Tcl script, find the end of + * the script. + * + * Results: + * The return value is a pointer to the last character that's part + * of the script pointed to by "p". If the command doesn't end + * properly within the string then the return value is the address + * of the null character at the end of the string. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static char * +ScriptEnd(p, nested) + char *p; /* Script to check. */ + int nested; /* Zero means this is a top-level command. + * One means this is a nested command (the + * last character of the script must be + * an unquoted ]). */ +{ + int commentOK = 1; + int length; + + while (1) { + while (isspace(UCHAR(*p))) { + if (*p == '\n') { + commentOK = 1; + } + p++; + } + if ((*p == '#') && commentOK) { + do { + if (*p == '\\') { + /* + * If the script ends with backslash-newline, then + * this command isn't complete. + */ + + if ((p[1] == '\n') && (p[2] == 0)) { + return p+2; + } + Tcl_Backslash(p, &length); + p += length; + } else { + p++; + } + } while ((*p != 0) && (*p != '\n')); + continue; + } + p = TclWordEnd(p, nested, &commentOK); + if (*p == 0) { + return p; + } + p++; + if (nested) { + if (*p == ']') { + return p; + } + } else { + if (*p == 0) { + return p-1; + } + } + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ParseVar -- + * + * Given a string starting with a $ sign, parse off a variable + * name and return its value. + * + * Results: + * The return value is the contents of the variable given by + * the leading characters of string. If termPtr isn't NULL, + * *termPtr gets filled in with the address of the character + * just after the last one in the variable specifier. If the + * variable doesn't exist, then the return value is NULL and + * an error message will be left in interp->result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_ParseVar(interp, string, termPtr) + Tcl_Interp *interp; /* Context for looking up variable. */ + register char *string; /* String containing variable name. + * First character must be "$". */ + char **termPtr; /* If non-NULL, points to word to fill + * in with character just after last + * one in the variable specifier. */ + +{ + char *name1, *name1End, c, *result; + register char *name2; +#define NUM_CHARS 200 + char copyStorage[NUM_CHARS]; + ParseValue pv; + + /* + * There are three cases: + * 1. The $ sign is followed by an open curly brace. Then the variable + * name is everything up to the next close curly brace, and the + * variable is a scalar variable. + * 2. The $ sign is not followed by an open curly brace. Then the + * variable name is everything up to the next character that isn't + * a letter, digit, or underscore. If the following character is an + * open parenthesis, then the information between parentheses is + * the array element name, which can include any of the substitutions + * permissible between quotes. + * 3. The $ sign is followed by something that isn't a letter, digit, + * or underscore: in this case, there is no variable name, and "$" + * is returned. + */ + + name2 = NULL; + string++; + if (*string == '{') { + string++; + name1 = string; + while (*string != '}') { + if (*string == 0) { + Tcl_SetResult(interp, "missing close-brace for variable name", + TCL_STATIC); + if (termPtr != 0) { + *termPtr = string; + } + return NULL; + } + string++; + } + name1End = string; + string++; + } else { + name1 = string; + while (isalnum(UCHAR(*string)) || (*string == '_')) { + string++; + } + if (string == name1) { + if (termPtr != 0) { + *termPtr = string; + } + return "$"; + } + name1End = string; + if (*string == '(') { + char *end; + + /* + * Perform substitutions on the array element name, just as + * is done for quotes. + */ + + pv.buffer = pv.next = copyStorage; + pv.end = copyStorage + NUM_CHARS - 1; + pv.expandProc = TclExpandParseValue; + pv.clientData = (ClientData) NULL; + if (TclParseQuotes(interp, string+1, ')', 0, &end, &pv) + != TCL_OK) { + char msg[200]; + int length; + + length = string-name1; + if (length > 100) { + length = 100; + } + sprintf(msg, "\n (parsing index for array \"%.*s\")", + length, name1); + Tcl_AddErrorInfo(interp, msg); + result = NULL; + name2 = pv.buffer; + if (termPtr != 0) { + *termPtr = end; + } + goto done; + } + Tcl_ResetResult(interp); + string = end; + name2 = pv.buffer; + } + } + if (termPtr != 0) { + *termPtr = string; + } + + if (((Interp *) interp)->noEval) { + return ""; + } + c = *name1End; + *name1End = 0; + result = Tcl_GetVar2(interp, name1, name2, TCL_LEAVE_ERR_MSG); + *name1End = c; + + done: + if ((name2 != NULL) && (pv.buffer != copyStorage)) { + ckfree(pv.buffer); + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CommandComplete -- + * + * Given a partial or complete Tcl command, this procedure + * determines whether the command is complete in the sense + * of having matched braces and quotes and brackets. + * + * Results: + * 1 is returned if the command is complete, 0 otherwise. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_CommandComplete(cmd) + char *cmd; /* Command to check. */ +{ + char *p; + + if (*cmd == 0) { + return 1; + } + p = ScriptEnd(cmd, 0); + return (*p != 0); +} diff --git a/contrib/tcl/generic/tclPkg.c b/contrib/tcl/generic/tclPkg.c new file mode 100644 index 0000000000000..9dc0b9481664a --- /dev/null +++ b/contrib/tcl/generic/tclPkg.c @@ -0,0 +1,732 @@ +/* + * tclPkg.c -- + * + * This file implements package and version control for Tcl via + * the "package" command and a few C APIs. + * + * Copyright (c) 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: @(#) tclPkg.c 1.6 96/02/15 11:43:16 + */ + +#include "tclInt.h" + +/* + * Each invocation of the "package ifneeded" command creates a structure + * of the following type, which is used to load the package into the + * interpreter if it is requested with a "package require" command. + */ + +typedef struct PkgAvail { + char *version; /* Version string; malloc'ed. */ + char *script; /* Script to invoke to provide this version + * of the package. Malloc'ed and protected + * by Tcl_Preserve and Tcl_Release. */ + struct PkgAvail *nextPtr; /* Next in list of available versions of + * the same package. */ +} PkgAvail; + +/* + * For each package that is known in any way to an interpreter, there + * is one record of the following type. These records are stored in + * the "packageTable" hash table in the interpreter, keyed by + * package name such as "Tk" (no version number). + */ + +typedef struct Package { + char *version; /* Version that has been supplied in this + * interpreter via "package provide" + * (malloc'ed). NULL means the package doesn't + * exist in this interpreter yet. */ + PkgAvail *availPtr; /* First in list of all available versions + * of this package. */ +} Package; + +/* + * Prototypes for procedures defined in this file: + */ + +static int CheckVersion _ANSI_ARGS_((Tcl_Interp *interp, + char *string)); +static int ComparePkgVersions _ANSI_ARGS_((char *v1, char *v2, + int *satPtr)); +static Package * FindPackage _ANSI_ARGS_((Tcl_Interp *interp, + char *name)); + +/* + *---------------------------------------------------------------------- + * + * Tcl_PkgProvide -- + * + * This procedure is invoked to declare that a particular version + * of a particular package is now present in an interpreter. There + * must not be any other version of this package already + * provided in the interpreter. + * + * Results: + * Normally returns TCL_OK; if there is already another version + * of the package loaded then TCL_ERROR is returned and an error + * message is left in interp->result. + * + * Side effects: + * The interpreter remembers that this package is available, + * so that no other version of the package may be provided for + * the interpreter. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_PkgProvide(interp, name, version) + Tcl_Interp *interp; /* Interpreter in which package is now + * available. */ + char *name; /* Name of package. */ + char *version; /* Version string for package. */ +{ + Package *pkgPtr; + + pkgPtr = FindPackage(interp, name); + if (pkgPtr->version == NULL) { + pkgPtr->version = ckalloc((unsigned) (strlen(version) + 1)); + strcpy(pkgPtr->version, version); + return TCL_OK; + } + if (ComparePkgVersions(pkgPtr->version, version, (int *) NULL) == 0) { + return TCL_OK; + } + Tcl_AppendResult(interp, "conflicting versions provided for package \"", + name, "\": ", pkgPtr->version, ", then ", version, (char *) NULL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_PkgRequire -- + * + * This procedure is called by code that depends on a particular + * version of a particular package. If the package is not already + * provided in the interpreter, this procedure invokes a Tcl script + * to provide it. If the package is already provided, this + * procedure makes sure that the caller's needs don't conflict with + * the version that is present. + * + * Results: + * If successful, returns the version string for the currently + * provided version of the package, which may be different from + * the "version" argument. If the caller's requirements + * cannot be met (e.g. the version requested conflicts with + * a currently provided version, or the required version cannot + * be found, or the script to provide the required version + * generates an error), NULL is returned and an error + * message is left in interp->result. + * + * Side effects: + * The script from some previous "package ifneeded" command may + * be invoked to provide the package. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_PkgRequire(interp, name, version, exact) + Tcl_Interp *interp; /* Interpreter in which package is now + * available. */ + char *name; /* Name of desired package. */ + char *version; /* Version string for desired version; + * NULL means use the latest version + * available. */ + int exact; /* Non-zero means that only the particular + * version given is acceptable. Zero means + * use the latest compatible version. */ +{ + Package *pkgPtr; + PkgAvail *availPtr, *bestPtr; + char *script; + int code, satisfies, result, pass; + Tcl_DString command; + + /* + * It can take up to three passes to find the package: one pass to + * run the "package unknown" script, one to run the "package ifneeded" + * script for a specific version, and a final pass to lookup the + * package loaded by the "package ifneeded" script. + */ + + for (pass = 1; ; pass++) { + pkgPtr = FindPackage(interp, name); + if (pkgPtr->version != NULL) { + break; + } + + /* + * The package isn't yet present. Search the list of available + * versions and invoke the script for the best available version. + */ + + bestPtr = NULL; + for (availPtr = pkgPtr->availPtr; availPtr != NULL; + availPtr = availPtr->nextPtr) { + if ((bestPtr != NULL) && (ComparePkgVersions(availPtr->version, + bestPtr->version, (int *) NULL) <= 0)) { + continue; + } + if (version != NULL) { + result = ComparePkgVersions(availPtr->version, version, + &satisfies); + if ((result != 0) && exact) { + continue; + } + if (!satisfies) { + continue; + } + } + bestPtr = availPtr; + } + if (bestPtr != NULL) { + /* + * We found an ifneeded script for the package. Be careful while + * executing it: this could cause reentrancy, so (a) protect the + * script itself from deletion and (b) don't assume that bestPtr + * will still exist when the script completes. + */ + + script = bestPtr->script; + Tcl_Preserve((ClientData) script); + code = Tcl_GlobalEval(interp, script); + Tcl_Release((ClientData) script); + if (code != TCL_OK) { + if (code == TCL_ERROR) { + Tcl_AddErrorInfo(interp, + "\n (\"package ifneeded\" script)"); + } + return NULL; + } + Tcl_ResetResult(interp); + pkgPtr = FindPackage(interp, name); + break; + } + + /* + * Package not in the database. If there is a "package unknown" + * command, invoke it (but only on the first pass; after that, + * we should not get here in the first place). + */ + + if (pass > 1) { + break; + } + script = ((Interp *) interp)->packageUnknown; + if (script != NULL) { + Tcl_DStringInit(&command); + Tcl_DStringAppend(&command, script, -1); + Tcl_DStringAppendElement(&command, name); + Tcl_DStringAppend(&command, " ", 1); + Tcl_DStringAppend(&command, (version != NULL) ? version : "{}", + -1); + if (exact) { + Tcl_DStringAppend(&command, " -exact", 7); + } + code = Tcl_GlobalEval(interp, Tcl_DStringValue(&command)); + Tcl_DStringFree(&command); + if (code != TCL_OK) { + if (code == TCL_ERROR) { + Tcl_AddErrorInfo(interp, + "\n (\"package unknown\" script)"); + } + return NULL; + } + Tcl_ResetResult(interp); + } + } + + if (pkgPtr->version == NULL) { + Tcl_AppendResult(interp, "can't find package ", name, + (char *) NULL); + if (version != NULL) { + Tcl_AppendResult(interp, " ", version, (char *) NULL); + } + return NULL; + } + + /* + * At this point we now that the package is present. Make sure that the + * provided version meets the current requirement. + */ + + if (version == NULL) { + return pkgPtr->version; + } + result = ComparePkgVersions(pkgPtr->version, version, &satisfies); + if ((satisfies && !exact) || (result == 0)) { + return pkgPtr->version; + } + Tcl_AppendResult(interp, "version conflict for package \"", + name, "\": have ", pkgPtr->version, ", need ", version, + (char *) NULL); + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_PackageCmd -- + * + * This procedure is invoked to process the "package" 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_PackageCmd(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; + size_t length; + int c, exact, i, satisfies; + PkgAvail *availPtr, *prevPtr; + Package *pkgPtr; + Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + Tcl_HashTable *tablePtr; + char *version; + + 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 == 'f') && (strncmp(argv[1], "forget", length) == 0)) { + for (i = 2; i < argc; i++) { + hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv[i]); + if (hPtr == NULL) { + return TCL_OK; + } + pkgPtr = (Package *) Tcl_GetHashValue(hPtr); + Tcl_DeleteHashEntry(hPtr); + if (pkgPtr->version != NULL) { + ckfree(pkgPtr->version); + } + while (pkgPtr->availPtr != NULL) { + availPtr = pkgPtr->availPtr; + pkgPtr->availPtr = availPtr->nextPtr; + ckfree(availPtr->version); + Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC); + ckfree((char *) availPtr); + } + ckfree((char *) pkgPtr); + } + } else if ((c == 'i') && (strncmp(argv[1], "ifneeded", length) == 0)) { + if ((argc != 4) && (argc != 5)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " ifneeded package version ?script?\"", (char *) NULL); + return TCL_ERROR; + } + if (CheckVersion(interp, argv[3]) != TCL_OK) { + return TCL_ERROR; + } + if (argc == 4) { + hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv[2]); + if (hPtr == NULL) { + return TCL_OK; + } + pkgPtr = (Package *) Tcl_GetHashValue(hPtr); + } else { + pkgPtr = FindPackage(interp, argv[2]); + } + for (availPtr = pkgPtr->availPtr, prevPtr = NULL; availPtr != NULL; + prevPtr = availPtr, availPtr = availPtr->nextPtr) { + if (ComparePkgVersions(availPtr->version, argv[3], (int *) NULL) + == 0) { + if (argc == 4) { + interp->result = availPtr->script; + return TCL_OK; + } + Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC); + break; + } + } + if (argc == 4) { + return TCL_OK; + } + if (availPtr == NULL) { + availPtr = (PkgAvail *) ckalloc(sizeof(PkgAvail)); + availPtr->version = ckalloc((unsigned) (strlen(argv[3]) + 1)); + strcpy(availPtr->version, argv[3]); + if (prevPtr == NULL) { + availPtr->nextPtr = pkgPtr->availPtr; + pkgPtr->availPtr = availPtr; + } else { + availPtr->nextPtr = prevPtr->nextPtr; + prevPtr->nextPtr = availPtr; + } + } + availPtr->script = ckalloc((unsigned) (strlen(argv[4]) + 1)); + strcpy(availPtr->script, argv[4]); + } else if ((c == 'n') && (strncmp(argv[1], "names", length) == 0)) { + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " names\"", (char *) NULL); + return TCL_ERROR; + } + tablePtr = &iPtr->packageTable; + for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL; + hPtr = Tcl_NextHashEntry(&search)) { + pkgPtr = (Package *) Tcl_GetHashValue(hPtr); + if ((pkgPtr->version != NULL) || (pkgPtr->availPtr != NULL)) { + Tcl_AppendElement(interp, Tcl_GetHashKey(tablePtr, hPtr)); + } + } + } else if ((c == 'p') && (strncmp(argv[1], "provide", length) == 0)) { + if ((argc != 3) && (argc != 4)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " provide package ?version?\"", (char *) NULL); + return TCL_ERROR; + } + if (argc == 3) { + hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv[2]); + if (hPtr != NULL) { + pkgPtr = (Package *) Tcl_GetHashValue(hPtr); + if (pkgPtr->version != NULL) { + interp->result = pkgPtr->version; + } + } + return TCL_OK; + } + if (CheckVersion(interp, argv[3]) != TCL_OK) { + return TCL_ERROR; + } + return Tcl_PkgProvide(interp, argv[2], argv[3]); + } else if ((c == 'r') && (strncmp(argv[1], "require", length) == 0)) { + if (argc < 3) { + requireSyntax: + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " require ?-exact? package ?version?\"", (char *) NULL); + return TCL_ERROR; + } + if ((argv[2][0] == '-') && (strcmp(argv[2], "-exact") == 0)) { + exact = 1; + } else { + exact = 0; + } + version = NULL; + if (argc == (4+exact)) { + version = argv[3+exact]; + if (CheckVersion(interp, version) != TCL_OK) { + return TCL_ERROR; + } + } else if ((argc != 3) || exact) { + goto requireSyntax; + } + version = Tcl_PkgRequire(interp, argv[2+exact], version, exact); + if (version == NULL) { + return TCL_ERROR; + } + interp->result = version; + } else if ((c == 'u') && (strncmp(argv[1], "unknown", length) == 0)) { + if (argc == 2) { + if (iPtr->packageUnknown != NULL) { + iPtr->result = iPtr->packageUnknown; + } + } else if (argc == 3) { + if (iPtr->packageUnknown != NULL) { + ckfree(iPtr->packageUnknown); + } + if (argv[2][0] == 0) { + iPtr->packageUnknown = NULL; + } else { + iPtr->packageUnknown = (char *) ckalloc((unsigned) + (strlen(argv[2]) + 1)); + strcpy(iPtr->packageUnknown, argv[2]); + } + } else { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " unknown ?command?\"", (char *) NULL); + return TCL_ERROR; + } + } else if ((c == 'v') && (strncmp(argv[1], "vcompare", length) == 0) + && (length >= 2)) { + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " vcompare version1 version2\"", (char *) NULL); + return TCL_ERROR; + } + if ((CheckVersion(interp, argv[2]) != TCL_OK) + || (CheckVersion(interp, argv[3]) != TCL_OK)) { + return TCL_ERROR; + } + sprintf(interp->result, "%d", ComparePkgVersions(argv[2], argv[3], + (int *) NULL)); + } else if ((c == 'v') && (strncmp(argv[1], "versions", length) == 0) + && (length >= 2)) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " versions package\"", (char *) NULL); + return TCL_ERROR; + } + hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv[2]); + if (hPtr != NULL) { + pkgPtr = (Package *) Tcl_GetHashValue(hPtr); + for (availPtr = pkgPtr->availPtr; availPtr != NULL; + availPtr = availPtr->nextPtr) { + Tcl_AppendElement(interp, availPtr->version); + } + } + } else if ((c == 'v') && (strncmp(argv[1], "vsatisfies", length) == 0) + && (length >= 2)) { + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " vsatisfies version1 version2\"", (char *) NULL); + return TCL_ERROR; + } + if ((CheckVersion(interp, argv[2]) != TCL_OK) + || (CheckVersion(interp, argv[3]) != TCL_OK)) { + return TCL_ERROR; + } + ComparePkgVersions(argv[2], argv[3], &satisfies); + sprintf(interp->result, "%d", satisfies); + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": should be forget, ifneeded, names, ", + "provide, require, unknown, vcompare, ", + "versions, or vsatisfies", (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * FindPackage -- + * + * This procedure finds the Package record for a particular package + * in a particular interpreter, creating a record if one doesn't + * already exist. + * + * Results: + * The return value is a pointer to the Package record for the + * package. + * + * Side effects: + * A new Package record may be created. + * + *---------------------------------------------------------------------- + */ + +static Package * +FindPackage(interp, name) + Tcl_Interp *interp; /* Interpreter to use for package lookup. */ + char *name; /* Name of package to fine. */ +{ + Interp *iPtr = (Interp *) interp; + Tcl_HashEntry *hPtr; + int new; + Package *pkgPtr; + + hPtr = Tcl_CreateHashEntry(&iPtr->packageTable, name, &new); + if (new) { + pkgPtr = (Package *) ckalloc(sizeof(Package)); + pkgPtr->version = NULL; + pkgPtr->availPtr = NULL; + Tcl_SetHashValue(hPtr, pkgPtr); + } else { + pkgPtr = (Package *) Tcl_GetHashValue(hPtr); + } + return pkgPtr; +} + +/* + *---------------------------------------------------------------------- + * + * TclFreePackageInfo -- + * + * This procedure is called during interpreter deletion to + * free all of the package-related information for the + * interpreter. + * + * Results: + * None. + * + * Side effects: + * Memory is freed. + * + *---------------------------------------------------------------------- + */ + +void +TclFreePackageInfo(iPtr) + Interp *iPtr; /* Interpereter that is being deleted. */ +{ + Package *pkgPtr; + Tcl_HashSearch search; + Tcl_HashEntry *hPtr; + PkgAvail *availPtr; + + for (hPtr = Tcl_FirstHashEntry(&iPtr->packageTable, &search); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + pkgPtr = (Package *) Tcl_GetHashValue(hPtr); + if (pkgPtr->version != NULL) { + ckfree(pkgPtr->version); + } + while (pkgPtr->availPtr != NULL) { + availPtr = pkgPtr->availPtr; + pkgPtr->availPtr = availPtr->nextPtr; + ckfree(availPtr->version); + Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC); + ckfree((char *) availPtr); + } + ckfree((char *) pkgPtr); + } + Tcl_DeleteHashTable(&iPtr->packageTable); + if (iPtr->packageUnknown != NULL) { + ckfree(iPtr->packageUnknown); + } +} + +/* + *---------------------------------------------------------------------- + * + * CheckVersion -- + * + * This procedure checks to see whether a version number has + * valid syntax. + * + * Results: + * If string is a properly formed version number the TCL_OK + * is returned. Otherwise TCL_ERROR is returned and an error + * message is left in interp->result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +CheckVersion(interp, string) + Tcl_Interp *interp; /* Used for error reporting. */ + char *string; /* Supposedly a version number, which is + * groups of decimal digits separated + * by dots. */ +{ + char *p = string; + + if (!isdigit(*p)) { + goto error; + } + for (p++; *p != 0; p++) { + if (!isdigit(*p) && (*p != '.')) { + goto error; + } + } + if (p[-1] != '.') { + return TCL_OK; + } + + error: + Tcl_AppendResult(interp, "expected version number but got \"", + string, "\"", (char *) NULL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * ComparePkgVersions -- + * + * This procedure compares two version numbers. + * + * Results: + * The return value is -1 if v1 is less than v2, 0 if the two + * version numbers are the same, and 1 if v1 is greater than v2. + * If *satPtr is non-NULL, the word it points to is filled in + * with 1 if v2 >= v1 and both numbers have the same major number + * or 0 otherwise. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +ComparePkgVersions(v1, v2, satPtr) + char *v1, *v2; /* Versions strings, of form 2.1.3 (any + * number of version numbers). */ + int *satPtr; /* If non-null, the word pointed to is + * filled in with a 0/1 value. 1 means + * v1 "satisfies" v2: v1 is greater than + * or equal to v2 and both version numbers + * have the same major number. */ +{ + int thisIsMajor, n1, n2; + + /* + * Each iteration of the following loop processes one number from + * each string, terminated by a ".". If those numbers don't match + * then the comparison is over; otherwise, we loop back for the + * next number. + */ + + thisIsMajor = 1; + while (1) { + /* + * Parse one decimal number from the front of each string. + */ + + n1 = n2 = 0; + while ((*v1 != 0) && (*v1 != '.')) { + n1 = 10*n1 + (*v1 - '0'); + v1++; + } + while ((*v2 != 0) && (*v2 != '.')) { + n2 = 10*n2 + (*v2 - '0'); + v2++; + } + + /* + * Compare and go on to the next version number if the + * current numbers match. + */ + + if (n1 != n2) { + break; + } + if (*v1 != 0) { + v1++; + } else if (*v2 == 0) { + break; + } + if (*v2 != 0) { + v2++; + } + thisIsMajor = 0; + } + if (satPtr != NULL) { + *satPtr = (n1 == n2) || ((n1 > n2) && !thisIsMajor); + } + if (n1 > n2) { + return 1; + } else if (n1 == n2) { + return 0; + } else { + return -1; + } +} diff --git a/contrib/tcl/generic/tclPort.h b/contrib/tcl/generic/tclPort.h new file mode 100644 index 0000000000000..2aa27f5d6e2e1 --- /dev/null +++ b/contrib/tcl/generic/tclPort.h @@ -0,0 +1,29 @@ +/* + * tclPort.h -- + * + * This header file handles porting issues that occur because + * of differences between systems. It reads in platform specific + * portability files. + * + * 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: @(#) tclPort.h 1.15 96/02/07 17:24:21 + */ + +#ifndef _TCLPORT +#define _TCLPORT + +#if defined(__WIN32__) || defined(_WIN32) +# include "../win/tclWinPort.h" +#else +# if defined(MAC_TCL) +# include "tclMacPort.h" +# else +# include "../unix/tclUnixPort.h" +# endif +#endif + +#endif /* _TCLPORT */ diff --git a/contrib/tcl/generic/tclPosixStr.c b/contrib/tcl/generic/tclPosixStr.c new file mode 100644 index 0000000000000..9f46ff8c72cb5 --- /dev/null +++ b/contrib/tcl/generic/tclPosixStr.c @@ -0,0 +1,1174 @@ +/* + * tclPosixStr.c -- + * + * This file contains procedures that generate strings + * corresponding to various POSIX-related codes, such + * as errno and signals. + * + * 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: @(#) tclPosixStr.c 1.30 96/02/08 16:33:34 + */ + +#include "tclInt.h" +#include "tclPort.h" + +/* + *---------------------------------------------------------------------- + * + * Tcl_ErrnoId -- + * + * Return a textual identifier for the current errno value. + * + * Results: + * This procedure returns a machine-readable textual identifier + * that corresponds to the current errno value (e.g. "EPERM"). + * The identifier is the same as the #define name in errno.h. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_ErrnoId() +{ + switch (errno) { +#ifdef E2BIG + case E2BIG: return "E2BIG"; +#endif +#ifdef EACCES + case EACCES: return "EACCES"; +#endif +#ifdef EADDRINUSE + case EADDRINUSE: return "EADDRINUSE"; +#endif +#ifdef EADDRNOTAVAIL + case EADDRNOTAVAIL: return "EADDRNOTAVAIL"; +#endif +#ifdef EADV + case EADV: return "EADV"; +#endif +#ifdef EAFNOSUPPORT + case EAFNOSUPPORT: return "EAFNOSUPPORT"; +#endif +#ifdef EAGAIN + case EAGAIN: return "EAGAIN"; +#endif +#ifdef EALIGN + case EALIGN: return "EALIGN"; +#endif +#if defined(EALREADY) && (!defined(EBUSY) || (EALREADY != EBUSY )) + case EALREADY: return "EALREADY"; +#endif +#ifdef EBADE + case EBADE: return "EBADE"; +#endif +#ifdef EBADF + case EBADF: return "EBADF"; +#endif +#ifdef EBADFD + case EBADFD: return "EBADFD"; +#endif +#ifdef EBADMSG + case EBADMSG: return "EBADMSG"; +#endif +#ifdef EBADR + case EBADR: return "EBADR"; +#endif +#ifdef EBADRPC + case EBADRPC: return "EBADRPC"; +#endif +#ifdef EBADRQC + case EBADRQC: return "EBADRQC"; +#endif +#ifdef EBADSLT + case EBADSLT: return "EBADSLT"; +#endif +#ifdef EBFONT + case EBFONT: return "EBFONT"; +#endif +#ifdef EBUSY + case EBUSY: return "EBUSY"; +#endif +#ifdef ECHILD + case ECHILD: return "ECHILD"; +#endif +#ifdef ECHRNG + case ECHRNG: return "ECHRNG"; +#endif +#ifdef ECOMM + case ECOMM: return "ECOMM"; +#endif +#ifdef ECONNABORTED + case ECONNABORTED: return "ECONNABORTED"; +#endif +#ifdef ECONNREFUSED + case ECONNREFUSED: return "ECONNREFUSED"; +#endif +#ifdef ECONNRESET + case ECONNRESET: return "ECONNRESET"; +#endif +#if defined(EDEADLK) && (!defined(EWOULDBLOCK) || (EDEADLK != EWOULDBLOCK)) + case EDEADLK: return "EDEADLK"; +#endif +#ifdef EDEADLOCK + case EDEADLOCK: return "EDEADLOCK"; +#endif +#ifdef EDESTADDRREQ + case EDESTADDRREQ: return "EDESTADDRREQ"; +#endif +#ifdef EDIRTY + case EDIRTY: return "EDIRTY"; +#endif +#ifdef EDOM + case EDOM: return "EDOM"; +#endif +#ifdef EDOTDOT + case EDOTDOT: return "EDOTDOT"; +#endif +#ifdef EDQUOT + case EDQUOT: return "EDQUOT"; +#endif +#ifdef EDUPPKG + case EDUPPKG: return "EDUPPKG"; +#endif +#ifdef EEXIST + case EEXIST: return "EEXIST"; +#endif +#ifdef EFAULT + case EFAULT: return "EFAULT"; +#endif +#ifdef EFBIG + case EFBIG: return "EFBIG"; +#endif +#ifdef EHOSTDOWN + case EHOSTDOWN: return "EHOSTDOWN"; +#endif +#ifdef EHOSTUNREACH + case EHOSTUNREACH: return "EHOSTUNREACH"; +#endif +#if defined(EIDRM) && (!defined(EINPROGRESS) || (EIDRM != EINPROGRESS)) + case EIDRM: return "EIDRM"; +#endif +#ifdef EINIT + case EINIT: return "EINIT"; +#endif +#ifdef EINPROGRESS + case EINPROGRESS: return "EINPROGRESS"; +#endif +#ifdef EINTR + case EINTR: return "EINTR"; +#endif +#ifdef EINVAL + case EINVAL: return "EINVAL"; +#endif +#ifdef EIO + case EIO: return "EIO"; +#endif +#ifdef EISCONN + case EISCONN: return "EISCONN"; +#endif +#ifdef EISDIR + case EISDIR: return "EISDIR"; +#endif +#ifdef EISNAME + case EISNAM: return "EISNAM"; +#endif +#ifdef ELBIN + case ELBIN: return "ELBIN"; +#endif +#ifdef EL2HLT + case EL2HLT: return "EL2HLT"; +#endif +#ifdef EL2NSYNC + case EL2NSYNC: return "EL2NSYNC"; +#endif +#ifdef EL3HLT + case EL3HLT: return "EL3HLT"; +#endif +#ifdef EL3RST + case EL3RST: return "EL3RST"; +#endif +#ifdef ELIBACC + case ELIBACC: return "ELIBACC"; +#endif +#ifdef ELIBBAD + case ELIBBAD: return "ELIBBAD"; +#endif +#ifdef ELIBEXEC + case ELIBEXEC: return "ELIBEXEC"; +#endif +#ifdef ELIBMAX + case ELIBMAX: return "ELIBMAX"; +#endif +#ifdef ELIBSCN + case ELIBSCN: return "ELIBSCN"; +#endif +#ifdef ELNRNG + case ELNRNG: return "ELNRNG"; +#endif +#if defined(ELOOP) && (!defined(ENOENT) || (ELOOP != ENOENT)) + case ELOOP: return "ELOOP"; +#endif +#ifdef EMFILE + case EMFILE: return "EMFILE"; +#endif +#ifdef EMLINK + case EMLINK: return "EMLINK"; +#endif +#ifdef EMSGSIZE + case EMSGSIZE: return "EMSGSIZE"; +#endif +#ifdef EMULTIHOP + case EMULTIHOP: return "EMULTIHOP"; +#endif +#ifdef ENAMETOOLONG + case ENAMETOOLONG: return "ENAMETOOLONG"; +#endif +#ifdef ENAVAIL + case ENAVAIL: return "ENAVAIL"; +#endif +#ifdef ENET + case ENET: return "ENET"; +#endif +#ifdef ENETDOWN + case ENETDOWN: return "ENETDOWN"; +#endif +#ifdef ENETRESET + case ENETRESET: return "ENETRESET"; +#endif +#ifdef ENETUNREACH + case ENETUNREACH: return "ENETUNREACH"; +#endif +#ifdef ENFILE + case ENFILE: return "ENFILE"; +#endif +#ifdef ENOANO + case ENOANO: return "ENOANO"; +#endif +#if defined(ENOBUFS) && (!defined(ENOSR) || (ENOBUFS != ENOSR)) + case ENOBUFS: return "ENOBUFS"; +#endif +#ifdef ENOCSI + case ENOCSI: return "ENOCSI"; +#endif +#if defined(ENODATA) && (!defined(ECONNREFUSED) || (ENODATA != ECONNREFUSED)) + case ENODATA: return "ENODATA"; +#endif +#ifdef ENODEV + case ENODEV: return "ENODEV"; +#endif +#ifdef ENOENT + case ENOENT: return "ENOENT"; +#endif +#ifdef ENOEXEC + case ENOEXEC: return "ENOEXEC"; +#endif +#ifdef ENOLCK + case ENOLCK: return "ENOLCK"; +#endif +#ifdef ENOLINK + case ENOLINK: return "ENOLINK"; +#endif +#ifdef ENOMEM + case ENOMEM: return "ENOMEM"; +#endif +#ifdef ENOMSG + case ENOMSG: return "ENOMSG"; +#endif +#ifdef ENONET + case ENONET: return "ENONET"; +#endif +#ifdef ENOPKG + case ENOPKG: return "ENOPKG"; +#endif +#ifdef ENOPROTOOPT + case ENOPROTOOPT: return "ENOPROTOOPT"; +#endif +#ifdef ENOSPC + case ENOSPC: return "ENOSPC"; +#endif +#if defined(ENOSR) && (!defined(ENAMETOOLONG) || (ENAMETOOLONG != ENOSR)) + case ENOSR: return "ENOSR"; +#endif +#if defined(ENOSTR) && (!defined(ENOTTY) || (ENOTTY != ENOSTR)) + case ENOSTR: return "ENOSTR"; +#endif +#ifdef ENOSYM + case ENOSYM: return "ENOSYM"; +#endif +#ifdef ENOSYS + case ENOSYS: return "ENOSYS"; +#endif +#ifdef ENOTBLK + case ENOTBLK: return "ENOTBLK"; +#endif +#ifdef ENOTCONN + case ENOTCONN: return "ENOTCONN"; +#endif +#ifdef ENOTDIR + case ENOTDIR: return "ENOTDIR"; +#endif +#if defined(ENOTEMPTY) && (!defined(EEXIST) || (ENOTEMPTY != EEXIST)) + case ENOTEMPTY: return "ENOTEMPTY"; +#endif +#ifdef ENOTNAM + case ENOTNAM: return "ENOTNAM"; +#endif +#ifdef ENOTSOCK + case ENOTSOCK: return "ENOTSOCK"; +#endif +#ifdef ENOTSUP + case ENOTSUP: return "ENOTSUP"; +#endif +#ifdef ENOTTY + case ENOTTY: return "ENOTTY"; +#endif +#ifdef ENOTUNIQ + case ENOTUNIQ: return "ENOTUNIQ"; +#endif +#ifdef ENXIO + case ENXIO: return "ENXIO"; +#endif +#ifdef EOPNOTSUPP + case EOPNOTSUPP: return "EOPNOTSUPP"; +#endif +#ifdef EPERM + case EPERM: return "EPERM"; +#endif +#if defined(EPFNOSUPPORT) && (!defined(ENOLCK) || (ENOLCK != EPFNOSUPPORT)) + case EPFNOSUPPORT: return "EPFNOSUPPORT"; +#endif +#ifdef EPIPE + case EPIPE: return "EPIPE"; +#endif +#ifdef EPROCLIM + case EPROCLIM: return "EPROCLIM"; +#endif +#ifdef EPROCUNAVAIL + case EPROCUNAVAIL: return "EPROCUNAVAIL"; +#endif +#ifdef EPROGMISMATCH + case EPROGMISMATCH: return "EPROGMISMATCH"; +#endif +#ifdef EPROGUNAVAIL + case EPROGUNAVAIL: return "EPROGUNAVAIL"; +#endif +#ifdef EPROTO + case EPROTO: return "EPROTO"; +#endif +#ifdef EPROTONOSUPPORT + case EPROTONOSUPPORT: return "EPROTONOSUPPORT"; +#endif +#ifdef EPROTOTYPE + case EPROTOTYPE: return "EPROTOTYPE"; +#endif +#ifdef ERANGE + case ERANGE: return "ERANGE"; +#endif +#if defined(EREFUSED) && (!defined(ECONNREFUSED) || (EREFUSED != ECONNREFUSED)) + case EREFUSED: return "EREFUSED"; +#endif +#ifdef EREMCHG + case EREMCHG: return "EREMCHG"; +#endif +#ifdef EREMDEV + case EREMDEV: return "EREMDEV"; +#endif +#ifdef EREMOTE + case EREMOTE: return "EREMOTE"; +#endif +#ifdef EREMOTEIO + case EREMOTEIO: return "EREMOTEIO"; +#endif +#ifdef EREMOTERELEASE + case EREMOTERELEASE: return "EREMOTERELEASE"; +#endif +#ifdef EROFS + case EROFS: return "EROFS"; +#endif +#ifdef ERPCMISMATCH + case ERPCMISMATCH: return "ERPCMISMATCH"; +#endif +#ifdef ERREMOTE + case ERREMOTE: return "ERREMOTE"; +#endif +#ifdef ESHUTDOWN + case ESHUTDOWN: return "ESHUTDOWN"; +#endif +#ifdef ESOCKTNOSUPPORT + case ESOCKTNOSUPPORT: return "ESOCKTNOSUPPORT"; +#endif +#ifdef ESPIPE + case ESPIPE: return "ESPIPE"; +#endif +#ifdef ESRCH + case ESRCH: return "ESRCH"; +#endif +#ifdef ESRMNT + case ESRMNT: return "ESRMNT"; +#endif +#ifdef ESTALE + case ESTALE: return "ESTALE"; +#endif +#ifdef ESUCCESS + case ESUCCESS: return "ESUCCESS"; +#endif +#if defined(ETIME) && (!defined(ELOOP) || (ETIME != ELOOP)) + case ETIME: return "ETIME"; +#endif +#if defined(ETIMEDOUT) && (!defined(ENOSTR) || (ETIMEDOUT != ENOSTR)) + case ETIMEDOUT: return "ETIMEDOUT"; +#endif +#ifdef ETOOMANYREFS + case ETOOMANYREFS: return "ETOOMANYREFS"; +#endif +#ifdef ETXTBSY + case ETXTBSY: return "ETXTBSY"; +#endif +#ifdef EUCLEAN + case EUCLEAN: return "EUCLEAN"; +#endif +#ifdef EUNATCH + case EUNATCH: return "EUNATCH"; +#endif +#ifdef EUSERS + case EUSERS: return "EUSERS"; +#endif +#ifdef EVERSION + case EVERSION: return "EVERSION"; +#endif +#if defined(EWOULDBLOCK) && (!defined(EAGAIN) || (EWOULDBLOCK != EAGAIN)) + case EWOULDBLOCK: return "EWOULDBLOCK"; +#endif +#ifdef EXDEV + case EXDEV: return "EXDEV"; +#endif +#ifdef EXFULL + case EXFULL: return "EXFULL"; +#endif + } + return "unknown error"; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ErrnoMsg -- + * + * Return a human-readable message corresponding to a given + * errno value. + * + * Results: + * The return value is the standard POSIX error message for + * errno. This procedure is used instead of strerror because + * strerror returns slightly different values on different + * machines (e.g. different capitalizations), which cause + * problems for things such as regression tests. This procedure + * provides messages for most standard errors, then it calls + * strerror for things it doesn't understand. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_ErrnoMsg(err) + int err; /* Error number (such as in errno variable). */ +{ + switch (err) { +#ifdef E2BIG + case E2BIG: return "argument list too long"; +#endif +#ifdef EACCES + case EACCES: return "permission denied"; +#endif +#ifdef EADDRINUSE + case EADDRINUSE: return "address already in use"; +#endif +#ifdef EADDRNOTAVAIL + case EADDRNOTAVAIL: return "can't assign requested address"; +#endif +#ifdef EADV + case EADV: return "advertise error"; +#endif +#ifdef EAFNOSUPPORT + case EAFNOSUPPORT: return "address family not supported by protocol family"; +#endif +#ifdef EAGAIN + case EAGAIN: return "resource temporarily unavailable"; +#endif +#ifdef EALIGN + case EALIGN: return "EALIGN"; +#endif +#if defined(EALREADY) && (!defined(EBUSY) || (EALREADY != EBUSY )) + case EALREADY: return "operation already in progress"; +#endif +#ifdef EBADE + case EBADE: return "bad exchange descriptor"; +#endif +#ifdef EBADF + case EBADF: return "bad file number"; +#endif +#ifdef EBADFD + case EBADFD: return "file descriptor in bad state"; +#endif +#ifdef EBADMSG + case EBADMSG: return "not a data message"; +#endif +#ifdef EBADR + case EBADR: return "bad request descriptor"; +#endif +#ifdef EBADRPC + case EBADRPC: return "RPC structure is bad"; +#endif +#ifdef EBADRQC + case EBADRQC: return "bad request code"; +#endif +#ifdef EBADSLT + case EBADSLT: return "invalid slot"; +#endif +#ifdef EBFONT + case EBFONT: return "bad font file format"; +#endif +#ifdef EBUSY + case EBUSY: return "mount device busy"; +#endif +#ifdef ECHILD + case ECHILD: return "no children"; +#endif +#ifdef ECHRNG + case ECHRNG: return "channel number out of range"; +#endif +#ifdef ECOMM + case ECOMM: return "communication error on send"; +#endif +#ifdef ECONNABORTED + case ECONNABORTED: return "software caused connection abort"; +#endif +#ifdef ECONNREFUSED + case ECONNREFUSED: return "connection refused"; +#endif +#ifdef ECONNRESET + case ECONNRESET: return "connection reset by peer"; +#endif +#if defined(EDEADLK) && (!defined(EWOULDBLOCK) || (EDEADLK != EWOULDBLOCK)) + case EDEADLK: return "resource deadlock avoided"; +#endif +#ifdef EDEADLOCK + case EDEADLOCK: return "resource deadlock avoided"; +#endif +#ifdef EDESTADDRREQ + case EDESTADDRREQ: return "destination address required"; +#endif +#ifdef EDIRTY + case EDIRTY: return "mounting a dirty fs w/o force"; +#endif +#ifdef EDOM + case EDOM: return "math argument out of range"; +#endif +#ifdef EDOTDOT + case EDOTDOT: return "cross mount point"; +#endif +#ifdef EDQUOT + case EDQUOT: return "disk quota exceeded"; +#endif +#ifdef EDUPPKG + case EDUPPKG: return "duplicate package name"; +#endif +#ifdef EEXIST + case EEXIST: return "file already exists"; +#endif +#ifdef EFAULT + case EFAULT: return "bad address in system call argument"; +#endif +#ifdef EFBIG + case EFBIG: return "file too large"; +#endif +#ifdef EHOSTDOWN + case EHOSTDOWN: return "host is down"; +#endif +#ifdef EHOSTUNREACH + case EHOSTUNREACH: return "host is unreachable"; +#endif +#if defined(EIDRM) && (!defined(EINPROGRESS) || (EIDRM != EINPROGRESS)) + case EIDRM: return "identifier removed"; +#endif +#ifdef EINIT + case EINIT: return "initialization error"; +#endif +#ifdef EINPROGRESS + case EINPROGRESS: return "operation now in progress"; +#endif +#ifdef EINTR + case EINTR: return "interrupted system call"; +#endif +#ifdef EINVAL + case EINVAL: return "invalid argument"; +#endif +#ifdef EIO + case EIO: return "I/O error"; +#endif +#ifdef EISCONN + case EISCONN: return "socket is already connected"; +#endif +#ifdef EISDIR + case EISDIR: return "illegal operation on a directory"; +#endif +#ifdef EISNAME + case EISNAM: return "is a name file"; +#endif +#ifdef ELBIN + case ELBIN: return "ELBIN"; +#endif +#ifdef EL2HLT + case EL2HLT: return "level 2 halted"; +#endif +#ifdef EL2NSYNC + case EL2NSYNC: return "level 2 not synchronized"; +#endif +#ifdef EL3HLT + case EL3HLT: return "level 3 halted"; +#endif +#ifdef EL3RST + case EL3RST: return "level 3 reset"; +#endif +#ifdef ELIBACC + case ELIBACC: return "can not access a needed shared library"; +#endif +#ifdef ELIBBAD + case ELIBBAD: return "accessing a corrupted shared library"; +#endif +#ifdef ELIBEXEC + case ELIBEXEC: return "can not exec a shared library directly"; +#endif +#ifdef ELIBMAX + case ELIBMAX: return + "attempting to link in more shared libraries than system limit"; +#endif +#ifdef ELIBSCN + case ELIBSCN: return ".lib section in a.out corrupted"; +#endif +#ifdef ELNRNG + case ELNRNG: return "link number out of range"; +#endif +#if defined(ELOOP) && (!defined(ENOENT) || (ELOOP != ENOENT)) + case ELOOP: return "too many levels of symbolic links"; +#endif +#ifdef EMFILE + case EMFILE: return "too many open files"; +#endif +#ifdef EMLINK + case EMLINK: return "too many links"; +#endif +#ifdef EMSGSIZE + case EMSGSIZE: return "message too long"; +#endif +#ifdef EMULTIHOP + case EMULTIHOP: return "multihop attempted"; +#endif +#ifdef ENAMETOOLONG + case ENAMETOOLONG: return "file name too long"; +#endif +#ifdef ENAVAIL + case ENAVAIL: return "not available"; +#endif +#ifdef ENET + case ENET: return "ENET"; +#endif +#ifdef ENETDOWN + case ENETDOWN: return "network is down"; +#endif +#ifdef ENETRESET + case ENETRESET: return "network dropped connection on reset"; +#endif +#ifdef ENETUNREACH + case ENETUNREACH: return "network is unreachable"; +#endif +#ifdef ENFILE + case ENFILE: return "file table overflow"; +#endif +#ifdef ENOANO + case ENOANO: return "anode table overflow"; +#endif +#if defined(ENOBUFS) && (!defined(ENOSR) || (ENOBUFS != ENOSR)) + case ENOBUFS: return "no buffer space available"; +#endif +#ifdef ENOCSI + case ENOCSI: return "no CSI structure available"; +#endif +#if defined(ENODATA) && (!defined(ECONNREFUSED) || (ENODATA != ECONNREFUSED)) + case ENODATA: return "no data available"; +#endif +#ifdef ENODEV + case ENODEV: return "no such device"; +#endif +#ifdef ENOENT + case ENOENT: return "no such file or directory"; +#endif +#ifdef ENOEXEC + case ENOEXEC: return "exec format error"; +#endif +#ifdef ENOLCK + case ENOLCK: return "no locks available"; +#endif +#ifdef ENOLINK + case ENOLINK: return "link has be severed"; +#endif +#ifdef ENOMEM + case ENOMEM: return "not enough memory"; +#endif +#ifdef ENOMSG + case ENOMSG: return "no message of desired type"; +#endif +#ifdef ENONET + case ENONET: return "machine is not on the network"; +#endif +#ifdef ENOPKG + case ENOPKG: return "package not installed"; +#endif +#ifdef ENOPROTOOPT + case ENOPROTOOPT: return "bad proocol option"; +#endif +#ifdef ENOSPC + case ENOSPC: return "no space left on device"; +#endif +#if defined(ENOSR) && (!defined(ENAMETOOLONG) || (ENAMETOOLONG != ENOSR)) + case ENOSR: return "out of stream resources"; +#endif +#if defined(ENOSTR) && (!defined(ENOTTY) || (ENOTTY != ENOSTR)) + case ENOSTR: return "not a stream device"; +#endif +#ifdef ENOSYM + case ENOSYM: return "unresolved symbol name"; +#endif +#ifdef ENOSYS + case ENOSYS: return "function not implemented"; +#endif +#ifdef ENOTBLK + case ENOTBLK: return "block device required"; +#endif +#ifdef ENOTCONN + case ENOTCONN: return "socket is not connected"; +#endif +#ifdef ENOTDIR + case ENOTDIR: return "not a directory"; +#endif +#if defined(ENOTEMPTY) && (!defined(EEXIST) || (ENOTEMPTY != EEXIST)) + case ENOTEMPTY: return "directory not empty"; +#endif +#ifdef ENOTNAM + case ENOTNAM: return "not a name file"; +#endif +#ifdef ENOTSOCK + case ENOTSOCK: return "socket operation on non-socket"; +#endif +#ifdef ENOTSUP + case ENOTSUP: return "operation not supported"; +#endif +#ifdef ENOTTY + case ENOTTY: return "inappropriate device for ioctl"; +#endif +#ifdef ENOTUNIQ + case ENOTUNIQ: return "name not unique on network"; +#endif +#ifdef ENXIO + case ENXIO: return "no such device or address"; +#endif +#ifdef EOPNOTSUPP + case EOPNOTSUPP: return "operation not supported on socket"; +#endif +#ifdef EPERM + case EPERM: return "not owner"; +#endif +#if defined(EPFNOSUPPORT) && (!defined(ENOLCK) || (ENOLCK != EPFNOSUPPORT)) + case EPFNOSUPPORT: return "protocol family not supported"; +#endif +#ifdef EPIPE + case EPIPE: return "broken pipe"; +#endif +#ifdef EPROCLIM + case EPROCLIM: return "too many processes"; +#endif +#ifdef EPROCUNAVAIL + case EPROCUNAVAIL: return "bad procedure for program"; +#endif +#ifdef EPROGMISMATCH + case EPROGMISMATCH: return "program version wrong"; +#endif +#ifdef EPROGUNAVAIL + case EPROGUNAVAIL: return "RPC program not available"; +#endif +#ifdef EPROTO + case EPROTO: return "protocol error"; +#endif +#ifdef EPROTONOSUPPORT + case EPROTONOSUPPORT: return "protocol not suppored"; +#endif +#ifdef EPROTOTYPE + case EPROTOTYPE: return "protocol wrong type for socket"; +#endif +#ifdef ERANGE + case ERANGE: return "math result unrepresentable"; +#endif +#if defined(EREFUSED) && (!defined(ECONNREFUSED) || (EREFUSED != ECONNREFUSED)) + case EREFUSED: return "EREFUSED"; +#endif +#ifdef EREMCHG + case EREMCHG: return "remote address changed"; +#endif +#ifdef EREMDEV + case EREMDEV: return "remote device"; +#endif +#ifdef EREMOTE + case EREMOTE: return "pathname hit remote file system"; +#endif +#ifdef EREMOTEIO + case EREMOTEIO: return "remote i/o error"; +#endif +#ifdef EREMOTERELEASE + case EREMOTERELEASE: return "EREMOTERELEASE"; +#endif +#ifdef EROFS + case EROFS: return "read-only file system"; +#endif +#ifdef ERPCMISMATCH + case ERPCMISMATCH: return "RPC version is wrong"; +#endif +#ifdef ERREMOTE + case ERREMOTE: return "object is remote"; +#endif +#ifdef ESHUTDOWN + case ESHUTDOWN: return "can't send afer socket shutdown"; +#endif +#ifdef ESOCKTNOSUPPORT + case ESOCKTNOSUPPORT: return "socket type not supported"; +#endif +#ifdef ESPIPE + case ESPIPE: return "invalid seek"; +#endif +#ifdef ESRCH + case ESRCH: return "no such process"; +#endif +#ifdef ESRMNT + case ESRMNT: return "srmount error"; +#endif +#ifdef ESTALE + case ESTALE: return "stale remote file handle"; +#endif +#ifdef ESUCCESS + case ESUCCESS: return "Error 0"; +#endif +#if defined(ETIME) && (!defined(ELOOP) || (ETIME != ELOOP)) + case ETIME: return "timer expired"; +#endif +#if defined(ETIMEDOUT) && (!defined(ENOSTR) || (ETIMEDOUT != ENOSTR)) + case ETIMEDOUT: return "connection timed out"; +#endif +#ifdef ETOOMANYREFS + case ETOOMANYREFS: return "too many references: can't splice"; +#endif +#ifdef ETXTBSY + case ETXTBSY: return "text file or pseudo-device busy"; +#endif +#ifdef EUCLEAN + case EUCLEAN: return "structure needs cleaning"; +#endif +#ifdef EUNATCH + case EUNATCH: return "protocol driver not attached"; +#endif +#ifdef EUSERS + case EUSERS: return "too many users"; +#endif +#ifdef EVERSION + case EVERSION: return "version mismatch"; +#endif +#if defined(EWOULDBLOCK) && (!defined(EAGAIN) || (EWOULDBLOCK != EAGAIN)) + case EWOULDBLOCK: return "operation would block"; +#endif +#ifdef EXDEV + case EXDEV: return "cross-domain link"; +#endif +#ifdef EXFULL + case EXFULL: return "message tables full"; +#endif + default: +#ifdef NO_STRERROR + return "unknown POSIX error"; +#else + return strerror(errno); +#endif + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SignalId -- + * + * Return a textual identifier for a signal number. + * + * Results: + * This procedure returns a machine-readable textual identifier + * that corresponds to sig. The identifier is the same as the + * #define name in signal.h. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_SignalId(sig) + int sig; /* Number of signal. */ +{ + switch (sig) { +#ifdef SIGABRT + case SIGABRT: return "SIGABRT"; +#endif +#ifdef SIGALRM + case SIGALRM: return "SIGALRM"; +#endif +#ifdef SIGBUS + case SIGBUS: return "SIGBUS"; +#endif +#ifdef SIGCHLD + case SIGCHLD: return "SIGCHLD"; +#endif +#if defined(SIGCLD) && (!defined(SIGCHLD) || (SIGCLD != SIGCHLD)) + case SIGCLD: return "SIGCLD"; +#endif +#ifdef SIGCONT + case SIGCONT: return "SIGCONT"; +#endif +#if defined(SIGEMT) && (!defined(SIGXCPU) || (SIGEMT != SIGXCPU)) + case SIGEMT: return "SIGEMT"; +#endif +#ifdef SIGFPE + case SIGFPE: return "SIGFPE"; +#endif +#ifdef SIGHUP + case SIGHUP: return "SIGHUP"; +#endif +#ifdef SIGILL + case SIGILL: return "SIGILL"; +#endif +#ifdef SIGINT + case SIGINT: return "SIGINT"; +#endif +#ifdef SIGIO + case SIGIO: return "SIGIO"; +#endif +#if defined(SIGIOT) && (!defined(SIGABRT) || (SIGIOT != SIGABRT)) + case SIGIOT: return "SIGIOT"; +#endif +#ifdef SIGKILL + case SIGKILL: return "SIGKILL"; +#endif +#if defined(SIGLOST) && (!defined(SIGIOT) || (SIGLOST != SIGIOT)) && (!defined(SIGURG) || (SIGLOST != SIGURG)) && (!defined(SIGPROF) || (SIGLOST != SIGPROF)) + case SIGLOST: return "SIGLOST"; +#endif +#ifdef SIGPIPE + case SIGPIPE: return "SIGPIPE"; +#endif +#if defined(SIGPOLL) && (!defined(SIGIO) || (SIGPOLL != SIGIO)) + case SIGPOLL: return "SIGPOLL"; +#endif +#ifdef SIGPROF + case SIGPROF: return "SIGPROF"; +#endif +#if defined(SIGPWR) && (!defined(SIGXFSZ) || (SIGPWR != SIGXFSZ)) + case SIGPWR: return "SIGPWR"; +#endif +#ifdef SIGQUIT + case SIGQUIT: return "SIGQUIT"; +#endif +#ifdef SIGSEGV + case SIGSEGV: return "SIGSEGV"; +#endif +#ifdef SIGSTOP + case SIGSTOP: return "SIGSTOP"; +#endif +#ifdef SIGSYS + case SIGSYS: return "SIGSYS"; +#endif +#ifdef SIGTERM + case SIGTERM: return "SIGTERM"; +#endif +#ifdef SIGTRAP + case SIGTRAP: return "SIGTRAP"; +#endif +#ifdef SIGTSTP + case SIGTSTP: return "SIGTSTP"; +#endif +#ifdef SIGTTIN + case SIGTTIN: return "SIGTTIN"; +#endif +#ifdef SIGTTOU + case SIGTTOU: return "SIGTTOU"; +#endif +#if defined(SIGURG) && (!defined(SIGIO) || (SIGURG != SIGIO)) + case SIGURG: return "SIGURG"; +#endif +#if defined(SIGUSR1) && (!defined(SIGIO) || (SIGUSR1 != SIGIO)) + case SIGUSR1: return "SIGUSR1"; +#endif +#if defined(SIGUSR2) && (!defined(SIGURG) || (SIGUSR2 != SIGURG)) + case SIGUSR2: return "SIGUSR2"; +#endif +#ifdef SIGVTALRM + case SIGVTALRM: return "SIGVTALRM"; +#endif +#ifdef SIGWINCH + case SIGWINCH: return "SIGWINCH"; +#endif +#ifdef SIGXCPU + case SIGXCPU: return "SIGXCPU"; +#endif +#ifdef SIGXFSZ + case SIGXFSZ: return "SIGXFSZ"; +#endif + } + return "unknown signal"; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SignalMsg -- + * + * Return a human-readable message describing a signal. + * + * Results: + * This procedure returns a string describing sig that should + * make sense to a human. It may not be easy for a machine + * to parse. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_SignalMsg(sig) + int sig; /* Number of signal. */ +{ + switch (sig) { +#ifdef SIGABRT + case SIGABRT: return "SIGABRT"; +#endif +#ifdef SIGALRM + case SIGALRM: return "alarm clock"; +#endif +#ifdef SIGBUS + case SIGBUS: return "bus error"; +#endif +#ifdef SIGCHLD + case SIGCHLD: return "child status changed"; +#endif +#if defined(SIGCLD) && (!defined(SIGCHLD) || (SIGCLD != SIGCHLD)) + case SIGCLD: return "child status changed"; +#endif +#ifdef SIGCONT + case SIGCONT: return "continue after stop"; +#endif +#if defined(SIGEMT) && (!defined(SIGXCPU) || (SIGEMT != SIGXCPU)) + case SIGEMT: return "EMT instruction"; +#endif +#ifdef SIGFPE + case SIGFPE: return "floating-point exception"; +#endif +#ifdef SIGHUP + case SIGHUP: return "hangup"; +#endif +#ifdef SIGILL + case SIGILL: return "illegal instruction"; +#endif +#ifdef SIGINT + case SIGINT: return "interrupt"; +#endif +#ifdef SIGIO + case SIGIO: return "input/output possible on file"; +#endif +#if defined(SIGIOT) && (!defined(SIGABRT) || (SIGABRT != SIGIOT)) + case SIGIOT: return "IOT instruction"; +#endif +#ifdef SIGKILL + case SIGKILL: return "kill signal"; +#endif +#if defined(SIGLOST) && (!defined(SIGIOT) || (SIGLOST != SIGIOT)) && (!defined(SIGURG) || (SIGLOST != SIGURG)) + case SIGLOST: return "resource lost"; +#endif +#ifdef SIGPIPE + case SIGPIPE: return "write on pipe with no readers"; +#endif +#if defined(SIGPOLL) && (!defined(SIGIO) || (SIGPOLL != SIGIO)) + case SIGPOLL: return "input/output possible on file"; +#endif +#ifdef SIGPROF + case SIGPROF: return "profiling alarm"; +#endif +#if defined(SIGPWR) && (!defined(SIGXFSZ) || (SIGPWR != SIGXFSZ)) + case SIGPWR: return "power-fail restart"; +#endif +#ifdef SIGQUIT + case SIGQUIT: return "quit signal"; +#endif +#ifdef SIGSEGV + case SIGSEGV: return "segmentation violation"; +#endif +#ifdef SIGSTOP + case SIGSTOP: return "stop"; +#endif +#ifdef SIGSYS + case SIGSYS: return "bad argument to system call"; +#endif +#ifdef SIGTERM + case SIGTERM: return "software termination signal"; +#endif +#ifdef SIGTRAP + case SIGTRAP: return "trace trap"; +#endif +#ifdef SIGTSTP + case SIGTSTP: return "stop signal from tty"; +#endif +#ifdef SIGTTIN + case SIGTTIN: return "background tty read"; +#endif +#ifdef SIGTTOU + case SIGTTOU: return "background tty write"; +#endif +#if defined(SIGURG) && (!defined(SIGIO) || (SIGURG != SIGIO)) + case SIGURG: return "urgent I/O condition"; +#endif +#if defined(SIGUSR1) && (!defined(SIGIO) || (SIGUSR1 != SIGIO)) + case SIGUSR1: return "user-defined signal 1"; +#endif +#if defined(SIGUSR2) && (!defined(SIGURG) || (SIGUSR2 != SIGURG)) + case SIGUSR2: return "user-defined signal 2"; +#endif +#ifdef SIGVTALRM + case SIGVTALRM: return "virtual time alarm"; +#endif +#ifdef SIGWINCH + case SIGWINCH: return "window changed"; +#endif +#ifdef SIGXCPU + case SIGXCPU: return "exceeded CPU time limit"; +#endif +#ifdef SIGXFSZ + case SIGXFSZ: return "exceeded file size limit"; +#endif + } + return "unknown signal"; +} diff --git a/contrib/tcl/generic/tclPreserve.c b/contrib/tcl/generic/tclPreserve.c new file mode 100644 index 0000000000000..714fb54cd12ab --- /dev/null +++ b/contrib/tcl/generic/tclPreserve.c @@ -0,0 +1,275 @@ +/* + * tclPreserve.c -- + * + * This file contains a collection of procedures that are used + * to make sure that widget records and other data structures + * aren't reallocated when there are nested procedures that + * depend on their existence. + * + * Copyright (c) 1991-1994 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclPreserve.c 1.14 96/03/20 08:24:37 + */ + +#include "tclInt.h" + +/* + * The following data structure is used to keep track of all the + * Tcl_Preserve calls that are still in effect. It grows as needed + * to accommodate any number of calls in effect. + */ + +typedef struct { + ClientData clientData; /* Address of preserved block. */ + int refCount; /* Number of Tcl_Preserve calls in effect + * for block. */ + int mustFree; /* Non-zero means Tcl_EventuallyFree was + * called while a Tcl_Preserve call was in + * effect, so the structure must be freed + * when refCount becomes zero. */ + Tcl_FreeProc *freeProc; /* Procedure to call to free. */ +} Reference; + +static Reference *refArray; /* First in array of references. */ +static int spaceAvl = 0; /* Total number of structures available + * at *firstRefPtr. */ +static int inUse = 0; /* Count of structures currently in use + * in refArray. */ +#define INITIAL_SIZE 2 + +/* + * Static routines in this file: + */ + +static void PreserveExitProc _ANSI_ARGS_((ClientData clientData)); + + +/* + *---------------------------------------------------------------------- + * + * PreserveExitProc -- + * + * Called during exit processing to clean up the reference array. + * + * Results: + * None. + * + * Side effects: + * Frees the storage of the reference array. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static void +PreserveExitProc(clientData) + ClientData clientData; /* NULL -Unused. */ +{ + if (spaceAvl != 0) { + ckfree((char *) refArray); + refArray = (Reference *) NULL; + inUse = 0; + spaceAvl = 0; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_Preserve -- + * + * This procedure is used by a procedure to declare its interest + * in a particular block of memory, so that the block will not be + * reallocated until a matching call to Tcl_Release has been made. + * + * Results: + * None. + * + * Side effects: + * Information is retained so that the block of memory will + * not be freed until at least the matching call to Tcl_Release. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_Preserve(clientData) + ClientData clientData; /* Pointer to malloc'ed block of memory. */ +{ + Reference *refPtr; + int i; + + /* + * See if there is already a reference for this pointer. If so, + * just increment its reference count. + */ + + for (i = 0, refPtr = refArray; i < inUse; i++, refPtr++) { + if (refPtr->clientData == clientData) { + refPtr->refCount++; + return; + } + } + + /* + * Make a reference array if it doesn't already exist, or make it + * bigger if it is full. + */ + + if (inUse == spaceAvl) { + if (spaceAvl == 0) { + Tcl_CreateExitHandler((Tcl_ExitProc *) PreserveExitProc, + (ClientData) NULL); + refArray = (Reference *) ckalloc((unsigned) + (INITIAL_SIZE*sizeof(Reference))); + spaceAvl = INITIAL_SIZE; + } else { + Reference *new; + + new = (Reference *) ckalloc((unsigned) + (2*spaceAvl*sizeof(Reference))); + memcpy((VOID *) new, (VOID *) refArray, + spaceAvl*sizeof(Reference)); + ckfree((char *) refArray); + refArray = new; + spaceAvl *= 2; + } + } + + /* + * Make a new entry for the new reference. + */ + + refPtr = &refArray[inUse]; + refPtr->clientData = clientData; + refPtr->refCount = 1; + refPtr->mustFree = 0; + inUse += 1; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_Release -- + * + * This procedure is called to cancel a previous call to + * Tcl_Preserve, thereby allowing a block of memory to be + * freed (if no one else cares about it). + * + * Results: + * None. + * + * Side effects: + * If Tcl_EventuallyFree has been called for clientData, and if + * no other call to Tcl_Preserve is still in effect, the block of + * memory is freed. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_Release(clientData) + ClientData clientData; /* Pointer to malloc'ed block of memory. */ +{ + Reference *refPtr; + int mustFree; + Tcl_FreeProc *freeProc; + int i; + + for (i = 0, refPtr = refArray; i < inUse; i++, refPtr++) { + if (refPtr->clientData != clientData) { + continue; + } + refPtr->refCount--; + if (refPtr->refCount == 0) { + + /* + * Must remove information from the slot before calling freeProc + * to avoid reentrancy problems if the freeProc calls Tcl_Preserve + * on the same clientData. Copy down the last reference in the + * array to overwrite the current slot. + */ + + freeProc = refPtr->freeProc; + mustFree = refPtr->mustFree; + inUse--; + if (i < inUse) { + refArray[i] = refArray[inUse]; + } + if (mustFree) { + if ((freeProc == TCL_DYNAMIC) || + (freeProc == (Tcl_FreeProc *) free)) { + ckfree((char *) clientData); + } else { + (*freeProc)((char *) clientData); + } + } + } + return; + } + + /* + * Reference not found. This is a bug in the caller. + */ + + panic("Tcl_Release couldn't find reference for 0x%x", clientData); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_EventuallyFree -- + * + * Free up a block of memory, unless a call to Tcl_Preserve is in + * effect for that block. In this case, defer the free until all + * calls to Tcl_Preserve have been undone by matching calls to + * Tcl_Release. + * + * Results: + * None. + * + * Side effects: + * Ptr may be released by calling free(). + * + *---------------------------------------------------------------------- + */ + +void +Tcl_EventuallyFree(clientData, freeProc) + ClientData clientData; /* Pointer to malloc'ed block of memory. */ + Tcl_FreeProc *freeProc; /* Procedure to actually do free. */ +{ + Reference *refPtr; + int i; + + /* + * See if there is a reference for this pointer. If so, set its + * "mustFree" flag (the flag had better not be set already!). + */ + + for (i = 0, refPtr = refArray; i < inUse; i++, refPtr++) { + if (refPtr->clientData != clientData) { + continue; + } + if (refPtr->mustFree) { + panic("Tcl_EventuallyFree called twice for 0x%x\n", clientData); + } + refPtr->mustFree = 1; + refPtr->freeProc = freeProc; + return; + } + + /* + * No reference for this block. Free it now. + */ + + if ((freeProc == TCL_DYNAMIC) || (freeProc == (Tcl_FreeProc *) free)) { + ckfree((char *) clientData); + } else { + (*freeProc)((char *)clientData); + } +} diff --git a/contrib/tcl/generic/tclProc.c b/contrib/tcl/generic/tclProc.c new file mode 100644 index 0000000000000..0b34e23bdf0b9 --- /dev/null +++ b/contrib/tcl/generic/tclProc.c @@ -0,0 +1,658 @@ +/* + * tclProc.c -- + * + * This file contains routines that implement Tcl procedures, + * including the "proc" and "uplevel" commands. + * + * Copyright (c) 1987-1993 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclProc.c 1.72 96/02/15 11:42:48 + */ + +#include "tclInt.h" + +/* + * Forward references to procedures defined later in this file: + */ + +static void CleanupProc _ANSI_ARGS_((Proc *procPtr)); +static int InterpProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +static void ProcDeleteProc _ANSI_ARGS_((ClientData clientData)); + +/* + *---------------------------------------------------------------------- + * + * Tcl_ProcCmd -- + * + * This procedure is invoked to process the "proc" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result value. + * + * Side effects: + * A new procedure gets created. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_ProcCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + register Interp *iPtr = (Interp *) interp; + register Proc *procPtr; + int result, argCount, i; + char **argArray = NULL; + Arg *lastArgPtr; + register Arg *argPtr = NULL; /* Initialization not needed, but + * prevents compiler warning. */ + + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " name args body\"", (char *) NULL); + return TCL_ERROR; + } + + procPtr = (Proc *) ckalloc(sizeof(Proc)); + procPtr->iPtr = iPtr; + procPtr->refCount = 1; + procPtr->command = (char *) ckalloc((unsigned) strlen(argv[3]) + 1); + strcpy(procPtr->command, argv[3]); + procPtr->argPtr = NULL; + + /* + * Break up the argument list into argument specifiers, then process + * each argument specifier. + */ + + result = Tcl_SplitList(interp, argv[2], &argCount, &argArray); + if (result != TCL_OK) { + goto procError; + } + lastArgPtr = NULL; + for (i = 0; i < argCount; i++) { + int fieldCount, nameLength, valueLength; + char **fieldValues; + + /* + * Now divide the specifier up into name and default. + */ + + result = Tcl_SplitList(interp, argArray[i], &fieldCount, + &fieldValues); + if (result != TCL_OK) { + goto procError; + } + if (fieldCount > 2) { + ckfree((char *) fieldValues); + Tcl_AppendResult(interp, + "too many fields in argument specifier \"", + argArray[i], "\"", (char *) NULL); + result = TCL_ERROR; + goto procError; + } + if ((fieldCount == 0) || (*fieldValues[0] == 0)) { + ckfree((char *) fieldValues); + Tcl_AppendResult(interp, "procedure \"", argv[1], + "\" has argument with no name", (char *) NULL); + result = TCL_ERROR; + goto procError; + } + nameLength = strlen(fieldValues[0]) + 1; + if (fieldCount == 2) { + valueLength = strlen(fieldValues[1]) + 1; + } else { + valueLength = 0; + } + argPtr = (Arg *) ckalloc((unsigned) + (sizeof(Arg) - sizeof(argPtr->name) + nameLength + + valueLength)); + if (lastArgPtr == NULL) { + procPtr->argPtr = argPtr; + } else { + lastArgPtr->nextPtr = argPtr; + } + lastArgPtr = argPtr; + argPtr->nextPtr = NULL; + strcpy(argPtr->name, fieldValues[0]); + if (fieldCount == 2) { + argPtr->defValue = argPtr->name + nameLength; + strcpy(argPtr->defValue, fieldValues[1]); + } else { + argPtr->defValue = NULL; + } + ckfree((char *) fieldValues); + } + + Tcl_CreateCommand(interp, argv[1], InterpProc, (ClientData) procPtr, + ProcDeleteProc); + ckfree((char *) argArray); + return TCL_OK; + + procError: + ckfree(procPtr->command); + while (procPtr->argPtr != NULL) { + argPtr = procPtr->argPtr; + procPtr->argPtr = argPtr->nextPtr; + ckfree((char *) argPtr); + } + ckfree((char *) procPtr); + if (argArray != NULL) { + ckfree((char *) argArray); + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TclGetFrame -- + * + * Given a description of a procedure frame, such as the first + * argument to an "uplevel" or "upvar" command, locate the + * call frame for the appropriate level of procedure. + * + * Results: + * The return value is -1 if an error occurred in finding the + * frame (in this case an error message is left in interp->result). + * 1 is returned if string was either a number or a number preceded + * by "#" and it specified a valid frame. 0 is returned if string + * isn't one of the two things above (in this case, the lookup + * acts as if string were "1"). The variable pointed to by + * framePtrPtr is filled in with the address of the desired frame + * (unless an error occurs, in which case it isn't modified). + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclGetFrame(interp, string, framePtrPtr) + Tcl_Interp *interp; /* Interpreter in which to find frame. */ + char *string; /* String describing frame. */ + CallFrame **framePtrPtr; /* Store pointer to frame here (or NULL + * if global frame indicated). */ +{ + register Interp *iPtr = (Interp *) interp; + int curLevel, level, result; + CallFrame *framePtr; + + /* + * Parse string to figure out which level number to go to. + */ + + result = 1; + curLevel = (iPtr->varFramePtr == NULL) ? 0 : iPtr->varFramePtr->level; + if (*string == '#') { + if (Tcl_GetInt(interp, string+1, &level) != TCL_OK) { + return -1; + } + if (level < 0) { + levelError: + Tcl_AppendResult(interp, "bad level \"", string, "\"", + (char *) NULL); + return -1; + } + } else if (isdigit(UCHAR(*string))) { + if (Tcl_GetInt(interp, string, &level) != TCL_OK) { + return -1; + } + level = curLevel - level; + } else { + level = curLevel - 1; + result = 0; + } + + /* + * Figure out which frame to use, and modify the interpreter so + * its variables come from that frame. + */ + + if (level == 0) { + framePtr = NULL; + } else { + for (framePtr = iPtr->varFramePtr; framePtr != NULL; + framePtr = framePtr->callerVarPtr) { + if (framePtr->level == level) { + break; + } + } + if (framePtr == NULL) { + goto levelError; + } + } + *framePtrPtr = framePtr; + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_UplevelCmd -- + * + * This procedure is invoked to process the "uplevel" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result value. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_UplevelCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + register Interp *iPtr = (Interp *) interp; + int result; + CallFrame *savedVarFramePtr, *framePtr; + + if (argc < 2) { + uplevelSyntax: + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " ?level? command ?arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + + /* + * Find the level to use for executing the command. + */ + + result = TclGetFrame(interp, argv[1], &framePtr); + if (result == -1) { + return TCL_ERROR; + } + argc -= (result+1); + if (argc == 0) { + goto uplevelSyntax; + } + argv += (result+1); + + /* + * Modify the interpreter state to execute in the given frame. + */ + + savedVarFramePtr = iPtr->varFramePtr; + iPtr->varFramePtr = framePtr; + + /* + * Execute the residual arguments as a command. + */ + + if (argc == 1) { + result = Tcl_Eval(interp, argv[0]); + } else { + char *cmd; + + cmd = Tcl_Concat(argc, argv); + result = Tcl_Eval(interp, cmd); + ckfree(cmd); + } + if (result == TCL_ERROR) { + char msg[60]; + sprintf(msg, "\n (\"uplevel\" body line %d)", interp->errorLine); + Tcl_AddErrorInfo(interp, msg); + } + + /* + * Restore the variable frame, and return. + */ + + iPtr->varFramePtr = savedVarFramePtr; + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TclFindProc -- + * + * Given the name of a procedure, return a pointer to the + * record describing the procedure. + * + * Results: + * NULL is returned if the name doesn't correspond to any + * procedure. Otherwise the return value is a pointer to + * the procedure's record. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Proc * +TclFindProc(iPtr, procName) + Interp *iPtr; /* Interpreter in which to look. */ + char *procName; /* Name of desired procedure. */ +{ + Tcl_HashEntry *hPtr; + Command *cmdPtr; + + hPtr = Tcl_FindHashEntry(&iPtr->commandTable, procName); + if (hPtr == NULL) { + return NULL; + } + cmdPtr = (Command *) Tcl_GetHashValue(hPtr); + if (cmdPtr->proc != InterpProc) { + return NULL; + } + return (Proc *) cmdPtr->clientData; +} + +/* + *---------------------------------------------------------------------- + * + * TclIsProc -- + * + * Tells whether a command is a Tcl procedure or not. + * + * Results: + * If the given command is actuall a Tcl procedure, the + * return value is the address of the record describing + * the procedure. Otherwise the return value is 0. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Proc * +TclIsProc(cmdPtr) + Command *cmdPtr; /* Command to test. */ +{ + if (cmdPtr->proc == InterpProc) { + return (Proc *) cmdPtr->clientData; + } + return (Proc *) 0; +} + +/* + *---------------------------------------------------------------------- + * + * InterpProc -- + * + * When a Tcl procedure gets invoked, this routine gets invoked + * to interpret the procedure. + * + * Results: + * A standard Tcl result value, usually TCL_OK. + * + * Side effects: + * Depends on the commands in the procedure. + * + *---------------------------------------------------------------------- + */ + +static int +InterpProc(clientData, interp, argc, argv) + ClientData clientData; /* Record describing procedure to be + * interpreted. */ + Tcl_Interp *interp; /* Interpreter in which procedure was + * invoked. */ + int argc; /* Count of number of arguments to this + * procedure. */ + char **argv; /* Argument values. */ +{ + register Proc *procPtr = (Proc *) clientData; + register Arg *argPtr; + register Interp *iPtr; + char **args; + CallFrame frame; + char *value; + int result; + + /* + * Set up a call frame for the new procedure invocation. + */ + + iPtr = procPtr->iPtr; + Tcl_InitHashTable(&frame.varTable, TCL_STRING_KEYS); + if (iPtr->varFramePtr != NULL) { + frame.level = iPtr->varFramePtr->level + 1; + } else { + frame.level = 1; + } + frame.argc = argc; + frame.argv = argv; + frame.callerPtr = iPtr->framePtr; + frame.callerVarPtr = iPtr->varFramePtr; + iPtr->framePtr = &frame; + iPtr->varFramePtr = &frame; + iPtr->returnCode = TCL_OK; + + /* + * Match the actual arguments against the procedure's formal + * parameters to compute local variables. + */ + + for (argPtr = procPtr->argPtr, args = argv+1, argc -= 1; + argPtr != NULL; + argPtr = argPtr->nextPtr, args++, argc--) { + + /* + * Handle the special case of the last formal being "args". When + * it occurs, assign it a list consisting of all the remaining + * actual arguments. + */ + + if ((argPtr->nextPtr == NULL) + && (strcmp(argPtr->name, "args") == 0)) { + if (argc < 0) { + argc = 0; + } + value = Tcl_Merge(argc, args); + Tcl_SetVar(interp, argPtr->name, value, 0); + ckfree(value); + argc = 0; + break; + } else if (argc > 0) { + value = *args; + } else if (argPtr->defValue != NULL) { + value = argPtr->defValue; + } else { + Tcl_AppendResult(interp, "no value given for parameter \"", + argPtr->name, "\" to \"", argv[0], "\"", + (char *) NULL); + result = TCL_ERROR; + goto procDone; + } + Tcl_SetVar(interp, argPtr->name, value, 0); + } + if (argc > 0) { + Tcl_AppendResult(interp, "called \"", argv[0], + "\" with too many arguments", (char *) NULL); + result = TCL_ERROR; + goto procDone; + } + + /* + * Invoke the commands in the procedure's body. + */ + + procPtr->refCount++; + result = Tcl_Eval(interp, procPtr->command); + procPtr->refCount--; + if (procPtr->refCount <= 0) { + CleanupProc(procPtr); + } + if (result == TCL_RETURN) { + result = TclUpdateReturnInfo(iPtr); + } else if (result == TCL_ERROR) { + char msg[100]; + + /* + * Record information telling where the error occurred. + */ + + sprintf(msg, "\n (procedure \"%.50s\" line %d)", argv[0], + iPtr->errorLine); + Tcl_AddErrorInfo(interp, msg); + } else if (result == TCL_BREAK) { + iPtr->result = "invoked \"break\" outside of a loop"; + result = TCL_ERROR; + } else if (result == TCL_CONTINUE) { + iPtr->result = "invoked \"continue\" outside of a loop"; + result = TCL_ERROR; + } + + /* + * Delete the call frame for this procedure invocation (it's + * important to remove the call frame from the interpreter + * before deleting it, so that traces invoked during the + * deletion don't see the partially-deleted frame). + */ + + procDone: + iPtr->framePtr = frame.callerPtr; + iPtr->varFramePtr = frame.callerVarPtr; + + /* + * The check below is a hack. The problem is that there could be + * unset traces on the variables, which cause scripts to be evaluated. + * This will clear the ERR_IN_PROGRESS flag, losing stack trace + * information if the procedure was exiting with an error. The + * code below preserves the flag. Unfortunately, that isn't + * really enough: we really should preserve the errorInfo variable + * too (otherwise a nested error in the trace script will trash + * errorInfo). What's really needed is a general-purpose + * mechanism for saving and restoring interpreter state. + */ + + if (iPtr->flags & ERR_IN_PROGRESS) { + TclDeleteVars(iPtr, &frame.varTable); + iPtr->flags |= ERR_IN_PROGRESS; + } else { + TclDeleteVars(iPtr, &frame.varTable); + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * ProcDeleteProc -- + * + * This procedure is invoked just before a command procedure is + * removed from an interpreter. Its job is to release all the + * resources allocated to the procedure. + * + * Results: + * None. + * + * Side effects: + * Memory gets freed, unless the procedure is actively being + * executed. In this case the cleanup is delayed until the + * last call to the current procedure completes. + * + *---------------------------------------------------------------------- + */ + +static void +ProcDeleteProc(clientData) + ClientData clientData; /* Procedure to be deleted. */ +{ + Proc *procPtr = (Proc *) clientData; + + procPtr->refCount--; + if (procPtr->refCount <= 0) { + CleanupProc(procPtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * CleanupProc -- + * + * This procedure does all the real work of freeing up a Proc + * structure. It's called only when the structure's reference + * count becomes zero. + * + * Results: + * None. + * + * Side effects: + * Memory gets freed. + * + *---------------------------------------------------------------------- + */ + +static void +CleanupProc(procPtr) + register Proc *procPtr; /* Procedure to be deleted. */ +{ + register Arg *argPtr; + + ckfree((char *) procPtr->command); + for (argPtr = procPtr->argPtr; argPtr != NULL; ) { + Arg *nextPtr = argPtr->nextPtr; + + ckfree((char *) argPtr); + argPtr = nextPtr; + } + ckfree((char *) procPtr); +} + +/* + *---------------------------------------------------------------------- + * + * TclUpdateReturnInfo -- + * + * This procedure is called when procedures return, and at other + * points where the TCL_RETURN code is used. It examines fields + * such as iPtr->returnCode and iPtr->errorCode and modifies + * the real return status accordingly. + * + * Results: + * The return value is the true completion code to use for + * the procedure, instead of TCL_RETURN. + * + * Side effects: + * The errorInfo and errorCode variables may get modified. + * + *---------------------------------------------------------------------- + */ + +int +TclUpdateReturnInfo(iPtr) + Interp *iPtr; /* Interpreter for which TCL_RETURN + * exception is being processed. */ +{ + int code; + + code = iPtr->returnCode; + iPtr->returnCode = TCL_OK; + if (code == TCL_ERROR) { + Tcl_SetVar2((Tcl_Interp *) iPtr, "errorCode", (char *) NULL, + (iPtr->errorCode != NULL) ? iPtr->errorCode : "NONE", + TCL_GLOBAL_ONLY); + iPtr->flags |= ERROR_CODE_SET; + if (iPtr->errorInfo != NULL) { + Tcl_SetVar2((Tcl_Interp *) iPtr, "errorInfo", (char *) NULL, + iPtr->errorInfo, TCL_GLOBAL_ONLY); + iPtr->flags |= ERR_IN_PROGRESS; + } + } + return code; +} diff --git a/contrib/tcl/generic/tclRegexp.h b/contrib/tcl/generic/tclRegexp.h new file mode 100644 index 0000000000000..986316be708e0 --- /dev/null +++ b/contrib/tcl/generic/tclRegexp.h @@ -0,0 +1,40 @@ +/* + * Definitions etc. for regexp(3) routines. + * + * Caveat: this is V8 regexp(3) [actually, a reimplementation thereof], + * not the System V one. + * + * SCCS: @(#) tclRegexp.h 1.6 96/04/02 18:43:57 + */ + +#ifndef _REGEXP +#define _REGEXP 1 + +#ifndef _TCL +#include "tcl.h" +#endif + +/* + * NSUBEXP must be at least 10, and no greater than 117 or the parser + * will not work properly. + */ + +#define NSUBEXP 20 + +typedef struct regexp { + char *startp[NSUBEXP]; + char *endp[NSUBEXP]; + char regstart; /* Internal use only. */ + char reganch; /* Internal use only. */ + char *regmust; /* Internal use only. */ + int regmlen; /* Internal use only. */ + char program[1]; /* Unwarranted chumminess with compiler. */ +} regexp; + +EXTERN regexp *TclRegComp _ANSI_ARGS_((char *exp)); +EXTERN int TclRegExec _ANSI_ARGS_((regexp *prog, char *string, char *start)); +EXTERN void TclRegSub _ANSI_ARGS_((regexp *prog, char *source, char *dest)); +EXTERN void TclRegError _ANSI_ARGS_((char *msg)); +EXTERN char *TclGetRegError _ANSI_ARGS_((void)); + +#endif /* REGEXP */ diff --git a/contrib/tcl/generic/tclTest.c b/contrib/tcl/generic/tclTest.c new file mode 100644 index 0000000000000..74ff0e233b0a4 --- /dev/null +++ b/contrib/tcl/generic/tclTest.c @@ -0,0 +1,1932 @@ +/* + * tclTest.c -- + * + * This file contains C command procedures for a bunch of additional + * Tcl commands that are used for testing out Tcl's C interfaces. + * These commands are not normally included in Tcl applications; + * they're only used for testing. + * + * Copyright (c) 1993-1994 The Regents of the University of California. + * Copyright (c) 1994-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: @(#) tclTest.c 1.78 96/04/11 14:50:51 + */ + +#include "tclInt.h" +#include "tclPort.h" + +/* + * Declare external functions used in Windows tests. + */ + +#if defined(__WIN32__) +extern TclPlatformType * TclWinGetPlatform _ANSI_ARGS_((void)); +#endif + +/* + * Dynamic string shared by TestdcallCmd and DelCallbackProc; used + * to collect the results of the various deletion callbacks. + */ + +static Tcl_DString delString; +static Tcl_Interp *delInterp; + +/* + * One of the following structures exists for each asynchronous + * handler created by the "testasync" command". + */ + +typedef struct TestAsyncHandler { + int id; /* Identifier for this handler. */ + Tcl_AsyncHandler handler; /* Tcl's token for the handler. */ + char *command; /* Command to invoke when the + * handler is invoked. */ + struct TestAsyncHandler *nextPtr; /* Next is list of handlers. */ +} TestAsyncHandler; + +static TestAsyncHandler *firstHandler = NULL; + +/* + * The dynamic string below is used by the "testdstring" command + * to test the dynamic string facilities. + */ + +static Tcl_DString dstring; + +/* + * One of the following structures exists for each command created + * by TestdelCmd: + */ + +typedef struct DelCmd { + Tcl_Interp *interp; /* Interpreter in which command exists. */ + char *deleteCmd; /* Script to execute when command is + * deleted. Malloc'ed. */ +} DelCmd; + +/* + * The following structure is used to keep track of modal timeout + * handlers created by the "testmodal" command. + */ + +typedef struct Modal { + Tcl_Interp *interp; /* Interpreter in which to set variable + * "x" when timer fires. */ + char *key; /* Null-terminated string to store in + * global variable "x" in interp when + * timer fires. Malloc-ed. */ +} Modal; + +/* + * Forward declarations for procedures defined later in this file: + */ + +int Tcltest_Init _ANSI_ARGS_((Tcl_Interp *interp)); +static int AsyncHandlerProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int code)); +static void CleanupTestSetassocdataTests _ANSI_ARGS_(( + ClientData clientData, Tcl_Interp *interp)); +static void CmdDelProc1 _ANSI_ARGS_((ClientData clientData)); +static void CmdDelProc2 _ANSI_ARGS_((ClientData clientData)); +static int CmdProc1 _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +static int CmdProc2 _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +static void DelCallbackProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp)); +static int DelCmdProc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int argc, char **argv)); +static void DelDeleteProc _ANSI_ARGS_((ClientData clientData)); +static void ExitProcEven _ANSI_ARGS_((ClientData clientData)); +static void ExitProcOdd _ANSI_ARGS_((ClientData clientData)); +static void ModalTimeoutProc _ANSI_ARGS_((ClientData clientData)); +static void SpecialFree _ANSI_ARGS_((char *blockPtr)); +static int StaticInitProc _ANSI_ARGS_((Tcl_Interp *interp)); +static int TestasyncCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestcmdinfoCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestcmdtokenCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestdcallCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestdelCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestdelassocdataCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestdstringCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestexithandlerCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestfilewaitCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestgetassocdataCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestgetplatformCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestfhandleCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestinterpdeleteCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestlinkCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestMathFunc _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, Tcl_Value *args, + Tcl_Value *resultPtr)); +static int TestmodalCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestsetassocdataCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestsetplatformCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TeststaticpkgCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TesttranslatefilenameCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestupvarCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestwordendCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestfeventCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); +static int TestPanicCmd _ANSI_ARGS_((ClientData dummy, + Tcl_Interp *interp, int argc, char **argv)); + +/* + * External (platform specific) initialization routine: + */ + +EXTERN int TclplatformtestInit _ANSI_ARGS_(( + Tcl_Interp *interp)); + +/* + *---------------------------------------------------------------------- + * + * Tcltest_Init -- + * + * This procedure performs application-specific initialization. + * Most applications, especially those that incorporate additional + * packages, will have their own version of this procedure. + * + * Results: + * Returns a standard Tcl completion code, and leaves an error + * message in interp->result if an error occurs. + * + * Side effects: + * Depends on the startup script. + * + *---------------------------------------------------------------------- + */ + +int +Tcltest_Init(interp) + Tcl_Interp *interp; /* Interpreter for application. */ +{ + if (Tcl_PkgProvide(interp, "Tcltest", "7.5") == TCL_ERROR) { + return TCL_ERROR; + } + + /* + * Create additional commands and math functions for testing Tcl. + */ + + Tcl_CreateCommand(interp, "testasync", TestasyncCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testchannel", TclTestChannelCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testchannelevent", TclTestChannelEventCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testcmdtoken", TestcmdtokenCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testcmdinfo", TestcmdinfoCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testdcall", TestdcallCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testdel", TestdelCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testdelassocdata", TestdelassocdataCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_DStringInit(&dstring); + Tcl_CreateCommand(interp, "testdstring", TestdstringCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testexithandler", TestexithandlerCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testfhandle", TestfhandleCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testfilewait", TestfilewaitCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testgetassocdata", TestgetassocdataCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testgetplatform", TestgetplatformCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testinterpdelete", TestinterpdeleteCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testlink", TestlinkCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testmodal", TestmodalCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testsetassocdata", TestsetassocdataCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testsetplatform", TestsetplatformCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "teststaticpkg", TeststaticpkgCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testtranslatefilename", + TesttranslatefilenameCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testupvar", TestupvarCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testwordend", TestwordendCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testfevent", TestfeventCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateCommand(interp, "testpanic", TestPanicCmd, (ClientData) 0, + (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateMathFunc(interp, "T1", 0, (Tcl_ValueType *) NULL, TestMathFunc, + (ClientData) 123); + Tcl_CreateMathFunc(interp, "T2", 0, (Tcl_ValueType *) NULL, TestMathFunc, + (ClientData) 345); + + /* + * And finally add any platform specific test commands. + */ + + return TclplatformtestInit(interp); +} + +/* + *---------------------------------------------------------------------- + * + * TestasyncCmd -- + * + * This procedure implements the "testasync" command. It is used + * to test the asynchronous handler facilities of Tcl. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Creates, deletes, and invokes handlers. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TestasyncCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + TestAsyncHandler *asyncPtr, *prevPtr; + int id, code; + static int nextId = 1; + + if (argc < 2) { + wrongNumArgs: + interp->result = "wrong # args"; + return TCL_ERROR; + } + if (strcmp(argv[1], "create") == 0) { + if (argc != 3) { + goto wrongNumArgs; + } + asyncPtr = (TestAsyncHandler *) ckalloc(sizeof(TestAsyncHandler)); + asyncPtr->id = nextId; + nextId++; + asyncPtr->handler = Tcl_AsyncCreate(AsyncHandlerProc, + (ClientData) asyncPtr); + asyncPtr->command = (char *) ckalloc((unsigned) (strlen(argv[2]) + 1)); + strcpy(asyncPtr->command, argv[2]); + asyncPtr->nextPtr = firstHandler; + firstHandler = asyncPtr; + sprintf(interp->result, "%d", asyncPtr->id); + } else if (strcmp(argv[1], "delete") == 0) { + if (argc == 2) { + while (firstHandler != NULL) { + asyncPtr = firstHandler; + firstHandler = asyncPtr->nextPtr; + Tcl_AsyncDelete(asyncPtr->handler); + ckfree(asyncPtr->command); + ckfree((char *) asyncPtr); + } + return TCL_OK; + } + if (argc != 3) { + goto wrongNumArgs; + } + if (Tcl_GetInt(interp, argv[2], &id) != TCL_OK) { + return TCL_ERROR; + } + for (prevPtr = NULL, asyncPtr = firstHandler; asyncPtr != NULL; + prevPtr = asyncPtr, asyncPtr = asyncPtr->nextPtr) { + if (asyncPtr->id != id) { + continue; + } + if (prevPtr == NULL) { + firstHandler = asyncPtr->nextPtr; + } else { + prevPtr->nextPtr = asyncPtr->nextPtr; + } + Tcl_AsyncDelete(asyncPtr->handler); + ckfree(asyncPtr->command); + ckfree((char *) asyncPtr); + break; + } + } else if (strcmp(argv[1], "mark") == 0) { + if (argc != 5) { + goto wrongNumArgs; + } + if ((Tcl_GetInt(interp, argv[2], &id) != TCL_OK) + || (Tcl_GetInt(interp, argv[4], &code) != TCL_OK)) { + return TCL_ERROR; + } + for (asyncPtr = firstHandler; asyncPtr != NULL; + asyncPtr = asyncPtr->nextPtr) { + if (asyncPtr->id == id) { + Tcl_AsyncMark(asyncPtr->handler); + break; + } + } + Tcl_SetResult(interp, argv[3], TCL_VOLATILE); + return code; + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be create, delete, int, or mark", + (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +static int +AsyncHandlerProc(clientData, interp, code) + ClientData clientData; /* Pointer to TestAsyncHandler structure. */ + Tcl_Interp *interp; /* Interpreter in which command was + * executed, or NULL. */ + int code; /* Current return code from command. */ +{ + TestAsyncHandler *asyncPtr = (TestAsyncHandler *) clientData; + char *listArgv[4]; + char string[20], *cmd; + + sprintf(string, "%d", code); + listArgv[0] = asyncPtr->command; + listArgv[1] = interp->result; + listArgv[2] = string; + listArgv[3] = NULL; + cmd = Tcl_Merge(3, listArgv); + code = Tcl_Eval(interp, cmd); + ckfree(cmd); + return code; +} + +/* + *---------------------------------------------------------------------- + * + * TestcmdinfoCmd -- + * + * This procedure implements the "testcmdinfo" command. It is used + * to test Tcl_GetCommandInfo, Tcl_SetCommandInfo, and command creation + * and deletion. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Creates and deletes various commands and modifies their data. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TestcmdinfoCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tcl_CmdInfo info; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " option cmdName\"", (char *) NULL); + return TCL_ERROR; + } + if (strcmp(argv[1], "create") == 0) { + Tcl_CreateCommand(interp, argv[2], CmdProc1, (ClientData) "original", + CmdDelProc1); + } else if (strcmp(argv[1], "delete") == 0) { + Tcl_DStringInit(&delString); + Tcl_DeleteCommand(interp, argv[2]); + Tcl_DStringResult(interp, &delString); + } else if (strcmp(argv[1], "get") == 0) { + if (Tcl_GetCommandInfo(interp, argv[2], &info) ==0) { + interp->result = "??"; + return TCL_OK; + } + if (info.proc == CmdProc1) { + Tcl_AppendResult(interp, "CmdProc1", " ", + (char *) info.clientData, (char *) NULL); + } else if (info.proc == CmdProc2) { + Tcl_AppendResult(interp, "CmdProc2", " ", + (char *) info.clientData, (char *) NULL); + } else { + Tcl_AppendResult(interp, "unknown", (char *) NULL); + } + if (info.deleteProc == CmdDelProc1) { + Tcl_AppendResult(interp, " CmdDelProc1", " ", + (char *) info.deleteData, (char *) NULL); + } else if (info.deleteProc == CmdDelProc2) { + Tcl_AppendResult(interp, " CmdDelProc2", " ", + (char *) info.deleteData, (char *) NULL); + } else { + Tcl_AppendResult(interp, " unknown", (char *) NULL); + } + } else if (strcmp(argv[1], "modify") == 0) { + info.proc = CmdProc2; + info.clientData = (ClientData) "new_command_data"; + info.deleteProc = CmdDelProc2; + info.deleteData = (ClientData) "new_delete_data"; + if (Tcl_SetCommandInfo(interp, argv[2], &info) == 0) { + interp->result = "0"; + } else { + interp->result = "1"; + } + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be create, delete, get, or modify", + (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + + /*ARGSUSED*/ +static int +CmdProc1(clientData, interp, argc, argv) + ClientData clientData; /* String to return. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tcl_AppendResult(interp, "CmdProc1 ", (char *) clientData, + (char *) NULL); + return TCL_OK; +} + + /*ARGSUSED*/ +static int +CmdProc2(clientData, interp, argc, argv) + ClientData clientData; /* String to return. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tcl_AppendResult(interp, "CmdProc2 ", (char *) clientData, + (char *) NULL); + return TCL_OK; +} + +static void +CmdDelProc1(clientData) + ClientData clientData; /* String to save. */ +{ + Tcl_DStringInit(&delString); + Tcl_DStringAppend(&delString, "CmdDelProc1 ", -1); + Tcl_DStringAppend(&delString, (char *) clientData, -1); +} + +static void +CmdDelProc2(clientData) + ClientData clientData; /* String to save. */ +{ + Tcl_DStringInit(&delString); + Tcl_DStringAppend(&delString, "CmdDelProc2 ", -1); + Tcl_DStringAppend(&delString, (char *) clientData, -1); +} + +/* + *---------------------------------------------------------------------- + * + * TestcmdtokenCmd -- + * + * This procedure implements the "testcmdtoken" command. It is used + * to test Tcl_Command tokens and Tcl_GetCommandName. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Creates and deletes various commands and modifies their data. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TestcmdtokenCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tcl_Command token; + long int l; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " option arg\"", (char *) NULL); + return TCL_ERROR; + } + if (strcmp(argv[1], "create") == 0) { + token = Tcl_CreateCommand(interp, argv[2], CmdProc1, + (ClientData) "original", (Tcl_CmdDeleteProc *) NULL); + sprintf(interp->result, "%lx", (long int) token); + } else if (strcmp(argv[1], "name") == 0) { + if (sscanf(argv[2], "%lx", &l) != 1) { + Tcl_AppendResult(interp, "bad command token \"", argv[2], + "\"", (char *) NULL); + return TCL_ERROR; + } + interp->result = Tcl_GetCommandName(interp, (Tcl_Command) l); + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be create or name", (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestdcallCmd -- + * + * This procedure implements the "testdcall" command. It is used + * to test Tcl_CallWhenDeleted. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Creates and deletes interpreters. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TestdcallCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int i, id; + + delInterp = Tcl_CreateInterp(); + Tcl_DStringInit(&delString); + for (i = 1; i < argc; i++) { + if (Tcl_GetInt(interp, argv[i], &id) != TCL_OK) { + return TCL_ERROR; + } + if (id < 0) { + Tcl_DontCallWhenDeleted(delInterp, DelCallbackProc, + (ClientData) (-id)); + } else { + Tcl_CallWhenDeleted(delInterp, DelCallbackProc, + (ClientData) id); + } + } + Tcl_DeleteInterp(delInterp); + Tcl_DStringResult(interp, &delString); + return TCL_OK; +} + +/* + * The deletion callback used by TestdcallCmd: + */ + +static void +DelCallbackProc(clientData, interp) + ClientData clientData; /* Numerical value to append to + * delString. */ + Tcl_Interp *interp; /* Interpreter being deleted. */ +{ + int id = (int) clientData; + char buffer[10]; + + sprintf(buffer, "%d", id); + Tcl_DStringAppendElement(&delString, buffer); + if (interp != delInterp) { + Tcl_DStringAppendElement(&delString, "bogus interpreter argument!"); + } +} + +/* + *---------------------------------------------------------------------- + * + * TestdelCmd -- + * + * This procedure implements the "testdcall" command. It is used + * to test Tcl_CallWhenDeleted. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Creates and deletes interpreters. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TestdelCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + DelCmd *dPtr; + Tcl_Interp *slave; + + if (argc != 4) { + interp->result = "wrong # args"; + return TCL_ERROR; + } + + slave = Tcl_GetSlave(interp, argv[1]); + if (slave == NULL) { + return TCL_ERROR; + } + + dPtr = (DelCmd *) ckalloc(sizeof(DelCmd)); + dPtr->interp = interp; + dPtr->deleteCmd = (char *) ckalloc((unsigned) (strlen(argv[3]) + 1)); + strcpy(dPtr->deleteCmd, argv[3]); + + Tcl_CreateCommand(slave, argv[2], DelCmdProc, (ClientData) dPtr, + DelDeleteProc); + return TCL_OK; +} + +static int +DelCmdProc(clientData, interp, argc, argv) + ClientData clientData; /* String result to return. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + DelCmd *dPtr = (DelCmd *) clientData; + + Tcl_AppendResult(interp, dPtr->deleteCmd, (char *) NULL); + ckfree(dPtr->deleteCmd); + ckfree((char *) dPtr); + return TCL_OK; +} + +static void +DelDeleteProc(clientData) + ClientData clientData; /* String command to evaluate. */ +{ + DelCmd *dPtr = (DelCmd *) clientData; + + Tcl_Eval(dPtr->interp, dPtr->deleteCmd); + Tcl_ResetResult(dPtr->interp); + ckfree(dPtr->deleteCmd); + ckfree((char *) dPtr); +} + +/* + *---------------------------------------------------------------------- + * + * TestdelassocdataCmd -- + * + * This procedure implements the "testdelassocdata" command. It is used + * to test Tcl_DeleteAssocData. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Deletes an association between a key and associated data from an + * interpreter. + * + *---------------------------------------------------------------------- + */ + +static int +TestdelassocdataCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], + " data_key\"", (char *) NULL); + return TCL_ERROR; + } + Tcl_DeleteAssocData(interp, argv[1]); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestdstringCmd -- + * + * This procedure implements the "testdstring" command. It is used + * to test the dynamic string facilities of Tcl. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Creates, deletes, and invokes handlers. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TestdstringCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int count; + + if (argc < 2) { + wrongNumArgs: + interp->result = "wrong # args"; + return TCL_ERROR; + } + if (strcmp(argv[1], "append") == 0) { + if (argc != 4) { + goto wrongNumArgs; + } + if (Tcl_GetInt(interp, argv[3], &count) != TCL_OK) { + return TCL_ERROR; + } + Tcl_DStringAppend(&dstring, argv[2], count); + } else if (strcmp(argv[1], "element") == 0) { + if (argc != 3) { + goto wrongNumArgs; + } + Tcl_DStringAppendElement(&dstring, argv[2]); + } else if (strcmp(argv[1], "end") == 0) { + if (argc != 2) { + goto wrongNumArgs; + } + Tcl_DStringEndSublist(&dstring); + } else if (strcmp(argv[1], "free") == 0) { + if (argc != 2) { + goto wrongNumArgs; + } + Tcl_DStringFree(&dstring); + } else if (strcmp(argv[1], "get") == 0) { + if (argc != 2) { + goto wrongNumArgs; + } + interp->result = Tcl_DStringValue(&dstring); + } else if (strcmp(argv[1], "gresult") == 0) { + if (argc != 3) { + goto wrongNumArgs; + } + if (strcmp(argv[2], "staticsmall") == 0) { + interp->result = "short"; + } else if (strcmp(argv[2], "staticlarge") == 0) { + interp->result = "first0 first1 first2 first3 first4 first5 first6 first7 first8 first9\nsecond0 second1 second2 second3 second4 second5 second6 second7 second8 second9\nthird0 third1 third2 third3 third4 third5 third6 third7 third8 third9\nfourth0 fourth1 fourth2 fourth3 fourth4 fourth5 fourth6 fourth7 fourth8 fourth9\nfifth0 fifth1 fifth2 fifth3 fifth4 fifth5 fifth6 fifth7 fifth8 fifth9\nsixth0 sixth1 sixth2 sixth3 sixth4 sixth5 sixth6 sixth7 sixth8 sixth9\nseventh0 seventh1 seventh2 seventh3 seventh4 seventh5 seventh6 seventh7 seventh8 seventh9\n"; + } else if (strcmp(argv[2], "free") == 0) { + interp->result = (char *) ckalloc(100); + interp->freeProc = TCL_DYNAMIC; + strcpy(interp->result, "This is a malloc-ed string"); + } else if (strcmp(argv[2], "special") == 0) { + interp->result = (char *) ckalloc(100); + interp->result += 4; + interp->freeProc = SpecialFree; + strcpy(interp->result, "This is a specially-allocated string"); + } else { + Tcl_AppendResult(interp, "bad gresult option \"", argv[2], + "\": must be staticsmall, staticlarge, free, or special", + (char *) NULL); + return TCL_ERROR; + } + Tcl_DStringGetResult(interp, &dstring); + } else if (strcmp(argv[1], "length") == 0) { + if (argc != 2) { + goto wrongNumArgs; + } + sprintf(interp->result, "%d", Tcl_DStringLength(&dstring)); + } else if (strcmp(argv[1], "result") == 0) { + if (argc != 2) { + goto wrongNumArgs; + } + Tcl_DStringResult(interp, &dstring); + } else if (strcmp(argv[1], "trunc") == 0) { + if (argc != 3) { + goto wrongNumArgs; + } + if (Tcl_GetInt(interp, argv[2], &count) != TCL_OK) { + return TCL_ERROR; + } + Tcl_DStringTrunc(&dstring, count); + } else if (strcmp(argv[1], "start") == 0) { + if (argc != 2) { + goto wrongNumArgs; + } + Tcl_DStringStartSublist(&dstring); + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be append, element, end, free, get, length, ", + "result, trunc, or start", (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + * The procedure below is used as a special freeProc to test how well + * Tcl_DStringGetResult handles freeProc's other than free. + */ + +static void SpecialFree(blockPtr) + char *blockPtr; /* Block to free. */ +{ + ckfree(blockPtr - 4); +} + +/* + *---------------------------------------------------------------------- + * + * TestexithandlerCmd -- + * + * This procedure implements the "testexithandler" command. It is + * used to test Tcl_CreateExitHandler and Tcl_DeleteExitHandler. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestexithandlerCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int value; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], + " create|delete value\"", (char *) NULL); + return TCL_ERROR; + } + if (Tcl_GetInt(interp, argv[2], &value) != TCL_OK) { + return TCL_ERROR; + } + if (strcmp(argv[1], "create") == 0) { + Tcl_CreateExitHandler((value & 1) ? ExitProcOdd : ExitProcEven, + (ClientData) value); + } else if (strcmp(argv[1], "delete") == 0) { + Tcl_DeleteExitHandler((value & 1) ? ExitProcOdd : ExitProcEven, + (ClientData) value); + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be create or delete", (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +static void +ExitProcOdd(clientData) + ClientData clientData; /* Integer value to print. */ +{ + char buf[100]; + + sprintf(buf, "odd %d\n", (int) clientData); + write(1, buf, strlen(buf)); +} + +static void +ExitProcEven(clientData) + ClientData clientData; /* Integer value to print. */ +{ + char buf[100]; + + sprintf(buf, "even %d\n", (int) clientData); + write(1, buf, strlen(buf)); +} + +/* + *---------------------------------------------------------------------- + * + * TestfhandleCmd -- + * + * This procedure implements the "testfhandle" command. It is + * used to test Tcl_GetFile, Tcl_FreeFile, and + * Tcl_GetFileInfo. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestfhandleCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ +#define MAX_FHANDLES 10 + static Tcl_File testHandles[MAX_FHANDLES]; + static initialized = 0; + + int i, index, type; + ClientData data; + + if (!initialized) { + for (i = 0; i < MAX_FHANDLES; i++) { + testHandles[i] = NULL; + } + initialized = 1; + } + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], + " option ... \"", (char *) NULL); + return TCL_ERROR; + } + index = -1; + if (argc >= 3) { + if (Tcl_GetInt(interp, argv[2], &index) != TCL_OK) { + return TCL_ERROR; + } + if (index >= MAX_FHANDLES) { + Tcl_AppendResult(interp, "bad index ", argv[2], (char *) NULL); + return TCL_ERROR; + } + } + if (strcmp(argv[1], "compare") == 0) { + int index2; + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", + argv[0], " index index\"", (char *) NULL); + return TCL_ERROR; + } + if (Tcl_GetInt(interp, argv[3], (int *) &index2) != TCL_OK) { + return TCL_ERROR; + } + if (testHandles[index] == testHandles[index2]) { + sprintf(interp->result, "equal"); + } else { + sprintf(interp->result, "notequal"); + } + } else if (strcmp(argv[1], "get") == 0) { + if (argc != 5) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", + argv[0], " index data type\"", (char *) NULL); + return TCL_ERROR; + } + if (Tcl_GetInt(interp, argv[3], (int *) &data) != TCL_OK) { + return TCL_ERROR; + } + if (Tcl_GetInt(interp, argv[4], &type) != TCL_OK) { + return TCL_ERROR; + } + testHandles[index] = Tcl_GetFile(data, type); + } else if (strcmp(argv[1], "free") == 0) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", + argv[0], " index\"", (char *) NULL); + return TCL_ERROR; + } + Tcl_FreeFile(testHandles[index]); + } else if (strcmp(argv[1], "info1") == 0) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", + argv[0], " index\"", (char *) NULL); + return TCL_ERROR; + } + data = Tcl_GetFileInfo(testHandles[index], NULL); + sprintf(interp->result, "%d", (int)data); + } else if (strcmp(argv[1], "info2") == 0) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", + argv[0], " index\"", (char *) NULL); + return TCL_ERROR; + } + data = Tcl_GetFileInfo(testHandles[index], &type); + sprintf(interp->result, "%d %d", (int)data, type); + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be compare, get, free, info1, or info2", + (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestfilewaitCmd -- + * + * This procedure implements the "testfilewait" command. It is + * used to test TclWaitForFile. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestfilewaitCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int mask, result, timeout; + Tcl_Channel channel; + Tcl_File file; + + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], + " file readable|writable|both timeout\"", (char *) NULL); + return TCL_ERROR; + } + channel = Tcl_GetChannel(interp, argv[1], NULL); + if (channel == NULL) { + return TCL_ERROR; + } + if (strcmp(argv[2], "readable") == 0) { + mask = TCL_READABLE; + } else if (strcmp(argv[2], "writable") == 0){ + mask = TCL_WRITABLE; + } else if (strcmp(argv[2], "both") == 0){ + mask = TCL_WRITABLE|TCL_READABLE; + } else { + Tcl_AppendResult(interp, "bad argument \"", argv[2], + "\": must be readable, writable, or both", (char *) NULL); + return TCL_ERROR; + } + file = Tcl_GetChannelFile(channel, + (mask & TCL_READABLE) ? TCL_READABLE : TCL_WRITABLE); + if (file == NULL) { + interp->result = "couldn't get channel file"; + return TCL_ERROR; + } + if (Tcl_GetInt(interp, argv[3], &timeout) != TCL_OK) { + return TCL_ERROR; + } + result = TclWaitForFile(file, mask, timeout); + if (result & TCL_READABLE) { + Tcl_AppendElement(interp, "readable"); + } + if (result & TCL_WRITABLE) { + Tcl_AppendElement(interp, "writable"); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestgetassocdataCmd -- + * + * This procedure implements the "testgetassocdata" command. It is + * used to test Tcl_GetAssocData. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestgetassocdataCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + char *res; + + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], + " data_key\"", (char *) NULL); + return TCL_ERROR; + } + res = (char *) Tcl_GetAssocData(interp, argv[1], NULL); + if (res != NULL) { + Tcl_AppendResult(interp, res, NULL); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestgetplatformCmd -- + * + * This procedure implements the "testgetplatform" command. It is + * used to retrievel the value of the tclPlatform global variable. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestgetplatformCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + static char *platformStrings[] = { "unix", "mac", "windows" }; + TclPlatformType *platform; + +#ifdef __WIN32__ + platform = TclWinGetPlatform(); +#else + platform = &tclPlatform; +#endif + + if (argc != 1) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], + (char *) NULL); + return TCL_ERROR; + } + + Tcl_AppendResult(interp, platformStrings[*platform], NULL); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestinterpdeleteCmd -- + * + * This procedure tests the code in tclInterp.c that deals with + * interpreter deletion. It deletes a user-specified interpreter + * from the hierarchy, and subsequent code checks integrity. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Deletes one or more interpreters. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TestinterpdeleteCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + Tcl_Interp *slaveToDelete; + + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " path\"", (char *) NULL); + return TCL_ERROR; + } + if (argv[1][0] == '\0') { + Tcl_AppendResult(interp, "cannot delete current interpreter", + (char *) NULL); + return TCL_ERROR; + } + slaveToDelete = Tcl_GetSlave(interp, argv[1]); + if (slaveToDelete == (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "could not find interpreter \"", + argv[1], "\"", (char *) NULL); + return TCL_ERROR; + } + Tcl_DeleteInterp(slaveToDelete); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestlinkCmd -- + * + * This procedure implements the "testlink" command. It is used + * to test Tcl_LinkVar and related library procedures. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Creates and deletes various variable links, plus returns + * values of the linked variables. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TestlinkCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + static int intVar = 43; + static int boolVar = 4; + static double realVar = 1.23; + static char *stringVar = NULL; + static int created = 0; + char buffer[TCL_DOUBLE_SPACE]; + int writable, flag; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " option ?arg arg arg?\"", (char *) NULL); + return TCL_ERROR; + } + if (strcmp(argv[1], "create") == 0) { + if (created) { + Tcl_UnlinkVar(interp, "int"); + Tcl_UnlinkVar(interp, "real"); + Tcl_UnlinkVar(interp, "bool"); + Tcl_UnlinkVar(interp, "string"); + } + created = 1; + if (Tcl_GetBoolean(interp, argv[2], &writable) != TCL_OK) { + return TCL_ERROR; + } + flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + if (Tcl_LinkVar(interp, "int", (char *) &intVar, + TCL_LINK_INT | flag) != TCL_OK) { + return TCL_ERROR; + } + if (Tcl_GetBoolean(interp, argv[3], &writable) != TCL_OK) { + return TCL_ERROR; + } + flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + if (Tcl_LinkVar(interp, "real", (char *) &realVar, + TCL_LINK_DOUBLE | flag) != TCL_OK) { + return TCL_ERROR; + } + if (Tcl_GetBoolean(interp, argv[4], &writable) != TCL_OK) { + return TCL_ERROR; + } + flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + if (Tcl_LinkVar(interp, "bool", (char *) &boolVar, + TCL_LINK_BOOLEAN | flag) != TCL_OK) { + return TCL_ERROR; + } + if (Tcl_GetBoolean(interp, argv[5], &writable) != TCL_OK) { + return TCL_ERROR; + } + flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + if (Tcl_LinkVar(interp, "string", (char *) &stringVar, + TCL_LINK_STRING | flag) != TCL_OK) { + return TCL_ERROR; + } + } else if (strcmp(argv[1], "delete") == 0) { + Tcl_UnlinkVar(interp, "int"); + Tcl_UnlinkVar(interp, "real"); + Tcl_UnlinkVar(interp, "bool"); + Tcl_UnlinkVar(interp, "string"); + created = 0; + } else if (strcmp(argv[1], "get") == 0) { + sprintf(buffer, "%d", intVar); + Tcl_AppendElement(interp, buffer); + Tcl_PrintDouble(interp, realVar, buffer); + Tcl_AppendElement(interp, buffer); + sprintf(buffer, "%d", boolVar); + Tcl_AppendElement(interp, buffer); + Tcl_AppendElement(interp, (stringVar == NULL) ? "-" : stringVar); + } else if (strcmp(argv[1], "set") == 0) { + if (argc != 6) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " ", argv[1], + "intValue realValue boolValue stringValue\"", (char *) NULL); + return TCL_ERROR; + } + if (argv[2][0] != 0) { + if (Tcl_GetInt(interp, argv[2], &intVar) != TCL_OK) { + return TCL_ERROR; + } + } + if (argv[3][0] != 0) { + if (Tcl_GetDouble(interp, argv[3], &realVar) != TCL_OK) { + return TCL_ERROR; + } + } + if (argv[4][0] != 0) { + if (Tcl_GetInt(interp, argv[4], &boolVar) != TCL_OK) { + return TCL_ERROR; + } + } + if (argv[5][0] != 0) { + if (stringVar != NULL) { + ckfree(stringVar); + } + if (strcmp(argv[5], "-") == 0) { + stringVar = NULL; + } else { + stringVar = (char *) ckalloc((unsigned) (strlen(argv[5]) + 1)); + strcpy(stringVar, argv[5]); + } + } + } else if (strcmp(argv[1], "update") == 0) { + if (argc != 6) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " ", argv[1], + "intValue realValue boolValue stringValue\"", (char *) NULL); + return TCL_ERROR; + } + if (argv[2][0] != 0) { + if (Tcl_GetInt(interp, argv[2], &intVar) != TCL_OK) { + return TCL_ERROR; + } + Tcl_UpdateLinkedVar(interp, "int"); + } + if (argv[3][0] != 0) { + if (Tcl_GetDouble(interp, argv[3], &realVar) != TCL_OK) { + return TCL_ERROR; + } + Tcl_UpdateLinkedVar(interp, "real"); + } + if (argv[4][0] != 0) { + if (Tcl_GetInt(interp, argv[4], &boolVar) != TCL_OK) { + return TCL_ERROR; + } + Tcl_UpdateLinkedVar(interp, "bool"); + } + if (argv[5][0] != 0) { + if (stringVar != NULL) { + ckfree(stringVar); + } + if (strcmp(argv[5], "-") == 0) { + stringVar = NULL; + } else { + stringVar = (char *) ckalloc((unsigned) (strlen(argv[5]) + 1)); + strcpy(stringVar, argv[5]); + } + Tcl_UpdateLinkedVar(interp, "string"); + } + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": should be create, delete, get, set, or update", + (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestMathFunc -- + * + * This is a user-defined math procedure to test out math procedures + * with no arguments. + * + * Results: + * A normal Tcl completion code. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TestMathFunc(clientData, interp, args, resultPtr) + ClientData clientData; /* Integer value to return. */ + Tcl_Interp *interp; /* Not used. */ + Tcl_Value *args; /* Not used. */ + Tcl_Value *resultPtr; /* Where to store result. */ +{ + resultPtr->type = TCL_INT; + resultPtr->intValue = (int) clientData; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * CleanupTestSetassocdataTests -- + * + * This function is called when an interpreter is deleted to clean + * up any data left over from running the testsetassocdata command. + * + * Results: + * None. + * + * Side effects: + * Releases storage. + * + *---------------------------------------------------------------------- + */ + /* ARGSUSED */ +static void +CleanupTestSetassocdataTests(clientData, interp) + ClientData clientData; /* Data to be released. */ + Tcl_Interp *interp; /* Interpreter being deleted. */ +{ + ckfree((char *) clientData); +} + +/* + *---------------------------------------------------------------------- + * + * TestmodalCmd -- + * + * This procedure implements the "testmodal" command. It is used + * to test modal timeouts created by Tcl_CreateModalTimeout. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Modifies or creates an association between a key and associated + * data for this interpreter. + * + *---------------------------------------------------------------------- + */ + +static int +TestmodalCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ +#define NUM_MODALS 10 + static Modal modals[NUM_MODALS]; + static int numModals = 0; + int ms; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], + " option ?arg arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + + if (strcmp(argv[1], "create") == 0) { + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], + " create ms key\"", (char *) NULL); + return TCL_ERROR; + } + if (numModals >= NUM_MODALS) { + interp->result = "too many modal timeouts"; + return TCL_ERROR; + } + if (Tcl_GetInt(interp, argv[2], &ms) != TCL_OK) { + return TCL_ERROR; + } + modals[numModals].interp = interp; + modals[numModals].key = (char *) ckalloc((unsigned) + (strlen(argv[3]) + 1)); + strcpy(modals[numModals].key, argv[3]); + Tcl_CreateModalTimeout(ms, ModalTimeoutProc, + (ClientData) &modals[numModals]); + numModals += 1; + } else if (strcmp(argv[1], "delete") == 0) { + if (numModals == 0) { + interp->result = "no more modal timeouts"; + return TCL_ERROR; + } + numModals -= 1; + ckfree(modals[numModals].key); + Tcl_DeleteModalTimeout(ModalTimeoutProc, + (ClientData) &modals[numModals]); + } else if (strcmp(argv[1], "event") == 0) { + Tcl_DoOneEvent(TCL_TIMER_EVENTS|TCL_DONT_WAIT); + } else if (strcmp(argv[1], "eventnotimers") == 0) { + Tcl_DoOneEvent(0x100000|TCL_DONT_WAIT); + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": must be create, delete, event, or eventnotimers", + (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +static void +ModalTimeoutProc(clientData) + ClientData clientData; /* Pointer to Modal structure. */ +{ + Modal *modalPtr = (Modal *) clientData; + Tcl_SetVar(modalPtr->interp, "x", modalPtr->key, + TCL_GLOBAL_ONLY|TCL_APPEND_VALUE|TCL_LIST_ELEMENT); +} + +/* + *---------------------------------------------------------------------- + * + * TestsetassocdataCmd -- + * + * This procedure implements the "testsetassocdata" command. It is used + * to test Tcl_SetAssocData. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Modifies or creates an association between a key and associated + * data for this interpreter. + * + *---------------------------------------------------------------------- + */ + +static int +TestsetassocdataCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + char *buf; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], + " data_key data_item\"", (char *) NULL); + return TCL_ERROR; + } + + buf = ckalloc((unsigned) strlen(argv[2]) + 1); + strcpy(buf, argv[2]); + + Tcl_SetAssocData(interp, argv[1], CleanupTestSetassocdataTests, + (ClientData) buf); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestsetplatformCmd -- + * + * This procedure implements the "testsetplatform" command. It is + * used to change the tclPlatform global variable so all file + * name conversions can be tested on a single platform. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Sets the tclPlatform global variable. + * + *---------------------------------------------------------------------- + */ + +static int +TestsetplatformCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + size_t length; + TclPlatformType *platform; + +#ifdef __WIN32__ + platform = TclWinGetPlatform(); +#else + platform = &tclPlatform; +#endif + + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], + " platform\"", (char *) NULL); + return TCL_ERROR; + } + + length = strlen(argv[1]); + if (strncmp(argv[1], "unix", length) == 0) { + *platform = TCL_PLATFORM_UNIX; + } else if (strncmp(argv[1], "mac", length) == 0) { + *platform = TCL_PLATFORM_MAC; + } else if (strncmp(argv[1], "windows", length) == 0) { + *platform = TCL_PLATFORM_WINDOWS; + } else { + Tcl_AppendResult(interp, "unsupported platform: should be one of ", + "unix, mac, or windows", (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TeststaticpkgCmd -- + * + * This procedure implements the "teststaticpkg" command. + * It is used to test the procedure Tcl_StaticPackage. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * When the packge given by argv[1] is loaded into an interpeter, + * variable "x" in that interpreter is set to "loaded". + * + *---------------------------------------------------------------------- + */ + +static int +TeststaticpkgCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int safe, loaded; + + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", + argv[0], " pkgName safe loaded\"", (char *) NULL); + return TCL_ERROR; + } + if (Tcl_GetInt(interp, argv[2], &safe) != TCL_OK) { + return TCL_ERROR; + } + if (Tcl_GetInt(interp, argv[3], &loaded) != TCL_OK) { + return TCL_ERROR; + } + Tcl_StaticPackage((loaded) ? interp : NULL, argv[1], StaticInitProc, + (safe) ? StaticInitProc : NULL); + return TCL_OK; +} + +static int +StaticInitProc(interp) + Tcl_Interp *interp; /* Interpreter in which package + * is supposedly being loaded. */ +{ + Tcl_SetVar(interp, "x", "loaded", TCL_GLOBAL_ONLY); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TesttranslatefilenameCmd -- + * + * This procedure implements the "testtranslatefilename" command. + * It is used to test the Tcl_TranslateFileName command. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TesttranslatefilenameCmd(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; + char *result; + + if (argc != 2) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", + argv[0], " path\"", (char *) NULL); + return TCL_ERROR; + } + result = Tcl_TranslateFileName(interp, argv[1], &buffer); + if (result == NULL) { + return TCL_ERROR; + } + Tcl_AppendResult(interp, result, NULL); + Tcl_DStringFree(&buffer); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestupvarCmd -- + * + * This procedure implements the "testupvar2" command. It is used + * to test Tcl_UpVar and Tcl_UpVar2. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Creates or modifies an "upvar" reference. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TestupvarCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + if ((argc != 5) && (argc != 6)) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", + argv[0], " level name ?name2? dest global\"", (char *) NULL); + return TCL_ERROR; + } + + if (argc == 5) { + return Tcl_UpVar(interp, argv[1], argv[2], argv[3], + (strcmp(argv[4], "global") == 0) ? TCL_GLOBAL_ONLY : 0); + } else { + return Tcl_UpVar2(interp, argv[1], argv[2], + (argv[3][0] == 0) ? (char *) NULL : argv[3], argv[4], + (strcmp(argv[5], "global") == 0) ? TCL_GLOBAL_ONLY : 0); + } +} + +/* + *---------------------------------------------------------------------- + * + * TestwordendCmd -- + * + * This procedure implements the "testwordend" command. It is used + * to test TclWordEnd. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TestwordendCmd(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 # arguments: should be \"", + argv[0], " string\"", (char *) NULL); + return TCL_ERROR; + } + Tcl_SetResult(interp, TclWordEnd(argv[1], 0, (int *) NULL), TCL_VOLATILE); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestfeventCmd -- + * + * This procedure implements the "testfevent" command. It is + * used for testing the "fileevent" command. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Creates and deletes interpreters. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TestfeventCmd(clientData, interp, argc, argv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + static Tcl_Interp *interp2 = NULL; + int code; + Tcl_Channel chan; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " option ?arg arg ...?", (char *) NULL); + return TCL_ERROR; + } + if (strcmp(argv[1], "cmd") == 0) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " cmd script", (char *) NULL); + return TCL_ERROR; + } + if (interp2 != (Tcl_Interp *) NULL) { + code = Tcl_GlobalEval(interp2, argv[2]); + interp->result = interp2->result; + return code; + } else { + Tcl_AppendResult(interp, + "called \"testfevent code\" before \"testfevent create\"", + (char *) NULL); + return TCL_ERROR; + } + } else if (strcmp(argv[1], "create") == 0) { + if (interp2 != NULL) { + Tcl_DeleteInterp(interp2); + } + interp2 = Tcl_CreateInterp(); + return TCL_OK; + } else if (strcmp(argv[1], "delete") == 0) { + if (interp2 != NULL) { + Tcl_DeleteInterp(interp2); + } + interp2 = NULL; + } else if (strcmp(argv[1], "share") == 0) { + if (interp2 != NULL) { + chan = Tcl_GetChannel(interp, argv[2], NULL); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + Tcl_RegisterChannel(interp2, chan); + } + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestPanicCmd -- + * + * Calls the panic routine. + * + * Results: + * Always returns TCL_OK. + * + * Side effects: + * May exit application. + * + *---------------------------------------------------------------------- + */ + +static int +TestPanicCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + char *argString; + + /* + * Put the arguments into a var args structure + * Append all of the arguments together separated by spaces + */ + + argString = Tcl_Merge(argc-1, argv+1); + panic(argString); + ckfree(argString); + + return TCL_OK; +} diff --git a/contrib/tcl/generic/tclUtil.c b/contrib/tcl/generic/tclUtil.c new file mode 100644 index 0000000000000..5f83c58b7e7e4 --- /dev/null +++ b/contrib/tcl/generic/tclUtil.c @@ -0,0 +1,2133 @@ +/* + * tclUtil.c -- + * + * This file contains utility procedures that are used by many Tcl + * commands. + * + * Copyright (c) 1987-1993 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclUtil.c 1.112 96/02/15 11:42:52 + */ + +#include "tclInt.h" +#include "tclPort.h" + +/* + * The following values are used in the flags returned by Tcl_ScanElement + * and used by Tcl_ConvertElement. The value TCL_DONT_USE_BRACES is also + * defined in tcl.h; make sure its value doesn't overlap with any of the + * values below. + * + * TCL_DONT_USE_BRACES - 1 means the string mustn't be enclosed in + * braces (e.g. it contains unmatched braces, + * or ends in a backslash character, or user + * just doesn't want braces); handle all + * special characters by adding backslashes. + * USE_BRACES - 1 means the string contains a special + * character that can be handled simply by + * enclosing the entire argument in braces. + * BRACES_UNMATCHED - 1 means that braces aren't properly matched + * in the argument. + */ + +#define USE_BRACES 2 +#define BRACES_UNMATCHED 4 + +/* + * Function prototypes for local procedures in this file: + */ + +static void SetupAppendBuffer _ANSI_ARGS_((Interp *iPtr, + int newSpace)); + +/* + *---------------------------------------------------------------------- + * + * TclFindElement -- + * + * Given a pointer into a Tcl list, locate the first (or next) + * element in the list. + * + * Results: + * The return value is normally TCL_OK, which means that the + * element was successfully located. If TCL_ERROR is returned + * it means that list didn't have proper list structure; + * interp->result contains a more detailed error message. + * + * If TCL_OK is returned, then *elementPtr will be set to point + * to the first element of list, and *nextPtr will be set to point + * to the character just after any white space following the last + * character that's part of the element. If this is the last argument + * in the list, then *nextPtr will point to the NULL character at the + * end of list. If sizePtr is non-NULL, *sizePtr is filled in with + * the number of characters in the element. If the element is in + * braces, then *elementPtr will point to the character after the + * opening brace and *sizePtr will not include either of the braces. + * If there isn't an element in the list, *sizePtr will be zero, and + * both *elementPtr and *termPtr will refer to the null character at + * the end of list. Note: this procedure does NOT collapse backslash + * sequences. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclFindElement(interp, list, elementPtr, nextPtr, sizePtr, bracePtr) + Tcl_Interp *interp; /* Interpreter to use for error reporting. + * If NULL, then no error message is left + * after errors. */ + register char *list; /* String containing Tcl list with zero + * or more elements (possibly in braces). */ + char **elementPtr; /* Fill in with location of first significant + * character in first element of list. */ + char **nextPtr; /* Fill in with location of character just + * after all white space following end of + * argument (i.e. next argument or end of + * list). */ + int *sizePtr; /* If non-zero, fill in with size of + * element. */ + int *bracePtr; /* If non-zero fill in with non-zero/zero + * to indicate that arg was/wasn't + * in braces. */ +{ + register char *p; + int openBraces = 0; + int inQuotes = 0; + int size; + + /* + * Skim off leading white space and check for an opening brace or + * quote. Note: use of "isascii" below and elsewhere in this + * procedure is a temporary hack (7/27/90) because Mx uses characters + * with the high-order bit set for some things. This should probably + * be changed back eventually, or all of Tcl should call isascii. + */ + + while (isspace(UCHAR(*list))) { + list++; + } + if (*list == '{') { + openBraces = 1; + list++; + } else if (*list == '"') { + inQuotes = 1; + list++; + } + if (bracePtr != 0) { + *bracePtr = openBraces; + } + p = list; + + /* + * Find the end of the element (either a space or a close brace or + * the end of the string). + */ + + while (1) { + switch (*p) { + + /* + * Open brace: don't treat specially unless the element is + * in braces. In this case, keep a nesting count. + */ + + case '{': + if (openBraces != 0) { + openBraces++; + } + break; + + /* + * Close brace: if element is in braces, keep nesting + * count and quit when the last close brace is seen. + */ + + case '}': + if (openBraces == 1) { + char *p2; + + size = p - list; + p++; + if (isspace(UCHAR(*p)) || (*p == 0)) { + goto done; + } + for (p2 = p; (*p2 != 0) && (!isspace(UCHAR(*p2))) + && (p2 < p+20); p2++) { + /* null body */ + } + if (interp != NULL) { + Tcl_ResetResult(interp); + sprintf(interp->result, + "list element in braces followed by \"%.*s\" instead of space", + (int) (p2-p), p); + } + return TCL_ERROR; + } else if (openBraces != 0) { + openBraces--; + } + break; + + /* + * Backslash: skip over everything up to the end of the + * backslash sequence. + */ + + case '\\': { + int size; + + (void) Tcl_Backslash(p, &size); + p += size - 1; + break; + } + + /* + * Space: ignore if element is in braces or quotes; otherwise + * terminate element. + */ + + case ' ': + case '\f': + case '\n': + case '\r': + case '\t': + case '\v': + if ((openBraces == 0) && !inQuotes) { + size = p - list; + goto done; + } + break; + + /* + * Double-quote: if element is in quotes then terminate it. + */ + + case '"': + if (inQuotes) { + char *p2; + + size = p-list; + p++; + if (isspace(UCHAR(*p)) || (*p == 0)) { + goto done; + } + for (p2 = p; (*p2 != 0) && (!isspace(UCHAR(*p2))) + && (p2 < p+20); p2++) { + /* null body */ + } + if (interp != NULL) { + Tcl_ResetResult(interp); + sprintf(interp->result, + "list element in quotes followed by \"%.*s\" %s", (int) (p2-p), p, + "instead of space"); + } + return TCL_ERROR; + } + break; + + /* + * End of list: terminate element. + */ + + case 0: + if (openBraces != 0) { + if (interp != NULL) { + Tcl_SetResult(interp, "unmatched open brace in list", + TCL_STATIC); + } + return TCL_ERROR; + } else if (inQuotes) { + if (interp != NULL) { + Tcl_SetResult(interp, "unmatched open quote in list", + TCL_STATIC); + } + return TCL_ERROR; + } + size = p - list; + goto done; + + } + p++; + } + + done: + while (isspace(UCHAR(*p))) { + p++; + } + *elementPtr = list; + *nextPtr = p; + if (sizePtr != 0) { + *sizePtr = size; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCopyAndCollapse -- + * + * Copy a string and eliminate any backslashes that aren't in braces. + * + * Results: + * There is no return value. Count chars. get copied from src + * to dst. Along the way, if backslash sequences are found outside + * braces, the backslashes are eliminated in the copy. + * After scanning count chars. from source, a null character is + * placed at the end of dst. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +TclCopyAndCollapse(count, src, dst) + int count; /* Total number of characters to copy + * from src. */ + register char *src; /* Copy from here... */ + register char *dst; /* ... to here. */ +{ + register char c; + int numRead; + + for (c = *src; count > 0; src++, c = *src, count--) { + if (c == '\\') { + *dst = Tcl_Backslash(src, &numRead); + dst++; + src += numRead-1; + count -= numRead-1; + } else { + *dst = c; + dst++; + } + } + *dst = 0; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SplitList -- + * + * Splits a list up into its constituent fields. + * + * Results + * The return value is normally TCL_OK, which means that + * the list was successfully split up. If TCL_ERROR is + * returned, it means that "list" didn't have proper list + * structure; interp->result will contain a more detailed + * error message. + * + * *argvPtr will be filled in with the address of an array + * whose elements point to the elements of list, in order. + * *argcPtr will get filled in with the number of valid elements + * in the array. A single block of memory is dynamically allocated + * to hold both the argv array and a copy of the list (with + * backslashes and braces removed in the standard way). + * The caller must eventually free this memory by calling free() + * on *argvPtr. Note: *argvPtr and *argcPtr are only modified + * if the procedure returns normally. + * + * Side effects: + * Memory is allocated. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_SplitList(interp, list, argcPtr, argvPtr) + Tcl_Interp *interp; /* Interpreter to use for error reporting. + * If NULL, then no error message is left. */ + char *list; /* Pointer to string with list structure. */ + int *argcPtr; /* Pointer to location to fill in with + * the number of elements in the list. */ + char ***argvPtr; /* Pointer to place to store pointer to array + * of pointers to list elements. */ +{ + char **argv; + register char *p; + int size, i, result, elSize, brace; + char *element; + + /* + * Figure out how much space to allocate. There must be enough + * space for both the array of pointers and also for a copy of + * the list. To estimate the number of pointers needed, count + * the number of space characters in the list. + */ + + for (size = 1, p = list; *p != 0; p++) { + if (isspace(UCHAR(*p))) { + size++; + } + } + size++; /* Leave space for final NULL pointer. */ + argv = (char **) ckalloc((unsigned) + ((size * sizeof(char *)) + (p - list) + 1)); + for (i = 0, p = ((char *) argv) + size*sizeof(char *); + *list != 0; i++) { + result = TclFindElement(interp, list, &element, &list, &elSize, &brace); + if (result != TCL_OK) { + ckfree((char *) argv); + return result; + } + if (*element == 0) { + break; + } + if (i >= size) { + ckfree((char *) argv); + if (interp != NULL) { + Tcl_SetResult(interp, "internal error in Tcl_SplitList", + TCL_STATIC); + } + return TCL_ERROR; + } + argv[i] = p; + if (brace) { + strncpy(p, element, (size_t) elSize); + p += elSize; + *p = 0; + p++; + } else { + TclCopyAndCollapse(elSize, element, p); + p += elSize+1; + } + } + + argv[i] = NULL; + *argvPtr = argv; + *argcPtr = i; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ScanElement -- + * + * This procedure is a companion procedure to Tcl_ConvertElement. + * It scans a string to see what needs to be done to it (e.g. + * add backslashes or enclosing braces) to make the string into + * a valid Tcl list element. + * + * Results: + * The return value is an overestimate of the number of characters + * that will be needed by Tcl_ConvertElement to produce a valid + * list element from string. The word at *flagPtr is filled in + * with a value needed by Tcl_ConvertElement when doing the actual + * conversion. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_ScanElement(string, flagPtr) + char *string; /* String to convert to Tcl list element. */ + int *flagPtr; /* Where to store information to guide + * Tcl_ConvertElement. */ +{ + int flags, nestingLevel; + register char *p; + + /* + * This procedure and Tcl_ConvertElement together do two things: + * + * 1. They produce a proper list, one that will yield back the + * argument strings when evaluated or when disassembled with + * Tcl_SplitList. This is the most important thing. + * + * 2. They try to produce legible output, which means minimizing the + * use of backslashes (using braces instead). However, there are + * some situations where backslashes must be used (e.g. an element + * like "{abc": the leading brace will have to be backslashed. For + * each element, one of three things must be done: + * + * (a) Use the element as-is (it doesn't contain anything special + * characters). This is the most desirable option. + * + * (b) Enclose the element in braces, but leave the contents alone. + * This happens if the element contains embedded space, or if it + * contains characters with special interpretation ($, [, ;, or \), + * or if it starts with a brace or double-quote, or if there are + * no characters in the element. + * + * (c) Don't enclose the element in braces, but add backslashes to + * prevent special interpretation of special characters. This is a + * last resort used when the argument would normally fall under case + * (b) but contains unmatched braces. It also occurs if the last + * character of the argument is a backslash or if the element contains + * a backslash followed by newline. + * + * The procedure figures out how many bytes will be needed to store + * the result (actually, it overestimates). It also collects information + * about the element in the form of a flags word. + */ + + nestingLevel = 0; + flags = 0; + if (string == NULL) { + string = ""; + } + p = string; + if ((*p == '{') || (*p == '"') || (*p == 0)) { + flags |= USE_BRACES; + } + for ( ; *p != 0; p++) { + switch (*p) { + case '{': + nestingLevel++; + break; + case '}': + nestingLevel--; + if (nestingLevel < 0) { + flags |= TCL_DONT_USE_BRACES|BRACES_UNMATCHED; + } + break; + case '[': + case '$': + case ';': + case ' ': + case '\f': + case '\n': + case '\r': + case '\t': + case '\v': + flags |= USE_BRACES; + break; + case '\\': + if ((p[1] == 0) || (p[1] == '\n')) { + flags = TCL_DONT_USE_BRACES; + } else { + int size; + + (void) Tcl_Backslash(p, &size); + p += size-1; + flags |= USE_BRACES; + } + break; + } + } + if (nestingLevel != 0) { + flags = TCL_DONT_USE_BRACES | BRACES_UNMATCHED; + } + *flagPtr = flags; + + /* + * Allow enough space to backslash every character plus leave + * two spaces for braces. + */ + + return 2*(p-string) + 2; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ConvertElement -- + * + * This is a companion procedure to Tcl_ScanElement. Given the + * information produced by Tcl_ScanElement, this procedure converts + * a string to a list element equal to that string. + * + * Results: + * Information is copied to *dst in the form of a list element + * identical to src (i.e. if Tcl_SplitList is applied to dst it + * will produce a string identical to src). The return value is + * a count of the number of characters copied (not including the + * terminating NULL character). + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_ConvertElement(src, dst, flags) + register char *src; /* Source information for list element. */ + char *dst; /* Place to put list-ified element. */ + int flags; /* Flags produced by Tcl_ScanElement. */ +{ + register char *p = dst; + + /* + * See the comment block at the beginning of the Tcl_ScanElement + * code for details of how this works. + */ + + if ((src == NULL) || (*src == 0)) { + p[0] = '{'; + p[1] = '}'; + p[2] = 0; + return 2; + } + if ((flags & USE_BRACES) && !(flags & TCL_DONT_USE_BRACES)) { + *p = '{'; + p++; + for ( ; *src != 0; src++, p++) { + *p = *src; + } + *p = '}'; + p++; + } else { + if (*src == '{') { + /* + * Can't have a leading brace unless the whole element is + * enclosed in braces. Add a backslash before the brace. + * Furthermore, this may destroy the balance between open + * and close braces, so set BRACES_UNMATCHED. + */ + + p[0] = '\\'; + p[1] = '{'; + p += 2; + src++; + flags |= BRACES_UNMATCHED; + } + for (; *src != 0 ; src++) { + switch (*src) { + case ']': + case '[': + case '$': + case ';': + case ' ': + case '\\': + case '"': + *p = '\\'; + p++; + break; + case '{': + case '}': + /* + * It may not seem necessary to backslash braces, but + * it is. The reason for this is that the resulting + * list element may actually be an element of a sub-list + * enclosed in braces (e.g. if Tcl_DStringStartSublist + * has been invoked), so there may be a brace mismatch + * if the braces aren't backslashed. + */ + + if (flags & BRACES_UNMATCHED) { + *p = '\\'; + p++; + } + break; + case '\f': + *p = '\\'; + p++; + *p = 'f'; + p++; + continue; + case '\n': + *p = '\\'; + p++; + *p = 'n'; + p++; + continue; + case '\r': + *p = '\\'; + p++; + *p = 'r'; + p++; + continue; + case '\t': + *p = '\\'; + p++; + *p = 't'; + p++; + continue; + case '\v': + *p = '\\'; + p++; + *p = 'v'; + p++; + continue; + } + *p = *src; + p++; + } + } + *p = '\0'; + return p-dst; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_Merge -- + * + * Given a collection of strings, merge them together into a + * single string that has proper Tcl list structured (i.e. + * Tcl_SplitList may be used to retrieve strings equal to the + * original elements, and Tcl_Eval will parse the string back + * into its original elements). + * + * Results: + * The return value is the address of a dynamically-allocated + * string containing the merged list. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_Merge(argc, argv) + int argc; /* How many strings to merge. */ + char **argv; /* Array of string values. */ +{ +# define LOCAL_SIZE 20 + int localFlags[LOCAL_SIZE], *flagPtr; + int numChars; + char *result; + register char *dst; + int i; + + /* + * Pass 1: estimate space, gather flags. + */ + + if (argc <= LOCAL_SIZE) { + flagPtr = localFlags; + } else { + flagPtr = (int *) ckalloc((unsigned) argc*sizeof(int)); + } + numChars = 1; + for (i = 0; i < argc; i++) { + numChars += Tcl_ScanElement(argv[i], &flagPtr[i]) + 1; + } + + /* + * Pass two: copy into the result area. + */ + + result = (char *) ckalloc((unsigned) numChars); + dst = result; + for (i = 0; i < argc; i++) { + numChars = Tcl_ConvertElement(argv[i], dst, flagPtr[i]); + dst += numChars; + *dst = ' '; + dst++; + } + if (dst == result) { + *dst = 0; + } else { + dst[-1] = 0; + } + + if (flagPtr != localFlags) { + ckfree((char *) flagPtr); + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_Concat -- + * + * Concatenate a set of strings into a single large string. + * + * Results: + * The return value is dynamically-allocated string containing + * a concatenation of all the strings in argv, with spaces between + * the original argv elements. + * + * Side effects: + * Memory is allocated for the result; the caller is responsible + * for freeing the memory. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_Concat(argc, argv) + int argc; /* Number of strings to concatenate. */ + char **argv; /* Array of strings to concatenate. */ +{ + int totalSize, i; + register char *p; + char *result; + + for (totalSize = 1, i = 0; i < argc; i++) { + totalSize += strlen(argv[i]) + 1; + } + result = (char *) ckalloc((unsigned) totalSize); + if (argc == 0) { + *result = '\0'; + return result; + } + for (p = result, i = 0; i < argc; i++) { + char *element; + int length; + + /* + * Clip white space off the front and back of the string + * to generate a neater result, and ignore any empty + * elements. + */ + + element = argv[i]; + while (isspace(UCHAR(*element))) { + element++; + } + for (length = strlen(element); + (length > 0) && (isspace(UCHAR(element[length-1]))); + length--) { + /* Null loop body. */ + } + if (length == 0) { + continue; + } + (void) strncpy(p, element, (size_t) length); + p += length; + *p = ' '; + p++; + } + if (p != result) { + p[-1] = 0; + } else { + *p = 0; + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_StringMatch -- + * + * See if a particular string matches a particular pattern. + * + * Results: + * The return value is 1 if string matches pattern, and + * 0 otherwise. The matching operation permits the following + * special characters in the pattern: *?\[] (see the manual + * entry for details on what these mean). + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_StringMatch(string, pattern) + register char *string; /* String. */ + register char *pattern; /* Pattern, which may contain + * special characters. */ +{ + char c2; + + while (1) { + /* See if we're at the end of both the pattern and the string. + * If so, we succeeded. If we're at the end of the pattern + * but not at the end of the string, we failed. + */ + + if (*pattern == 0) { + if (*string == 0) { + return 1; + } else { + return 0; + } + } + if ((*string == 0) && (*pattern != '*')) { + return 0; + } + + /* Check for a "*" as the next pattern character. It matches + * any substring. We handle this by calling ourselves + * recursively for each postfix of string, until either we + * match or we reach the end of the string. + */ + + if (*pattern == '*') { + pattern += 1; + if (*pattern == 0) { + return 1; + } + while (1) { + if (Tcl_StringMatch(string, pattern)) { + return 1; + } + if (*string == 0) { + return 0; + } + string += 1; + } + } + + /* Check for a "?" as the next pattern character. It matches + * any single character. + */ + + if (*pattern == '?') { + goto thisCharOK; + } + + /* Check for a "[" as the next pattern character. It is followed + * by a list of characters that are acceptable, or by a range + * (two characters separated by "-"). + */ + + if (*pattern == '[') { + pattern += 1; + while (1) { + if ((*pattern == ']') || (*pattern == 0)) { + return 0; + } + if (*pattern == *string) { + break; + } + if (pattern[1] == '-') { + c2 = pattern[2]; + if (c2 == 0) { + return 0; + } + if ((*pattern <= *string) && (c2 >= *string)) { + break; + } + if ((*pattern >= *string) && (c2 <= *string)) { + break; + } + pattern += 2; + } + pattern += 1; + } + while (*pattern != ']') { + if (*pattern == 0) { + pattern--; + break; + } + pattern += 1; + } + goto thisCharOK; + } + + /* If the next pattern character is '/', just strip off the '/' + * so we do exact matching on the character that follows. + */ + + if (*pattern == '\\') { + pattern += 1; + if (*pattern == 0) { + return 0; + } + } + + /* There's no special character. Just make sure that the next + * characters of each string match. + */ + + if (*pattern != *string) { + return 0; + } + + thisCharOK: pattern += 1; + string += 1; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetResult -- + * + * Arrange for "string" to be the Tcl return value. + * + * Results: + * None. + * + * Side effects: + * interp->result is left pointing either to "string" (if "copy" is 0) + * or to a copy of string. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SetResult(interp, string, freeProc) + Tcl_Interp *interp; /* Interpreter with which to associate the + * return value. */ + char *string; /* Value to be returned. If NULL, + * the result is set to an empty string. */ + Tcl_FreeProc *freeProc; /* Gives information about the string: + * TCL_STATIC, TCL_VOLATILE, or the address + * of a Tcl_FreeProc such as free. */ +{ + register Interp *iPtr = (Interp *) interp; + int length; + Tcl_FreeProc *oldFreeProc = iPtr->freeProc; + char *oldResult = iPtr->result; + + if (string == NULL) { + iPtr->resultSpace[0] = 0; + iPtr->result = iPtr->resultSpace; + iPtr->freeProc = 0; + } else if (freeProc == TCL_DYNAMIC) { + iPtr->result = string; + iPtr->freeProc = TCL_DYNAMIC; + } else if (freeProc == TCL_VOLATILE) { + length = strlen(string); + if (length > TCL_RESULT_SIZE) { + iPtr->result = (char *) ckalloc((unsigned) length+1); + iPtr->freeProc = TCL_DYNAMIC; + } else { + iPtr->result = iPtr->resultSpace; + iPtr->freeProc = 0; + } + strcpy(iPtr->result, string); + } else { + iPtr->result = string; + iPtr->freeProc = freeProc; + } + + /* + * If the old result was dynamically-allocated, free it up. Do it + * here, rather than at the beginning, in case the new result value + * was part of the old result value. + */ + + if (oldFreeProc != 0) { + if ((oldFreeProc == TCL_DYNAMIC) + || (oldFreeProc == (Tcl_FreeProc *) free)) { + ckfree(oldResult); + } else { + (*oldFreeProc)(oldResult); + } + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_AppendResult -- + * + * Append a variable number of strings onto the result already + * present for an interpreter. + * + * Results: + * None. + * + * Side effects: + * The result in the interpreter given by the first argument + * is extended by the strings given by the second and following + * arguments (up to a terminating NULL argument). + * + *---------------------------------------------------------------------- + */ + + /* VARARGS2 */ +void +Tcl_AppendResult TCL_VARARGS_DEF(Tcl_Interp *,arg1) +{ + va_list argList; + register Interp *iPtr; + char *string; + int newSpace; + + /* + * First, scan through all the arguments to see how much space is + * needed. + */ + + iPtr = (Interp *) TCL_VARARGS_START(Tcl_Interp *,arg1,argList); + newSpace = 0; + while (1) { + string = va_arg(argList, char *); + if (string == NULL) { + break; + } + newSpace += strlen(string); + } + va_end(argList); + + /* + * If the append buffer isn't already setup and large enough + * to hold the new data, set it up. + */ + + if ((iPtr->result != iPtr->appendResult) + || (iPtr->appendResult[iPtr->appendUsed] != 0) + || ((newSpace + iPtr->appendUsed) >= iPtr->appendAvl)) { + SetupAppendBuffer(iPtr, newSpace); + } + + /* + * Final step: go through all the argument strings again, copying + * them into the buffer. + */ + + TCL_VARARGS_START(Tcl_Interp *,arg1,argList); + while (1) { + string = va_arg(argList, char *); + if (string == NULL) { + break; + } + strcpy(iPtr->appendResult + iPtr->appendUsed, string); + iPtr->appendUsed += strlen(string); + } + va_end(argList); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_AppendElement -- + * + * Convert a string to a valid Tcl list element and append it + * to the current result (which is ostensibly a list). + * + * Results: + * None. + * + * Side effects: + * The result in the interpreter given by the first argument + * is extended with a list element converted from string. A + * separator space is added before the converted list element + * unless the current result is empty, contains the single + * character "{", or ends in " {". + * + *---------------------------------------------------------------------- + */ + +void +Tcl_AppendElement(interp, string) + Tcl_Interp *interp; /* Interpreter whose result is to be + * extended. */ + char *string; /* String to convert to list element and + * add to result. */ +{ + register Interp *iPtr = (Interp *) interp; + int size, flags; + char *dst; + + /* + * See how much space is needed, and grow the append buffer if + * needed to accommodate the list element. + */ + + size = Tcl_ScanElement(string, &flags) + 1; + if ((iPtr->result != iPtr->appendResult) + || (iPtr->appendResult[iPtr->appendUsed] != 0) + || ((size + iPtr->appendUsed) >= iPtr->appendAvl)) { + SetupAppendBuffer(iPtr, size+iPtr->appendUsed); + } + + /* + * Convert the string into a list element and copy it to the + * buffer that's forming, with a space separator if needed. + */ + + dst = iPtr->appendResult + iPtr->appendUsed; + if (TclNeedSpace(iPtr->appendResult, dst)) { + iPtr->appendUsed++; + *dst = ' '; + dst++; + } + iPtr->appendUsed += Tcl_ConvertElement(string, dst, flags); +} + +/* + *---------------------------------------------------------------------- + * + * SetupAppendBuffer -- + * + * This procedure makes sure that there is an append buffer + * properly initialized for interp, and that it has at least + * enough room to accommodate newSpace new bytes of information. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +SetupAppendBuffer(iPtr, newSpace) + register Interp *iPtr; /* Interpreter whose result is being set up. */ + int newSpace; /* Make sure that at least this many bytes + * of new information may be added. */ +{ + int totalSpace; + + /* + * Make the append buffer larger, if that's necessary, then + * copy the current result into the append buffer and make the + * append buffer the official Tcl result. + */ + + if (iPtr->result != iPtr->appendResult) { + /* + * If an oversized buffer was used recently, then free it up + * so we go back to a smaller buffer. This avoids tying up + * memory forever after a large operation. + */ + + if (iPtr->appendAvl > 500) { + ckfree(iPtr->appendResult); + iPtr->appendResult = NULL; + iPtr->appendAvl = 0; + } + iPtr->appendUsed = strlen(iPtr->result); + } else if (iPtr->result[iPtr->appendUsed] != 0) { + /* + * Most likely someone has modified a result created by + * Tcl_AppendResult et al. so that it has a different size. + * Just recompute the size. + */ + + iPtr->appendUsed = strlen(iPtr->result); + } + totalSpace = newSpace + iPtr->appendUsed; + if (totalSpace >= iPtr->appendAvl) { + char *new; + + if (totalSpace < 100) { + totalSpace = 200; + } else { + totalSpace *= 2; + } + new = (char *) ckalloc((unsigned) totalSpace); + strcpy(new, iPtr->result); + if (iPtr->appendResult != NULL) { + ckfree(iPtr->appendResult); + } + iPtr->appendResult = new; + iPtr->appendAvl = totalSpace; + } else if (iPtr->result != iPtr->appendResult) { + strcpy(iPtr->appendResult, iPtr->result); + } + Tcl_FreeResult(iPtr); + iPtr->result = iPtr->appendResult; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ResetResult -- + * + * This procedure restores the result area for an interpreter + * to its default initialized state, freeing up any memory that + * may have been allocated for the result and clearing any + * error information for the interpreter. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_ResetResult(interp) + Tcl_Interp *interp; /* Interpreter for which to clear result. */ +{ + register Interp *iPtr = (Interp *) interp; + + Tcl_FreeResult(iPtr); + iPtr->result = iPtr->resultSpace; + iPtr->resultSpace[0] = 0; + iPtr->flags &= + ~(ERR_ALREADY_LOGGED | ERR_IN_PROGRESS | ERROR_CODE_SET); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetErrorCode -- + * + * This procedure is called to record machine-readable information + * about an error that is about to be returned. + * + * Results: + * None. + * + * Side effects: + * The errorCode global variable is modified to hold all of the + * arguments to this procedure, in a list form with each argument + * becoming one element of the list. A flag is set internally + * to remember that errorCode has been set, so the variable doesn't + * get set automatically when the error is returned. + * + *---------------------------------------------------------------------- + */ + /* VARARGS2 */ +void +Tcl_SetErrorCode TCL_VARARGS_DEF(Tcl_Interp *,arg1) +{ + va_list argList; + char *string; + int flags; + Interp *iPtr; + + /* + * Scan through the arguments one at a time, appending them to + * $errorCode as list elements. + */ + + iPtr = (Interp *) TCL_VARARGS_START(Tcl_Interp *,arg1,argList); + flags = TCL_GLOBAL_ONLY | TCL_LIST_ELEMENT; + while (1) { + string = va_arg(argList, char *); + if (string == NULL) { + break; + } + (void) Tcl_SetVar2((Tcl_Interp *) iPtr, "errorCode", + (char *) NULL, string, flags); + flags |= TCL_APPEND_VALUE; + } + va_end(argList); + iPtr->flags |= ERROR_CODE_SET; +} + +/* + *---------------------------------------------------------------------- + * + * TclGetListIndex -- + * + * Parse a list index, which may be either an integer or the + * value "end". + * + * Results: + * The return value is either TCL_OK or TCL_ERROR. If it is + * TCL_OK, then the index corresponding to string is left in + * *indexPtr. If the return value is TCL_ERROR, then string + * was bogus; an error message is returned in interp->result. + * If a negative index is specified, it is rounded up to 0. + * The index value may be larger than the size of the list + * (this happens when "end" is specified). + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclGetListIndex(interp, string, indexPtr) + Tcl_Interp *interp; /* Interpreter for error reporting. */ + char *string; /* String containing list index. */ + int *indexPtr; /* Where to store index. */ +{ + if (isdigit(UCHAR(*string)) || (*string == '-')) { + if (Tcl_GetInt(interp, string, indexPtr) != TCL_OK) { + return TCL_ERROR; + } + if (*indexPtr < 0) { + *indexPtr = 0; + } + } else if (strncmp(string, "end", strlen(string)) == 0) { + *indexPtr = INT_MAX; + } else { + Tcl_AppendResult(interp, "bad index \"", string, + "\": must be integer or \"end\"", (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_RegExpCompile -- + * + * Compile a regular expression into a form suitable for fast + * matching. This procedure retains a small cache of pre-compiled + * regular expressions in the interpreter, in order to avoid + * compilation costs as much as possible. + * + * Results: + * The return value is a pointer to the compiled form of string, + * suitable for passing to Tcl_RegExpExec. This compiled form + * is only valid up until the next call to this procedure, so + * don't keep these around for a long time! If an error occurred + * while compiling the pattern, then NULL is returned and an error + * message is left in interp->result. + * + * Side effects: + * The cache of compiled regexp's in interp will be modified to + * hold information for string, if such information isn't already + * present in the cache. + * + *---------------------------------------------------------------------- + */ + +Tcl_RegExp +Tcl_RegExpCompile(interp, string) + Tcl_Interp *interp; /* For use in error reporting. */ + char *string; /* String for which to produce + * compiled regular expression. */ +{ + register Interp *iPtr = (Interp *) interp; + int i, length; + regexp *result; + + length = strlen(string); + for (i = 0; i < NUM_REGEXPS; i++) { + if ((length == iPtr->patLengths[i]) + && (strcmp(string, iPtr->patterns[i]) == 0)) { + /* + * Move the matched pattern to the first slot in the + * cache and shift the other patterns down one position. + */ + + if (i != 0) { + int j; + char *cachedString; + + cachedString = iPtr->patterns[i]; + result = iPtr->regexps[i]; + for (j = i-1; j >= 0; j--) { + iPtr->patterns[j+1] = iPtr->patterns[j]; + iPtr->patLengths[j+1] = iPtr->patLengths[j]; + iPtr->regexps[j+1] = iPtr->regexps[j]; + } + iPtr->patterns[0] = cachedString; + iPtr->patLengths[0] = length; + iPtr->regexps[0] = result; + } + return (Tcl_RegExp) iPtr->regexps[0]; + } + } + + /* + * No match in the cache. Compile the string and add it to the + * cache. + */ + + TclRegError((char *) NULL); + result = TclRegComp(string); + if (TclGetRegError() != NULL) { + Tcl_AppendResult(interp, + "couldn't compile regular expression pattern: ", + TclGetRegError(), (char *) NULL); + return NULL; + } + if (iPtr->patterns[NUM_REGEXPS-1] != NULL) { + ckfree(iPtr->patterns[NUM_REGEXPS-1]); + ckfree((char *) iPtr->regexps[NUM_REGEXPS-1]); + } + for (i = NUM_REGEXPS - 2; i >= 0; i--) { + iPtr->patterns[i+1] = iPtr->patterns[i]; + iPtr->patLengths[i+1] = iPtr->patLengths[i]; + iPtr->regexps[i+1] = iPtr->regexps[i]; + } + iPtr->patterns[0] = (char *) ckalloc((unsigned) (length+1)); + strcpy(iPtr->patterns[0], string); + iPtr->patLengths[0] = length; + iPtr->regexps[0] = result; + return (Tcl_RegExp) result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_RegExpExec -- + * + * Execute the regular expression matcher using a compiled form + * of a regular expression and save information about any match + * that is found. + * + * Results: + * If an error occurs during the matching operation then -1 + * is returned and interp->result contains an error message. + * Otherwise the return value is 1 if a matching range is + * found and 0 if there is no matching range. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_RegExpExec(interp, re, string, start) + Tcl_Interp *interp; /* Interpreter to use for error reporting. */ + Tcl_RegExp re; /* Compiled regular expression; must have + * been returned by previous call to + * Tcl_RegExpCompile. */ + char *string; /* String against which to match re. */ + char *start; /* If string is part of a larger string, + * this identifies beginning of larger + * string, so that "^" won't match. */ +{ + int match; + + regexp *regexpPtr = (regexp *) re; + TclRegError((char *) NULL); + match = TclRegExec(regexpPtr, string, start); + if (TclGetRegError() != NULL) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "error while matching regular expression: ", + TclGetRegError(), (char *) NULL); + return -1; + } + return match; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_RegExpRange -- + * + * Returns pointers describing the range of a regular expression match, + * or one of the subranges within the match. + * + * Results: + * The variables at *startPtr and *endPtr are modified to hold the + * addresses of the endpoints of the range given by index. If the + * specified range doesn't exist then NULLs are returned. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_RegExpRange(re, index, startPtr, endPtr) + Tcl_RegExp re; /* Compiled regular expression that has + * been passed to Tcl_RegExpExec. */ + int index; /* 0 means give the range of the entire + * match, > 0 means give the range of + * a matching subrange. Must be no greater + * than NSUBEXP. */ + char **startPtr; /* Store address of first character in + * (sub-) range here. */ + char **endPtr; /* Store address of character just after last + * in (sub-) range here. */ +{ + regexp *regexpPtr = (regexp *) re; + + if (index >= NSUBEXP) { + *startPtr = *endPtr = NULL; + } else { + *startPtr = regexpPtr->startp[index]; + *endPtr = regexpPtr->endp[index]; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_RegExpMatch -- + * + * See if a string matches a regular expression. + * + * Results: + * If an error occurs during the matching operation then -1 + * is returned and interp->result contains an error message. + * Otherwise the return value is 1 if "string" matches "pattern" + * and 0 otherwise. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_RegExpMatch(interp, string, pattern) + Tcl_Interp *interp; /* Used for error reporting. */ + char *string; /* String. */ + char *pattern; /* Regular expression to match against + * string. */ +{ + Tcl_RegExp re; + + re = Tcl_RegExpCompile(interp, pattern); + if (re == NULL) { + return -1; + } + return Tcl_RegExpExec(interp, re, string, string); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DStringInit -- + * + * Initializes a dynamic string, discarding any previous contents + * of the string (Tcl_DStringFree should have been called already + * if the dynamic string was previously in use). + * + * Results: + * None. + * + * Side effects: + * The dynamic string is initialized to be empty. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DStringInit(dsPtr) + register Tcl_DString *dsPtr; /* Pointer to structure for + * dynamic string. */ +{ + dsPtr->string = dsPtr->staticSpace; + dsPtr->length = 0; + dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; + dsPtr->staticSpace[0] = 0; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DStringAppend -- + * + * Append more characters to the current value of a dynamic string. + * + * Results: + * The return value is a pointer to the dynamic string's new value. + * + * Side effects: + * Length bytes from string (or all of string if length is less + * than zero) are added to the current value of the string. Memory + * gets reallocated if needed to accomodate the string's new size. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_DStringAppend(dsPtr, string, length) + register Tcl_DString *dsPtr; /* Structure describing dynamic + * string. */ + char *string; /* String to append. If length is + * -1 then this must be + * null-terminated. */ + int length; /* Number of characters from string + * to append. If < 0, then append all + * of string, up to null at end. */ +{ + int newSize; + char *newString, *dst, *end; + + if (length < 0) { + length = strlen(string); + } + newSize = length + dsPtr->length; + + /* + * Allocate a larger buffer for the string if the current one isn't + * large enough. Allocate extra space in the new buffer so that there + * will be room to grow before we have to allocate again. + */ + + if (newSize >= dsPtr->spaceAvl) { + dsPtr->spaceAvl = newSize*2; + newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl); + memcpy((VOID *)newString, (VOID *) dsPtr->string, + (size_t) dsPtr->length); + if (dsPtr->string != dsPtr->staticSpace) { + ckfree(dsPtr->string); + } + dsPtr->string = newString; + } + + /* + * Copy the new string into the buffer at the end of the old + * one. + */ + + for (dst = dsPtr->string + dsPtr->length, end = string+length; + string < end; string++, dst++) { + *dst = *string; + } + *dst = 0; + dsPtr->length += length; + return dsPtr->string; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DStringAppendElement -- + * + * Append a list element to the current value of a dynamic string. + * + * Results: + * The return value is a pointer to the dynamic string's new value. + * + * Side effects: + * String is reformatted as a list element and added to the current + * value of the string. Memory gets reallocated if needed to + * accomodate the string's new size. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_DStringAppendElement(dsPtr, string) + register Tcl_DString *dsPtr; /* Structure describing dynamic + * string. */ + char *string; /* String to append. Must be + * null-terminated. */ +{ + int newSize, flags; + char *dst, *newString; + + newSize = Tcl_ScanElement(string, &flags) + dsPtr->length + 1; + + /* + * Allocate a larger buffer for the string if the current one isn't + * large enough. Allocate extra space in the new buffer so that there + * will be room to grow before we have to allocate again. + * SPECIAL NOTE: must use memcpy, not strcpy, to copy the string + * to a larger buffer, since there may be embedded NULLs in the + * string in some cases. + */ + + if (newSize >= dsPtr->spaceAvl) { + dsPtr->spaceAvl = newSize*2; + newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl); + memcpy((VOID *) newString, (VOID *) dsPtr->string, + (size_t) dsPtr->length); + if (dsPtr->string != dsPtr->staticSpace) { + ckfree(dsPtr->string); + } + dsPtr->string = newString; + } + + /* + * Convert the new string to a list element and copy it into the + * buffer at the end, with a space, if needed. + */ + + dst = dsPtr->string + dsPtr->length; + if (TclNeedSpace(dsPtr->string, dst)) { + *dst = ' '; + dst++; + dsPtr->length++; + } + dsPtr->length += Tcl_ConvertElement(string, dst, flags); + return dsPtr->string; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DStringSetLength -- + * + * Change the length of a dynamic string. This can cause the + * string to either grow or shrink, depending on the value of + * length. + * + * Results: + * None. + * + * Side effects: + * The length of dsPtr is changed to length and a null byte is + * stored at that position in the string. If length is larger + * than the space allocated for dsPtr, then a panic occurs. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DStringSetLength(dsPtr, length) + register Tcl_DString *dsPtr; /* Structure describing dynamic + * string. */ + int length; /* New length for dynamic string. */ +{ + if (length < 0) { + length = 0; + } + if (length >= dsPtr->spaceAvl) { + char *newString; + + dsPtr->spaceAvl = length+1; + newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl); + + /* + * SPECIAL NOTE: must use memcpy, not strcpy, to copy the string + * to a larger buffer, since there may be embedded NULLs in the + * string in some cases. + */ + + memcpy((VOID *) newString, (VOID *) dsPtr->string, + (size_t) dsPtr->length); + if (dsPtr->string != dsPtr->staticSpace) { + ckfree(dsPtr->string); + } + dsPtr->string = newString; + } + dsPtr->length = length; + dsPtr->string[length] = 0; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DStringFree -- + * + * Frees up any memory allocated for the dynamic string and + * reinitializes the string to an empty state. + * + * Results: + * None. + * + * Side effects: + * The previous contents of the dynamic string are lost, and + * the new value is an empty string. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DStringFree(dsPtr) + register Tcl_DString *dsPtr; /* Structure describing dynamic + * string. */ +{ + if (dsPtr->string != dsPtr->staticSpace) { + ckfree(dsPtr->string); + } + dsPtr->string = dsPtr->staticSpace; + dsPtr->length = 0; + dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; + dsPtr->staticSpace[0] = 0; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DStringResult -- + * + * This procedure moves the value of a dynamic string into an + * interpreter as its result. The string itself is reinitialized + * to an empty string. + * + * Results: + * None. + * + * Side effects: + * The string is "moved" to interp's result, and any existing + * result for interp is freed up. DsPtr is reinitialized to + * an empty string. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DStringResult(interp, dsPtr) + Tcl_Interp *interp; /* Interpreter whose result is to be + * reset. */ + Tcl_DString *dsPtr; /* Dynamic string that is to become + * the result of interp. */ +{ + Tcl_ResetResult(interp); + if (dsPtr->string != dsPtr->staticSpace) { + interp->result = dsPtr->string; + interp->freeProc = TCL_DYNAMIC; + } else if (dsPtr->length < TCL_RESULT_SIZE) { + interp->result = ((Interp *) interp)->resultSpace; + strcpy(interp->result, dsPtr->string); + } else { + Tcl_SetResult(interp, dsPtr->string, TCL_VOLATILE); + } + dsPtr->string = dsPtr->staticSpace; + dsPtr->length = 0; + dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; + dsPtr->staticSpace[0] = 0; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DStringGetResult -- + * + * This procedure moves the result of an interpreter into a + * dynamic string. + * + * Results: + * None. + * + * Side effects: + * The interpreter's result is cleared, and the previous contents + * of dsPtr are freed. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DStringGetResult(interp, dsPtr) + Tcl_Interp *interp; /* Interpreter whose result is to be + * reset. */ + Tcl_DString *dsPtr; /* Dynamic string that is to become + * the result of interp. */ +{ + Interp *iPtr = (Interp *) interp; + if (dsPtr->string != dsPtr->staticSpace) { + ckfree(dsPtr->string); + } + dsPtr->length = strlen(iPtr->result); + if (iPtr->freeProc != NULL) { + if ((iPtr->freeProc == TCL_DYNAMIC) + || (iPtr->freeProc == (Tcl_FreeProc *) free)) { + dsPtr->string = iPtr->result; + dsPtr->spaceAvl = dsPtr->length+1; + } else { + dsPtr->string = (char *) ckalloc((unsigned) (dsPtr->length+1)); + strcpy(dsPtr->string, iPtr->result); + (*iPtr->freeProc)(iPtr->result); + } + dsPtr->spaceAvl = dsPtr->length+1; + iPtr->freeProc = NULL; + } else { + if (dsPtr->length < TCL_DSTRING_STATIC_SIZE) { + dsPtr->string = dsPtr->staticSpace; + dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; + } else { + dsPtr->string = (char *) ckalloc((unsigned) (dsPtr->length + 1)); + dsPtr->spaceAvl = dsPtr->length + 1; + } + strcpy(dsPtr->string, iPtr->result); + } + iPtr->result = iPtr->resultSpace; + iPtr->resultSpace[0] = 0; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DStringStartSublist -- + * + * This procedure adds the necessary information to a dynamic + * string (e.g. " {" to start a sublist. Future element + * appends will be in the sublist rather than the main list. + * + * Results: + * None. + * + * Side effects: + * Characters get added to the dynamic string. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DStringStartSublist(dsPtr) + Tcl_DString *dsPtr; /* Dynamic string. */ +{ + if (TclNeedSpace(dsPtr->string, dsPtr->string + dsPtr->length)) { + Tcl_DStringAppend(dsPtr, " {", -1); + } else { + Tcl_DStringAppend(dsPtr, "{", -1); + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DStringEndSublist -- + * + * This procedure adds the necessary characters to a dynamic + * string to end a sublist (e.g. "}"). Future element appends + * will be in the enclosing (sub)list rather than the current + * sublist. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DStringEndSublist(dsPtr) + Tcl_DString *dsPtr; /* Dynamic string. */ +{ + Tcl_DStringAppend(dsPtr, "}", -1); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_PrintDouble -- + * + * Given a floating-point value, this procedure converts it to + * an ASCII string using. + * + * Results: + * The ASCII equivalent of "value" is written at "dst". It is + * written using the current precision, and it is guaranteed to + * contain a decimal point or exponent, so that it looks like + * a floating-point value and not an integer. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_PrintDouble(interp, value, dst) + Tcl_Interp *interp; /* Interpreter whose tcl_precision + * variable controls printing. */ + double value; /* Value to print as string. */ + char *dst; /* Where to store converted value; + * must have at least TCL_DOUBLE_SPACE + * characters. */ +{ + register char *p; + sprintf(dst, ((Interp *) interp)->pdFormat, value); + + /* + * If the ASCII result looks like an integer, add ".0" so that it + * doesn't look like an integer anymore. This prevents floating-point + * values from being converted to integers unintentionally. + */ + + for (p = dst; *p != 0; p++) { + if ((*p == '.') || (isalpha(UCHAR(*p)))) { + return; + } + } + p[0] = '.'; + p[1] = '0'; + p[2] = 0; +} + +/* + *---------------------------------------------------------------------- + * + * TclPrecTraceProc -- + * + * This procedure is invoked whenever the variable "tcl_precision" + * is written. + * + * Results: + * Returns NULL if all went well, or an error message if the + * new value for the variable doesn't make sense. + * + * Side effects: + * If the new value doesn't make sense then this procedure + * undoes the effect of the variable modification. Otherwise + * it modifies the format string that's used by Tcl_PrintDouble. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +char * +TclPrecTraceProc(clientData, interp, name1, name2, flags) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Interpreter containing variable. */ + char *name1; /* Name of variable. */ + char *name2; /* Second part of variable name. */ + int flags; /* Information about what happened. */ +{ + register Interp *iPtr = (Interp *) interp; + char *value, *end; + int prec; + + /* + * If the variable is unset, then recreate the trace and restore + * the default value of the format string. + */ + + if (flags & TCL_TRACE_UNSETS) { + if ((flags & TCL_TRACE_DESTROYED) && !(flags & TCL_INTERP_DESTROYED)) { + Tcl_TraceVar2(interp, name1, name2, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + TclPrecTraceProc, clientData); + } + strcpy(iPtr->pdFormat, DEFAULT_PD_FORMAT); + iPtr->pdPrec = DEFAULT_PD_PREC; + return (char *) NULL; + } + + value = Tcl_GetVar2(interp, name1, name2, flags & TCL_GLOBAL_ONLY); + if (value == NULL) { + value = ""; + } + prec = strtoul(value, &end, 10); + if ((prec <= 0) || (prec > TCL_MAX_PREC) || (prec > 100) || + (end == value) || (*end != 0)) { + char oldValue[10]; + + sprintf(oldValue, "%d", iPtr->pdPrec); + Tcl_SetVar2(interp, name1, name2, oldValue, flags & TCL_GLOBAL_ONLY); + return "improper value for precision"; + } + sprintf(iPtr->pdFormat, "%%.%dg", prec); + iPtr->pdPrec = prec; + return (char *) NULL; +} + +/* + *---------------------------------------------------------------------- + * + * TclNeedSpace -- + * + * This procedure checks to see whether it is appropriate to + * add a space before appending a new list element to an + * existing string. + * + * Results: + * The return value is 1 if a space is appropriate, 0 otherwise. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclNeedSpace(start, end) + char *start; /* First character in string. */ + char *end; /* End of string (place where space will + * be added, if appropriate). */ +{ + /* + * A space is needed unless either + * (a) we're at the start of the string, or + * (b) the trailing characters of the string consist of one or more + * open curly braces preceded by a space or extending back to + * the beginning of the string. + * (c) the trailing characters of the string consist of a space + * preceded by a character other than backslash. + */ + + if (end == start) { + return 0; + } + end--; + if (*end != '{') { + if (isspace(UCHAR(*end)) && ((end == start) || (end[-1] != '\\'))) { + return 0; + } + return 1; + } + do { + if (end == start) { + return 0; + } + end--; + } while (*end == '{'); + if (isspace(UCHAR(*end))) { + return 0; + } + return 1; +} diff --git a/contrib/tcl/generic/tclVar.c b/contrib/tcl/generic/tclVar.c new file mode 100644 index 0000000000000..c5c214745f4b9 --- /dev/null +++ b/contrib/tcl/generic/tclVar.c @@ -0,0 +1,2575 @@ +/* + * tclVar.c -- + * + * This file contains routines that implement Tcl variables + * (both scalars and arrays). + * + * The implementation of arrays is modelled after an initial + * implementation by Mark Diekhans and Karl Lehenbauer. + * + * Copyright (c) 1987-1994 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclVar.c 1.69 96/02/28 21:45:10 + */ + +#include "tclInt.h" +#include "tclPort.h" + +/* + * The strings below are used to indicate what went wrong when a + * variable access is denied. + */ + +static char *noSuchVar = "no such variable"; +static char *isArray = "variable is array"; +static char *needArray = "variable isn't array"; +static char *noSuchElement = "no such element in array"; +static char *danglingUpvar = "upvar refers to element in deleted array"; + +/* + * Creation flag values passed in to LookupVar: + * + * CRT_PART1 - 1 means create hash table entry for part 1 of + * name, if it doesn't already exist. 0 means + * return an error if it doesn't exist. + * CRT_PART2 - 1 means create hash table entry for part 2 of + * name, if it doesn't already exist. 0 means + * return an error if it doesn't exist. + */ + +#define CRT_PART1 1 +#define CRT_PART2 2 + +/* + * The following additional flag is used internally and passed through + * to LookupVar to indicate that a procedure like Tcl_GetVar was called + * instead of Tcl_GetVar2 and the single name value hasn't yet been + * parsed into an array name and index (if any). + */ + +#define PART1_NOT_PARSED 0x10000 + +/* + * Forward references to procedures defined later in this file: + */ + +static char * CallTraces _ANSI_ARGS_((Interp *iPtr, Var *arrayPtr, + Var *varPtr, char *part1, char *part2, + int flags)); +static void CleanupVar _ANSI_ARGS_((Var *varPtr, Var *arrayPtr)); +static void DeleteSearches _ANSI_ARGS_((Var *arrayVarPtr)); +static void DeleteArray _ANSI_ARGS_((Interp *iPtr, char *arrayName, + Var *varPtr, int flags)); +static Var * LookupVar _ANSI_ARGS_((Tcl_Interp *interp, char *part1, + char *part2, int flags, char *msg, int create, + Var **arrayPtrPtr)); +static int MakeUpvar _ANSI_ARGS_((Interp *iPtr, + CallFrame *framePtr, char *otherP1, + char *otherP2, char *myName, int flags)); +static Var * NewVar _ANSI_ARGS_((void)); +static ArraySearch * ParseSearchId _ANSI_ARGS_((Tcl_Interp *interp, + Var *varPtr, char *varName, char *string)); +static void VarErrMsg _ANSI_ARGS_((Tcl_Interp *interp, + char *part1, char *part2, char *operation, + char *reason)); + +/* + *---------------------------------------------------------------------- + * + * LookupVar -- + * + * This procedure is used by virtually all of the variable + * code to locate a variable given its name(s). + * + * Results: + * The return value is a pointer to the variable indicated by + * part1 and part2, or NULL if the variable couldn't be found. + * If the variable is found, *arrayPtrPtr is filled in with + * the address of the array that contains the variable (or NULL + * if the variable is a scalar). Note: it's possible that the + * variable returned may be VAR_UNDEFINED, even if CRT_PART1 and + * CRT_PART2 are specified (these only cause the hash table entry + * and/or array to be created). + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static Var * +LookupVar(interp, part1, part2, flags, msg, create, arrayPtrPtr) + Tcl_Interp *interp; /* Interpreter to use for lookup. */ + char *part1; /* If part2 isn't NULL, this is the name + * of an array. Otherwise, if the + * PART1_NOT_PARSED flag bit is set this + * is a full variable name that could + * include a parenthesized array elemnt. + * If PART1_NOT_PARSED isn't present, then + * this is the name of a scalar variable. */ + char *part2; /* Name of an element within array, or NULL. */ + int flags; /* Only the TCL_GLOBAL_ONLY, TCL_LEAVE_ERR_MSG, + * and PART1_NOT_PARSED bits matter. */ + char *msg; /* Verb to use in error messages, e.g. + * "read" or "set". Only needed if + * TCL_LEAVE_ERR_MSG is set in flags. */ + int create; /* OR'ed combination of CRT_PART1 and + * CRT_PART2. Tells which entries to create + * if they don't already exist. */ + Var **arrayPtrPtr; /* If the name refers to an element of an + * array, *arrayPtrPtr gets filled in with + * address of array variable. Otherwise + * this is set to NULL. */ +{ + Interp *iPtr = (Interp *) interp; + Tcl_HashTable *tablePtr; + Tcl_HashEntry *hPtr; + Var *varPtr; + int new; + char *openParen, *closeParen; /* If this procedure parses a name + * into array and index, these point + * to the parens around the index. + * Otherwise they are NULL. These + * are needed to restore the parens + * after parsing the name. */ + char *elName; /* Name of array element or NULL; + * may be same as part2, or may be + * openParen+1. */ + char *p; + + /* + * If the name hasn't been parsed into array name and index yet, + * do it now. + */ + + openParen = closeParen = NULL; + elName = part2; + if (flags & PART1_NOT_PARSED) { + for (p = part1; ; p++) { + if (*p == 0) { + elName = NULL; + break; + } + if (*p == '(') { + openParen = p; + do { + p++; + } while (*p != '\0'); + p--; + if (*p == ')') { + closeParen = p; + *openParen = 0; + elName = openParen+1; + } else { + openParen = NULL; + elName = NULL; + } + break; + } + } + } + + /* + * Lookup part1. + */ + + *arrayPtrPtr = NULL; + if ((flags & TCL_GLOBAL_ONLY) || (iPtr->varFramePtr == NULL)) { + tablePtr = &iPtr->globalTable; + } else { + tablePtr = &iPtr->varFramePtr->varTable; + } + if (create & CRT_PART1) { + hPtr = Tcl_CreateHashEntry(tablePtr, part1, &new); + if (openParen != NULL) { + *openParen = '('; + } + if (new) { + varPtr = NewVar(); + Tcl_SetHashValue(hPtr, varPtr); + varPtr->hPtr = hPtr; + } + } else { + hPtr = Tcl_FindHashEntry(tablePtr, part1); + if (openParen != NULL) { + *openParen = '('; + } + if (hPtr == NULL) { + if (flags & TCL_LEAVE_ERR_MSG) { + VarErrMsg(interp, part1, part2, msg, noSuchVar); + } + return NULL; + } + } + varPtr = (Var *) Tcl_GetHashValue(hPtr); + if (varPtr->flags & VAR_UPVAR) { + varPtr = varPtr->value.upvarPtr; + } + + if (elName == NULL) { + return varPtr; + } + + /* + * We're dealing with an array element, so make sure the variable + * is an array and lookup the element (create it if desired). + */ + + if (varPtr->flags & VAR_UNDEFINED) { + if (!(create & CRT_PART1)) { + if (flags & TCL_LEAVE_ERR_MSG) { + VarErrMsg(interp, part1, part2, msg, noSuchVar); + } + return NULL; + } + varPtr->flags = VAR_ARRAY; + varPtr->value.tablePtr = (Tcl_HashTable *) + ckalloc(sizeof(Tcl_HashTable)); + Tcl_InitHashTable(varPtr->value.tablePtr, TCL_STRING_KEYS); + } else if (!(varPtr->flags & VAR_ARRAY)) { + if (flags & TCL_LEAVE_ERR_MSG) { + VarErrMsg(interp, part1, part2, msg, needArray); + } + return NULL; + } + *arrayPtrPtr = varPtr; + if (closeParen != NULL) { + *closeParen = 0; + } + if (create & CRT_PART2) { + hPtr = Tcl_CreateHashEntry(varPtr->value.tablePtr, elName, &new); + if (closeParen != NULL) { + *closeParen = ')'; + } + if (new) { + if (varPtr->searchPtr != NULL) { + DeleteSearches(varPtr); + } + varPtr = NewVar(); + Tcl_SetHashValue(hPtr, varPtr); + varPtr->hPtr = hPtr; + } + } else { + hPtr = Tcl_FindHashEntry(varPtr->value.tablePtr, elName); + if (closeParen != NULL) { + *closeParen = ')'; + } + if (hPtr == NULL) { + if (flags & TCL_LEAVE_ERR_MSG) { + VarErrMsg(interp, part1, part2, msg, noSuchElement); + } + return NULL; + } + } + return (Var *) Tcl_GetHashValue(hPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetVar -- + * + * Return the value of a Tcl variable. + * + * Results: + * The return value points to the current value of varName. If + * the variable is not defined or can't be read because of a clash + * in array usage then a NULL pointer is returned and an error + * message is left in interp->result if the TCL_LEAVE_ERR_MSG + * flag is set. Note: the return value is only valid up until + * the next call to Tcl_SetVar or Tcl_SetVar2; if you depend on + * the value lasting longer than that, then make yourself a private + * copy. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_GetVar(interp, varName, flags) + Tcl_Interp *interp; /* Command interpreter in which varName is + * to be looked up. */ + char *varName; /* Name of a variable in interp. */ + int flags; /* OR-ed combination of TCL_GLOBAL_ONLY + * or TCL_LEAVE_ERR_MSG bits. */ +{ + return Tcl_GetVar2(interp, varName, (char *) NULL, + flags | PART1_NOT_PARSED); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetVar2 -- + * + * Return the value of a Tcl variable, given a two-part name + * consisting of array name and element within array. + * + * Results: + * The return value points to the current value of the variable + * given by part1 and part2. If the specified variable doesn't + * exist, or if there is a clash in array usage, then NULL is + * returned and a message will be left in interp->result if the + * TCL_LEAVE_ERR_MSG flag is set. Note: the return value is + * only valid up until the next call to Tcl_SetVar or Tcl_SetVar2; + * if you depend on the value lasting longer than that, then make + * yourself a private copy. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_GetVar2(interp, part1, part2, flags) + Tcl_Interp *interp; /* Command interpreter in which variable is + * to be looked up. */ + char *part1; /* Name of array (if part2 is NULL) or + * name of variable. */ + char *part2; /* If non-null, gives name of element in + * array. */ + int flags; /* OR-ed combination of TCL_GLOBAL_ONLY, + * TCL_LEAVE_ERR_MSG, and PART1_NOT_PARSED + * bits. */ +{ + Var *varPtr, *arrayPtr; + Interp *iPtr = (Interp *) interp; + + varPtr = LookupVar(interp, part1, part2, flags, "read", CRT_PART2, + &arrayPtr); + if (varPtr == NULL) { + return NULL; + } + + /* + * Invoke any traces that have been set for the variable. + */ + + if ((varPtr->tracePtr != NULL) + || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) { + char *msg; + + msg = CallTraces(iPtr, arrayPtr, varPtr, part1, part2, + (flags & (TCL_GLOBAL_ONLY|PART1_NOT_PARSED)) | TCL_TRACE_READS); + if (msg != NULL) { + VarErrMsg(interp, part1, part2, "read", msg); + goto cleanup; + } + } + if (!(varPtr->flags & (VAR_UNDEFINED|VAR_UPVAR|VAR_ARRAY))) { + return varPtr->value.string; + } + if (flags & TCL_LEAVE_ERR_MSG) { + char *msg; + + if ((varPtr->flags & VAR_UNDEFINED) && (arrayPtr != NULL) + && !(arrayPtr->flags & VAR_UNDEFINED)) { + msg = noSuchElement; + } else if (varPtr->flags & VAR_ARRAY) { + msg = isArray; + } else { + msg = noSuchVar; + } + VarErrMsg(interp, part1, part2, "read", msg); + } + + /* + * If the variable doesn't exist anymore and no-one's using it, + * then free up the relevant structures and hash table entries. + */ + + cleanup: + if (varPtr->flags & VAR_UNDEFINED) { + CleanupVar(varPtr, arrayPtr); + } + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetVar -- + * + * Change the value of a variable. + * + * Results: + * Returns a pointer to the malloc'ed string holding the new + * value of the variable. The caller should not modify this + * string. If the write operation was disallowed then NULL + * is returned; if the TCL_LEAVE_ERR_MSG flag is set, then + * an explanatory message will be left in interp->result. + * + * Side effects: + * If varName is defined as a local or global variable in interp, + * its value is changed to newValue. If varName isn't currently + * defined, then a new global variable by that name is created. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_SetVar(interp, varName, newValue, flags) + Tcl_Interp *interp; /* Command interpreter in which varName is + * to be looked up. */ + char *varName; /* Name of a variable in interp. */ + char *newValue; /* New value for varName. */ + int flags; /* Various flags that tell how to set value: + * any of TCL_GLOBAL_ONLY, TCL_APPEND_VALUE, + * TCL_LIST_ELEMENT, or TCL_LEAVE_ERR_MSG. */ +{ + return Tcl_SetVar2(interp, varName, (char *) NULL, newValue, + flags | PART1_NOT_PARSED); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetVar2 -- + * + * Given a two-part variable name, which may refer either to a + * scalar variable or an element of an array, change the value + * of the variable. If the named scalar or array or element + * doesn't exist then create one. + * + * Results: + * Returns a pointer to the malloc'ed string holding the new + * value of the variable. The caller should not modify this + * string. If the write operation was disallowed because an + * array was expected but not found (or vice versa), then NULL + * is returned; if the TCL_LEAVE_ERR_MSG flag is set, then + * an explanatory message will be left in interp->result. + * + * Side effects: + * The value of the given variable is set. If either the array + * or the entry didn't exist then a new one is created. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_SetVar2(interp, part1, part2, newValue, flags) + Tcl_Interp *interp; /* Command interpreter in which variable is + * to be looked up. */ + char *part1; /* If part2 is NULL, this is name of scalar + * variable. Otherwise it is name of array. */ + char *part2; /* Name of an element within array, or NULL. */ + char *newValue; /* New value for variable. */ + int flags; /* Various flags that tell how to set value: + * any of TCL_GLOBAL_ONLY, TCL_APPEND_VALUE, + * TCL_LIST_ELEMENT, TCL_LEAVE_ERR_MSG, or + * PART1_NOT_PARSED. */ +{ + register Var *varPtr; + register Interp *iPtr = (Interp *) interp; + int length, listFlags; + Var *arrayPtr; + char *result; + + varPtr = LookupVar(interp, part1, part2, flags, "set", CRT_PART1|CRT_PART2, + &arrayPtr); + if (varPtr == NULL) { + return NULL; + } + + /* + * If the variable's hPtr field is NULL, it means that this is an + * upvar to an array element where the array was deleted, leaving + * the element dangling at the end of the upvar. Generate an error + * (allowing the variable to be reset would screw up our storage + * allocation and is meaningless anyway). + */ + + if (varPtr->hPtr == NULL) { + if (flags & TCL_LEAVE_ERR_MSG) { + VarErrMsg(interp, part1, part2, "set", danglingUpvar); + } + return NULL; + } + + /* + * Clear the variable's current value unless this is an + * append operation. + */ + + if (varPtr->flags & VAR_ARRAY) { + if (flags & TCL_LEAVE_ERR_MSG) { + VarErrMsg(interp, part1, part2, "set", isArray); + } + return NULL; + } + if (!(flags & TCL_APPEND_VALUE) || (varPtr->flags & VAR_UNDEFINED)) { + varPtr->valueLength = 0; + } + + /* + * Call read trace if variable is being appended to. + */ + + if ((flags & TCL_APPEND_VALUE) && ((varPtr->tracePtr != NULL) + || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL)))) { + char *msg; + msg = CallTraces(iPtr, arrayPtr, varPtr, part1, part2, + (flags & (TCL_GLOBAL_ONLY|PART1_NOT_PARSED)) | TCL_TRACE_READS); + if (msg != NULL) { + VarErrMsg(interp, part1, part2, "read", msg); + result = NULL; + goto cleanup; + } + } + + /* + * Compute how many total bytes will be needed for the variable's + * new value (leave space for a separating space between list + * elements). Allocate new space for the value if needed. + */ + + if (flags & TCL_LIST_ELEMENT) { + length = Tcl_ScanElement(newValue, &listFlags) + 1; + } else { + length = strlen(newValue); + } + length += varPtr->valueLength; + if (length >= varPtr->valueSpace) { + char *newValue; + int newSize; + + newSize = 2*varPtr->valueSpace; + if (newSize <= length) { + newSize = length + 1; + } + if (newSize < 24) { + /* + * Don't waste time with teensy-tiny variables; we'll + * just end up expanding them later. + */ + + newSize = 24; + } + newValue = (char *) ckalloc((unsigned) newSize); + if (varPtr->valueSpace > 0) { + strcpy(newValue, varPtr->value.string); + ckfree(varPtr->value.string); + } + varPtr->valueSpace = newSize; + varPtr->value.string = newValue; + } + + /* + * Append the new value to the variable, either as a list + * element or as a string. + */ + + if (flags & TCL_LIST_ELEMENT) { + char *dst = varPtr->value.string + varPtr->valueLength; + + if (TclNeedSpace(varPtr->value.string, dst)) { + *dst = ' '; + dst++; + varPtr->valueLength++; + } + varPtr->valueLength += Tcl_ConvertElement(newValue, dst, listFlags); + } else { + strcpy(varPtr->value.string + varPtr->valueLength, newValue); + varPtr->valueLength = length; + } + varPtr->flags &= ~VAR_UNDEFINED; + + /* + * Invoke any write traces for the variable. + */ + + if ((varPtr->tracePtr != NULL) + || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) { + char *msg; + + msg = CallTraces(iPtr, arrayPtr, varPtr, part1, part2, + (flags & (TCL_GLOBAL_ONLY|PART1_NOT_PARSED)) + | TCL_TRACE_WRITES); + if (msg != NULL) { + VarErrMsg(interp, part1, part2, "set", msg); + result = NULL; + goto cleanup; + } + } + + /* + * If the variable was changed in some gross way by a trace (e.g. + * it was unset and then recreated as an array) then just return + * an empty string; otherwise return the variable's current + * value. + */ + + if (!(varPtr->flags & (VAR_UNDEFINED|VAR_UPVAR|VAR_ARRAY))) { + return varPtr->value.string; + } + result = ""; + + /* + * If the variable doesn't exist anymore and no-one's using it, + * then free up the relevant structures and hash table entries. + */ + + cleanup: + if (varPtr->flags & VAR_UNDEFINED) { + CleanupVar(varPtr, arrayPtr); + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_UnsetVar -- + * + * Delete a variable, so that it may not be accessed anymore. + * + * Results: + * Returns TCL_OK if the variable was successfully deleted, TCL_ERROR + * if the variable can't be unset. In the event of an error, + * if the TCL_LEAVE_ERR_MSG flag is set then an error message + * is left in interp->result. + * + * Side effects: + * If varName is defined as a local or global variable in interp, + * it is deleted. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_UnsetVar(interp, varName, flags) + Tcl_Interp *interp; /* Command interpreter in which varName is + * to be looked up. */ + char *varName; /* Name of a variable in interp. May be + * either a scalar name or an array name + * or an element in an array. */ + int flags; /* OR-ed combination of any of + * TCL_GLOBAL_ONLY or TCL_LEAVE_ERR_MSG. */ +{ + return Tcl_UnsetVar2(interp, varName, (char *) NULL, + flags | PART1_NOT_PARSED); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_UnsetVar2 -- + * + * Delete a variable, given a 2-part name. + * + * Results: + * Returns TCL_OK if the variable was successfully deleted, TCL_ERROR + * if the variable can't be unset. In the event of an error, + * if the TCL_LEAVE_ERR_MSG flag is set then an error message + * is left in interp->result. + * + * Side effects: + * If part1 and part2 indicate a local or global variable in interp, + * it is deleted. If part1 is an array name and part2 is NULL, then + * the whole array is deleted. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_UnsetVar2(interp, part1, part2, flags) + Tcl_Interp *interp; /* Command interpreter in which varName is + * to be looked up. */ + char *part1; /* Name of variable or array. */ + char *part2; /* Name of element within array or NULL. */ + int flags; /* OR-ed combination of any of + * TCL_GLOBAL_ONLY, TCL_LEAVE_ERR_MSG, + * or PART1_NOT_PARSED. */ +{ + Var *varPtr, dummyVar; + Interp *iPtr = (Interp *) interp; + Var *arrayPtr; + ActiveVarTrace *activePtr; + int result; + + varPtr = LookupVar(interp, part1, part2, flags, "unset", 0, &arrayPtr); + if (varPtr == NULL) { + return TCL_ERROR; + } + result = (varPtr->flags & VAR_UNDEFINED) ? TCL_ERROR : TCL_OK; + + if ((arrayPtr != NULL) && (arrayPtr->searchPtr != NULL)) { + DeleteSearches(arrayPtr); + } + + /* + * The code below is tricky, because of the possibility that + * a trace procedure might try to access a variable being + * deleted. To handle this situation gracefully, do things + * in three steps: + * 1. Copy the contents of the variable to a dummy variable + * structure, and mark the original structure as undefined. + * 2. Invoke traces and clean up the variable, using the copy. + * 3. If at the end of this the original variable is still + * undefined and has no outstanding references, then delete + * it (but it could have gotten recreated by a trace). + */ + + dummyVar = *varPtr; + varPtr->valueSpace = 0; + varPtr->flags = VAR_UNDEFINED; + varPtr->tracePtr = NULL; + varPtr->searchPtr = NULL; + + /* + * Call trace procedures for the variable being deleted and delete + * its traces. Be sure to abort any other traces for the variable + * that are still pending. Special tricks: + * 1. Increment varPtr's refCount around this: CallTraces will + * use dummyVar so it won't increment varPtr's refCount. + * 2. Turn off the VAR_TRACE_ACTIVE flag in dummyVar: we want to + * call unset traces even if other traces are pending. + */ + + if ((dummyVar.tracePtr != NULL) + || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) { + varPtr->refCount++; + dummyVar.flags &= ~VAR_TRACE_ACTIVE; + (void) CallTraces(iPtr, arrayPtr, &dummyVar, part1, part2, + (flags & (TCL_GLOBAL_ONLY|PART1_NOT_PARSED)) + | TCL_TRACE_UNSETS); + while (dummyVar.tracePtr != NULL) { + VarTrace *tracePtr = dummyVar.tracePtr; + dummyVar.tracePtr = tracePtr->nextPtr; + ckfree((char *) tracePtr); + } + for (activePtr = iPtr->activeTracePtr; activePtr != NULL; + activePtr = activePtr->nextPtr) { + if (activePtr->varPtr == varPtr) { + activePtr->nextTracePtr = NULL; + } + } + varPtr->refCount--; + } + + /* + * If the variable is an array, delete all of its elements. This + * must be done after calling the traces on the array, above (that's + * the way traces are defined). + */ + + if (dummyVar.flags & VAR_ARRAY) { + DeleteArray(iPtr, part1, &dummyVar, + (flags & TCL_GLOBAL_ONLY) | TCL_TRACE_UNSETS); + } + if (dummyVar.valueSpace > 0) { + ckfree(dummyVar.value.string); + } + if (result == TCL_ERROR) { + if (flags & TCL_LEAVE_ERR_MSG) { + VarErrMsg(interp, part1, part2, "unset", + (arrayPtr == NULL) ? noSuchVar : noSuchElement); + } + } + + /* + * Finally, if the variable is truly not in use then free up its + * record and remove it from the hash table. + */ + + CleanupVar(varPtr, arrayPtr); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_TraceVar -- + * + * Arrange for reads and/or writes to a variable to cause a + * procedure to be invoked, which can monitor the operations + * and/or change their actions. + * + * Results: + * A standard Tcl return value. + * + * Side effects: + * A trace is set up on the variable given by varName, such that + * future references to the variable will be intermediated by + * proc. See the manual entry for complete details on the calling + * sequence for proc. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_TraceVar(interp, varName, flags, proc, clientData) + Tcl_Interp *interp; /* Interpreter in which variable is + * to be traced. */ + char *varName; /* Name of variable; may end with "(index)" + * to signify an array reference. */ + int flags; /* OR-ed collection of bits, including any + * of TCL_TRACE_READS, TCL_TRACE_WRITES, + * TCL_TRACE_UNSETS, and TCL_GLOBAL_ONLY. */ + Tcl_VarTraceProc *proc; /* Procedure to call when specified ops are + * invoked upon varName. */ + ClientData clientData; /* Arbitrary argument to pass to proc. */ +{ + return Tcl_TraceVar2(interp, varName, (char *) NULL, + flags | PART1_NOT_PARSED, proc, clientData); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_TraceVar2 -- + * + * Arrange for reads and/or writes to a variable to cause a + * procedure to be invoked, which can monitor the operations + * and/or change their actions. + * + * Results: + * A standard Tcl return value. + * + * Side effects: + * A trace is set up on the variable given by part1 and part2, such + * that future references to the variable will be intermediated by + * proc. See the manual entry for complete details on the calling + * sequence for proc. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_TraceVar2(interp, part1, part2, flags, proc, clientData) + Tcl_Interp *interp; /* Interpreter in which variable is + * to be traced. */ + char *part1; /* Name of scalar variable or array. */ + char *part2; /* Name of element within array; NULL means + * trace applies to scalar variable or array + * as-a-whole. */ + int flags; /* OR-ed collection of bits, including any + * of TCL_TRACE_READS, TCL_TRACE_WRITES, + * TCL_TRACE_UNSETS, TCL_GLOBAL_ONLY, and + * PART1_NOT_PARSED. */ + Tcl_VarTraceProc *proc; /* Procedure to call when specified ops are + * invoked upon varName. */ + ClientData clientData; /* Arbitrary argument to pass to proc. */ +{ + Var *varPtr, *arrayPtr; + register VarTrace *tracePtr; + + varPtr = LookupVar(interp, part1, part2, (flags | TCL_LEAVE_ERR_MSG), + "trace", CRT_PART1|CRT_PART2, &arrayPtr); + if (varPtr == NULL) { + return TCL_ERROR; + } + + /* + * Set up trace information. + */ + + tracePtr = (VarTrace *) ckalloc(sizeof(VarTrace)); + tracePtr->traceProc = proc; + tracePtr->clientData = clientData; + tracePtr->flags = flags & + (TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS); + tracePtr->nextPtr = varPtr->tracePtr; + varPtr->tracePtr = tracePtr; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_UntraceVar -- + * + * Remove a previously-created trace for a variable. + * + * Results: + * None. + * + * Side effects: + * If there exists a trace for the variable given by varName + * with the given flags, proc, and clientData, then that trace + * is removed. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_UntraceVar(interp, varName, flags, proc, clientData) + Tcl_Interp *interp; /* Interpreter containing traced variable. */ + char *varName; /* Name of variable; may end with "(index)" + * to signify an array reference. */ + int flags; /* OR-ed collection of bits describing + * current trace, including any of + * TCL_TRACE_READS, TCL_TRACE_WRITES, + * TCL_TRACE_UNSETS, and TCL_GLOBAL_ONLY. */ + Tcl_VarTraceProc *proc; /* Procedure assocated with trace. */ + ClientData clientData; /* Arbitrary argument to pass to proc. */ +{ + Tcl_UntraceVar2(interp, varName, (char *) NULL, flags | PART1_NOT_PARSED, + proc, clientData); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_UntraceVar2 -- + * + * Remove a previously-created trace for a variable. + * + * Results: + * None. + * + * Side effects: + * If there exists a trace for the variable given by part1 + * and part2 with the given flags, proc, and clientData, then + * that trace is removed. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_UntraceVar2(interp, part1, part2, flags, proc, clientData) + Tcl_Interp *interp; /* Interpreter containing traced variable. */ + char *part1; /* Name of variable or array. */ + char *part2; /* Name of element within array; NULL means + * trace applies to scalar variable or array + * as-a-whole. */ + int flags; /* OR-ed collection of bits describing + * current trace, including any of + * TCL_TRACE_READS, TCL_TRACE_WRITES, + * TCL_TRACE_UNSETS, TCL_GLOBAL_ONLY, and + * PART1_NOT_PARSED. */ + Tcl_VarTraceProc *proc; /* Procedure assocated with trace. */ + ClientData clientData; /* Arbitrary argument to pass to proc. */ +{ + register VarTrace *tracePtr; + VarTrace *prevPtr; + Var *varPtr, *arrayPtr; + Interp *iPtr = (Interp *) interp; + ActiveVarTrace *activePtr; + + varPtr = LookupVar(interp, part1, part2, + flags & (TCL_GLOBAL_ONLY|PART1_NOT_PARSED), (char *) NULL, 0, + &arrayPtr); + if (varPtr == NULL) { + return; + } + + flags &= (TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS); + for (tracePtr = varPtr->tracePtr, prevPtr = NULL; ; + prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) { + if (tracePtr == NULL) { + return; + } + if ((tracePtr->traceProc == proc) && (tracePtr->flags == flags) + && (tracePtr->clientData == clientData)) { + break; + } + } + + /* + * The code below makes it possible to delete traces while traces + * are active: it makes sure that the deleted trace won't be + * processed by CallTraces. + */ + + for (activePtr = iPtr->activeTracePtr; activePtr != NULL; + activePtr = activePtr->nextPtr) { + if (activePtr->nextTracePtr == tracePtr) { + activePtr->nextTracePtr = tracePtr->nextPtr; + } + } + if (prevPtr == NULL) { + varPtr->tracePtr = tracePtr->nextPtr; + } else { + prevPtr->nextPtr = tracePtr->nextPtr; + } + ckfree((char *) tracePtr); + + /* + * If this is the last trace on the variable, and the variable is + * unset and unused, then free up the variable. + */ + + if (varPtr->flags & VAR_UNDEFINED) { + CleanupVar(varPtr, (Var *) NULL); + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_VarTraceInfo -- + * + * Return the clientData value associated with a trace on a + * variable. This procedure can also be used to step through + * all of the traces on a particular variable that have the + * same trace procedure. + * + * Results: + * The return value is the clientData value associated with + * a trace on the given variable. Information will only be + * returned for a trace with proc as trace procedure. If + * the clientData argument is NULL then the first such trace is + * returned; otherwise, the next relevant one after the one + * given by clientData will be returned. If the variable + * doesn't exist, or if there are no (more) traces for it, + * then NULL is returned. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +ClientData +Tcl_VarTraceInfo(interp, varName, flags, proc, prevClientData) + Tcl_Interp *interp; /* Interpreter containing variable. */ + char *varName; /* Name of variable; may end with "(index)" + * to signify an array reference. */ + int flags; /* 0 or TCL_GLOBAL_ONLY. */ + Tcl_VarTraceProc *proc; /* Procedure assocated with trace. */ + ClientData prevClientData; /* If non-NULL, gives last value returned + * by this procedure, so this call will + * return the next trace after that one. + * If NULL, this call will return the + * first trace. */ +{ + return Tcl_VarTraceInfo2(interp, varName, (char *) NULL, + flags | PART1_NOT_PARSED, proc, prevClientData); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_VarTraceInfo2 -- + * + * Same as Tcl_VarTraceInfo, except takes name in two pieces + * instead of one. + * + * Results: + * Same as Tcl_VarTraceInfo. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +ClientData +Tcl_VarTraceInfo2(interp, part1, part2, flags, proc, prevClientData) + Tcl_Interp *interp; /* Interpreter containing variable. */ + char *part1; /* Name of variable or array. */ + char *part2; /* Name of element within array; NULL means + * trace applies to scalar variable or array + * as-a-whole. */ + int flags; /* OR-ed combination of TCL_GLOBAL_ONLY and + * PART1_NOT_PARSED. */ + Tcl_VarTraceProc *proc; /* Procedure assocated with trace. */ + ClientData prevClientData; /* If non-NULL, gives last value returned + * by this procedure, so this call will + * return the next trace after that one. + * If NULL, this call will return the + * first trace. */ +{ + register VarTrace *tracePtr; + Var *varPtr, *arrayPtr; + + varPtr = LookupVar(interp, part1, part2, + flags & (TCL_GLOBAL_ONLY|PART1_NOT_PARSED), (char *) NULL, 0, + &arrayPtr); + if (varPtr == NULL) { + return NULL; + } + + /* + * Find the relevant trace, if any, and return its clientData. + */ + + tracePtr = varPtr->tracePtr; + if (prevClientData != NULL) { + for ( ; tracePtr != NULL; tracePtr = tracePtr->nextPtr) { + if ((tracePtr->clientData == prevClientData) + && (tracePtr->traceProc == proc)) { + tracePtr = tracePtr->nextPtr; + break; + } + } + } + for ( ; tracePtr != NULL; tracePtr = tracePtr->nextPtr) { + if (tracePtr->traceProc == proc) { + return tracePtr->clientData; + } + } + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetCmd -- + * + * This procedure is invoked to process the "set" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result value. + * + * Side effects: + * A variable's value may be changed. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_SetCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + register Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + if (argc == 2) { + char *value; + + value = Tcl_GetVar2(interp, argv[1], (char *) NULL, + TCL_LEAVE_ERR_MSG|PART1_NOT_PARSED); + if (value == NULL) { + return TCL_ERROR; + } + interp->result = value; + return TCL_OK; + } else if (argc == 3) { + char *result; + + result = Tcl_SetVar2(interp, argv[1], (char *) NULL, argv[2], + TCL_LEAVE_ERR_MSG|PART1_NOT_PARSED); + if (result == NULL) { + return TCL_ERROR; + } + interp->result = result; + return TCL_OK; + } else { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " varName ?newValue?\"", (char *) NULL); + return TCL_ERROR; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_UnsetCmd -- + * + * This procedure is invoked to process the "unset" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result value. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_UnsetCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + register Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int i; + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " varName ?varName ...?\"", (char *) NULL); + return TCL_ERROR; + } + for (i = 1; i < argc; i++) { + if (Tcl_UnsetVar2(interp, argv[i], (char *) NULL, + TCL_LEAVE_ERR_MSG|PART1_NOT_PARSED) != TCL_OK) { + return TCL_ERROR; + } + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_AppendCmd -- + * + * This procedure is invoked to process the "append" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result value. + * + * Side effects: + * A variable's value may be changed. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_AppendCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + register Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int i; + char *result = NULL; /* (Initialization only needed to keep + * the compiler from complaining) */ + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " varName ?value value ...?\"", (char *) NULL); + return TCL_ERROR; + } + if (argc == 2) { + result = Tcl_GetVar2(interp, argv[1], (char *) NULL, + TCL_LEAVE_ERR_MSG|PART1_NOT_PARSED); + if (result == NULL) { + return TCL_ERROR; + } + interp->result = result; + return TCL_OK; + } + + for (i = 2; i < argc; i++) { + result = Tcl_SetVar2(interp, argv[1], (char *) NULL, argv[i], + TCL_APPEND_VALUE|TCL_LEAVE_ERR_MSG|PART1_NOT_PARSED); + if (result == NULL) { + return TCL_ERROR; + } + } + interp->result = result; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_LappendCmd -- + * + * This procedure is invoked to process the "lappend" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result value. + * + * Side effects: + * A variable's value may be changed. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_LappendCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + register Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int i; + char *result = NULL; /* (Initialization only needed to keep + * the compiler from complaining) */ + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " varName ?value value ...?\"", (char *) NULL); + return TCL_ERROR; + } + if (argc == 2) { + result = Tcl_GetVar2(interp, argv[1], (char *) NULL, + TCL_LEAVE_ERR_MSG|PART1_NOT_PARSED); + if (result == NULL) { + return TCL_ERROR; + } + interp->result = result; + return TCL_OK; + } + + for (i = 2; i < argc; i++) { + result = Tcl_SetVar2(interp, argv[1], (char *) NULL, argv[i], + TCL_APPEND_VALUE|TCL_LIST_ELEMENT|TCL_LEAVE_ERR_MSG + |PART1_NOT_PARSED); + if (result == NULL) { + return TCL_ERROR; + } + } + interp->result = result; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ArrayCmd -- + * + * This procedure is invoked to process the "array" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result value. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_ArrayCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + register Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + int c, notArray; + size_t length; + Var *varPtr = NULL; /* Initialization needed only to prevent + * compiler warning. */ + Tcl_HashEntry *hPtr; + Interp *iPtr = (Interp *) interp; + + if (argc < 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " option arrayName ?arg ...?\"", (char *) NULL); + return TCL_ERROR; + } + + /* + * Locate the array variable (and it better be an array). + */ + + if (iPtr->varFramePtr == NULL) { + hPtr = Tcl_FindHashEntry(&iPtr->globalTable, argv[2]); + } else { + hPtr = Tcl_FindHashEntry(&iPtr->varFramePtr->varTable, argv[2]); + } + notArray = 0; + if (hPtr == NULL) { + notArray = 1; + } else { + varPtr = (Var *) Tcl_GetHashValue(hPtr); + if (varPtr->flags & VAR_UPVAR) { + varPtr = varPtr->value.upvarPtr; + } + if (!(varPtr->flags & VAR_ARRAY)) { + notArray = 1; + } + } + + /* + * Dispatch based on the option. + */ + + c = argv[1][0]; + length = strlen(argv[1]); + if ((c == 'a') && (strncmp(argv[1], "anymore", length) == 0)) { + ArraySearch *searchPtr; + + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " anymore arrayName searchId\"", (char *) NULL); + return TCL_ERROR; + } + if (notArray) { + goto error; + } + searchPtr = ParseSearchId(interp, varPtr, argv[2], argv[3]); + if (searchPtr == NULL) { + return TCL_ERROR; + } + while (1) { + Var *varPtr2; + + if (searchPtr->nextEntry != NULL) { + varPtr2 = (Var *) Tcl_GetHashValue(searchPtr->nextEntry); + if (!(varPtr2->flags & VAR_UNDEFINED)) { + break; + } + } + searchPtr->nextEntry = Tcl_NextHashEntry(&searchPtr->search); + if (searchPtr->nextEntry == NULL) { + interp->result = "0"; + return TCL_OK; + } + } + interp->result = "1"; + return TCL_OK; + } else if ((c == 'd') && (strncmp(argv[1], "donesearch", length) == 0)) { + ArraySearch *searchPtr, *prevPtr; + + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " donesearch arrayName searchId\"", (char *) NULL); + return TCL_ERROR; + } + if (notArray) { + goto error; + } + searchPtr = ParseSearchId(interp, varPtr, argv[2], argv[3]); + if (searchPtr == NULL) { + return TCL_ERROR; + } + if (varPtr->searchPtr == searchPtr) { + varPtr->searchPtr = searchPtr->nextPtr; + } else { + for (prevPtr = varPtr->searchPtr; ; prevPtr = prevPtr->nextPtr) { + if (prevPtr->nextPtr == searchPtr) { + prevPtr->nextPtr = searchPtr->nextPtr; + break; + } + } + } + ckfree((char *) searchPtr); + } else if ((c == 'e') && (strncmp(argv[1], "exists", length) == 0)) { + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " exists arrayName\"", (char *) NULL); + return TCL_ERROR; + } + interp->result = (notArray) ? "0" : "1"; + } else if ((c == 'g') && (strncmp(argv[1], "get", length) == 0)) { + Tcl_HashSearch search; + Var *varPtr2; + char *name; + + if ((argc != 3) && (argc != 4)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " get arrayName ?pattern?\"", (char *) NULL); + return TCL_ERROR; + } + if (notArray) { + return TCL_OK; + } + for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + varPtr2 = (Var *) Tcl_GetHashValue(hPtr); + if (varPtr2->flags & VAR_UNDEFINED) { + continue; + } + name = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr); + if ((argc == 4) && !Tcl_StringMatch(name, argv[3])) { + continue; + } + Tcl_AppendElement(interp, name); + Tcl_AppendElement(interp, varPtr2->value.string); + } + } else if ((c == 'n') && (strncmp(argv[1], "names", length) == 0) + && (length >= 2)) { + Tcl_HashSearch search; + Var *varPtr2; + char *name; + + if ((argc != 3) && (argc != 4)) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " names arrayName ?pattern?\"", (char *) NULL); + return TCL_ERROR; + } + if (notArray) { + return TCL_OK; + } + for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + varPtr2 = (Var *) Tcl_GetHashValue(hPtr); + if (varPtr2->flags & VAR_UNDEFINED) { + continue; + } + name = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr); + if ((argc == 4) && !Tcl_StringMatch(name, argv[3])) { + continue; + } + Tcl_AppendElement(interp, name); + } + } else if ((c == 'n') && (strncmp(argv[1], "nextelement", length) == 0) + && (length >= 2)) { + ArraySearch *searchPtr; + Tcl_HashEntry *hPtr; + + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " nextelement arrayName searchId\"", + (char *) NULL); + return TCL_ERROR; + } + if (notArray) { + goto error; + } + searchPtr = ParseSearchId(interp, varPtr, argv[2], argv[3]); + if (searchPtr == NULL) { + return TCL_ERROR; + } + while (1) { + Var *varPtr2; + + hPtr = searchPtr->nextEntry; + if (hPtr == NULL) { + hPtr = Tcl_NextHashEntry(&searchPtr->search); + if (hPtr == NULL) { + return TCL_OK; + } + } else { + searchPtr->nextEntry = NULL; + } + varPtr2 = (Var *) Tcl_GetHashValue(hPtr); + if (!(varPtr2->flags & VAR_UNDEFINED)) { + break; + } + } + interp->result = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr); + } else if ((c == 's') && (strncmp(argv[1], "set", length) == 0) + && (length >= 2)) { + char **valueArgv; + int valueArgc, i, result; + + if (argc != 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " set arrayName list\"", (char *) NULL); + return TCL_ERROR; + } + if (Tcl_SplitList(interp, argv[3], &valueArgc, &valueArgv) != TCL_OK) { + return TCL_ERROR; + } + result = TCL_OK; + if (valueArgc & 1) { + interp->result = "list must have an even number of elements"; + result = TCL_ERROR; + goto setDone; + } + for (i = 0; i < valueArgc; i += 2) { + if (Tcl_SetVar2(interp, argv[2], valueArgv[i], valueArgv[i+1], + TCL_LEAVE_ERR_MSG) == NULL) { + result = TCL_ERROR; + break; + } + } + setDone: + ckfree((char *) valueArgv); + return result; + } else if ((c == 's') && (strncmp(argv[1], "size", length) == 0) + && (length >= 2)) { + Tcl_HashSearch search; + Var *varPtr2; + int size; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " size arrayName\"", (char *) NULL); + return TCL_ERROR; + } + size = 0; + if (!notArray) { + for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + varPtr2 = (Var *) Tcl_GetHashValue(hPtr); + if (varPtr2->flags & VAR_UNDEFINED) { + continue; + } + size++; + } + } + sprintf(interp->result, "%d", size); + } else if ((c == 's') && (strncmp(argv[1], "startsearch", length) == 0) + && (length >= 2)) { + ArraySearch *searchPtr; + + if (argc != 3) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " startsearch arrayName\"", (char *) NULL); + return TCL_ERROR; + } + if (notArray) { + goto error; + } + searchPtr = (ArraySearch *) ckalloc(sizeof(ArraySearch)); + if (varPtr->searchPtr == NULL) { + searchPtr->id = 1; + Tcl_AppendResult(interp, "s-1-", argv[2], (char *) NULL); + } else { + char string[20]; + + searchPtr->id = varPtr->searchPtr->id + 1; + sprintf(string, "%d", searchPtr->id); + Tcl_AppendResult(interp, "s-", string, "-", argv[2], + (char *) NULL); + } + searchPtr->varPtr = varPtr; + searchPtr->nextEntry = Tcl_FirstHashEntry(varPtr->value.tablePtr, + &searchPtr->search); + searchPtr->nextPtr = varPtr->searchPtr; + varPtr->searchPtr = searchPtr; + } else { + Tcl_AppendResult(interp, "bad option \"", argv[1], + "\": should be anymore, donesearch, exists, ", + "get, names, nextelement, ", + "set, size, or startsearch", (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; + + error: + Tcl_AppendResult(interp, "\"", argv[2], "\" isn't an array", + (char *) NULL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * MakeUpvar -- + * + * This procedure does all of the work of the "global" and "upvar" + * commands. + * + * Results: + * A standard Tcl completion code. If an error occurs then an + * error message is left in iPtr->result. + * + * Side effects: + * The variable given by myName is linked to the variable in + * framePtr given by otherP1 and otherP2, so that references to + * myName are redirected to the other variable like a symbolic +* link. + * + *---------------------------------------------------------------------- + */ + +static int +MakeUpvar(iPtr, framePtr, otherP1, otherP2, myName, flags) + Interp *iPtr; /* Interpreter containing variables. Used + * for error messages, too. */ + CallFrame *framePtr; /* Call frame containing "other" variable. + * NULL means use global context. */ + char *otherP1, *otherP2; /* Two-part name of variable in framePtr. */ + char *myName; /* Name of variable in local table, which + * will refer to otherP1/P2. Must be a + * scalar. */ + int flags; /* 0 or TCL_GLOBAL_ONLY: indicates scope of + * myName. */ +{ + Tcl_HashEntry *hPtr; + Var *otherPtr, *varPtr, *arrayPtr; + CallFrame *savedFramePtr; + int new; + + /* + * In order to use LookupVar to find "other", temporarily replace + * the current frame pointer in the interpreter. + */ + + savedFramePtr = iPtr->varFramePtr; + iPtr->varFramePtr = framePtr; + otherPtr = LookupVar((Tcl_Interp *) iPtr, otherP1, otherP2, + TCL_LEAVE_ERR_MSG, "access", CRT_PART1|CRT_PART2, &arrayPtr); + iPtr->varFramePtr = savedFramePtr; + if (otherPtr == NULL) { + return TCL_ERROR; + } + if ((flags & TCL_GLOBAL_ONLY) || (iPtr->varFramePtr == NULL)) { + hPtr = Tcl_CreateHashEntry(&iPtr->globalTable, myName, &new); + } else { + hPtr = Tcl_CreateHashEntry(&iPtr->varFramePtr->varTable, myName, &new); + } + if (new) { + varPtr = NewVar(); + Tcl_SetHashValue(hPtr, varPtr); + varPtr->hPtr = hPtr; + } else { + /* + * The variable already exists. Make sure that this variable + * isn't also "otherVar" (avoid circular links). Also, if it's + * not an upvar then it's an error. If it is an upvar, then + * just disconnect it from the thing it currently refers to. + */ + + varPtr = (Var *) Tcl_GetHashValue(hPtr); + if (varPtr == otherPtr) { + iPtr->result = "can't upvar from variable to itself"; + return TCL_ERROR; + } + if (varPtr->flags & VAR_UPVAR) { + Var *upvarPtr; + + upvarPtr = varPtr->value.upvarPtr; + if (upvarPtr == otherPtr) { + return TCL_OK; + } + upvarPtr->refCount--; + if (upvarPtr->flags & VAR_UNDEFINED) { + CleanupVar(upvarPtr, (Var *) NULL); + } + } else if (!(varPtr->flags & VAR_UNDEFINED)) { + Tcl_AppendResult((Tcl_Interp *) iPtr, "variable \"", myName, + "\" already exists", (char *) NULL); + return TCL_ERROR; + } else if (varPtr->tracePtr != NULL) { + Tcl_AppendResult((Tcl_Interp *) iPtr, "variable \"", myName, + "\" has traces: can't use for upvar", (char *) NULL); + return TCL_ERROR; + } + } + varPtr->flags = (varPtr->flags & ~VAR_UNDEFINED) | VAR_UPVAR; + varPtr->value.upvarPtr = otherPtr; + otherPtr->refCount++; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_UpVar -- + * + * Delete a variable, so that it may not be accessed anymore. + * + * Results: + * Returns TCL_OK if the variable was successfully deleted, TCL_ERROR + * if the variable can't be unset. In the event of an error, + * if the TCL_LEAVE_ERR_MSG flag is set then an error message + * is left in interp->result. + * + * Side effects: + * If varName is defined as a local or global variable in interp, + * it is deleted. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_UpVar(interp, frameName, varName, localName, flags) + Tcl_Interp *interp; /* Command interpreter in which varName is + * to be looked up. */ + char *frameName; /* Name of the frame containing the source + * variable, such as "1" or "#0". */ + char *varName; /* Name of a variable in interp. May be + * either a scalar name or an element + * in an array. */ + char *localName; /* Destination variable name. */ + int flags; /* Either 0 or TCL_GLOBAL_ONLY; indicates + * whether localName is local or global. */ +{ + int result; + CallFrame *framePtr; + register char *p; + + result = TclGetFrame(interp, frameName, &framePtr); + if (result == -1) { + return TCL_ERROR; + } + + /* + * Figure out whether this is an array reference, then call + * Tcl_UpVar2 to do all the real work. + */ + + for (p = varName; *p != '\0'; p++) { + if (*p == '(') { + char *openParen = p; + + do { + p++; + } while (*p != '\0'); + p--; + if (*p != ')') { + goto scalar; + } + *openParen = '\0'; + *p = '\0'; + result = MakeUpvar((Interp *) interp, framePtr, varName, + openParen+1, localName, flags); + *openParen = '('; + *p = ')'; + return result; + } + } + + scalar: + return MakeUpvar((Interp *) interp, framePtr, varName, (char *) NULL, + localName, flags); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_UpVar2 -- + * + * This procedure links one variable to another, just like + * the "upvar" command. + * + * Results: + * A standard Tcl completion code. If an error occurs then + * an error message is left in interp->result. + * + * Side effects: + * The variable in frameName whose name is given by part1 and + * part2 becomes accessible under the name newName, so that + * references to newName are redirected to the other variable + * like a symbolic link. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_UpVar2(interp, frameName, part1, part2, localName, flags) + Tcl_Interp *interp; /* Interpreter containing variables. Used + * for error messages too. */ + char *frameName; /* Name of the frame containing the source + * variable, such as "1" or "#0". */ + char *part1, *part2; /* Two parts of source variable name. */ + char *localName; /* Destination variable name. */ + int flags; /* TCL_GLOBAL_ONLY or 0. */ +{ + int result; + CallFrame *framePtr; + + result = TclGetFrame(interp, frameName, &framePtr); + if (result == -1) { + return TCL_ERROR; + } + return MakeUpvar((Interp *) interp, framePtr, part1, part2, + localName, flags); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GlobalCmd -- + * + * This procedure is invoked to process the "global" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result value. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_GlobalCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + register Interp *iPtr = (Interp *) interp; + + if (argc < 2) { + Tcl_AppendResult((Tcl_Interp *) iPtr, "wrong # args: should be \"", + argv[0], " varName ?varName ...?\"", (char *) NULL); + return TCL_ERROR; + } + if (iPtr->varFramePtr == NULL) { + return TCL_OK; + } + + for (argc--, argv++; argc > 0; argc--, argv++) { + if (MakeUpvar(iPtr, (CallFrame *) NULL, *argv, (char *) NULL, *argv, 0) + != TCL_OK) { + return TCL_ERROR; + } + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_UpvarCmd -- + * + * This procedure is invoked to process the "upvar" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result value. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_UpvarCmd(dummy, interp, argc, argv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int argc; /* Number of arguments. */ + char **argv; /* Argument strings. */ +{ + register Interp *iPtr = (Interp *) interp; + int result; + CallFrame *framePtr; + register char *p; + + if (argc < 3) { + upvarSyntax: + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " ?level? otherVar localVar ?otherVar localVar ...?\"", + (char *) NULL); + return TCL_ERROR; + } + + /* + * Find the hash table containing the variable being referenced. + */ + + result = TclGetFrame(interp, argv[1], &framePtr); + if (result == -1) { + return TCL_ERROR; + } + argc -= result+1; + if ((argc & 1) != 0) { + goto upvarSyntax; + } + argv += result+1; + + /* + * Iterate over all the pairs of (other variable, local variable) + * names. For each pair, divide the other variable name into two + * parts, then call MakeUpvar to do all the work of creating linking + * it to the local variable. + */ + + for ( ; argc > 0; argc -= 2, argv += 2) { + for (p = argv[0]; *p != 0; p++) { + if (*p == '(') { + char *openParen = p; + + do { + p++; + } while (*p != '\0'); + p--; + if (*p != ')') { + goto scalar; + } + *openParen = '\0'; + *p = '\0'; + result = MakeUpvar(iPtr, framePtr, argv[0], openParen+1, + argv[1], 0); + *openParen = '('; + *p = ')'; + goto checkResult; + } + } + scalar: + result = MakeUpvar(iPtr, framePtr, argv[0], (char *) NULL, argv[1], 0); + + checkResult: + if (result != TCL_OK) { + return TCL_ERROR; + } + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * CallTraces -- + * + * This procedure is invoked to find and invoke relevant + * trace procedures associated with a particular operation on + * a variable. This procedure invokes traces both on the + * variable and on its containing array (where relevant). + * + * Results: + * The return value is NULL if no trace procedures were invoked, or + * if all the invoked trace procedures returned successfully. + * The return value is non-zero if a trace procedure returned an + * error (in this case no more trace procedures were invoked after + * the error was returned). In this case the return value is a + * pointer to a static string describing the error. + * + * Side effects: + * Almost anything can happen, depending on trace; this procedure + * itself doesn't have any side effects. + * + *---------------------------------------------------------------------- + */ + +static char * +CallTraces(iPtr, arrayPtr, varPtr, part1, part2, flags) + Interp *iPtr; /* Interpreter containing variable. */ + register Var *arrayPtr; /* Pointer to array variable that + * contains the variable, or NULL if + * the variable isn't an element of an + * array. */ + Var *varPtr; /* Variable whose traces are to be + * invoked. */ + char *part1, *part2; /* Variable's two-part name. */ + int flags; /* Flags to pass to trace procedures: + * indicates what's happening to + * variable, plus other stuff like + * TCL_GLOBAL_ONLY and + * TCL_INTERP_DESTROYED. May also + * contain PART1_NOT_PARSEd, which + * should not be passed through + * to callbacks. */ +{ + register VarTrace *tracePtr; + ActiveVarTrace active; + char *result, *openParen, *p; + Tcl_DString nameCopy; + int copiedName; + + /* + * If there are already similar trace procedures active for the + * variable, don't call them again. + */ + + if (varPtr->flags & VAR_TRACE_ACTIVE) { + return NULL; + } + varPtr->flags |= VAR_TRACE_ACTIVE; + varPtr->refCount++; + + /* + * If the variable name hasn't been parsed into array name and + * element, do it here. If there really is an array element, + * make a copy of the original name so that NULLs can be + * inserted into it to separate the names (can't modify the name + * string in place, because the string might get used by the + * callbacks we invoke). + */ + + copiedName = 0; + if (flags & PART1_NOT_PARSED) { + for (p = part1; ; p++) { + if (*p == 0) { + break; + } + if (*p == '(') { + openParen = p; + do { + p++; + } while (*p != '\0'); + p--; + if (*p == ')') { + Tcl_DStringInit(&nameCopy); + Tcl_DStringAppend(&nameCopy, part1, (p-part1)); + part2 = Tcl_DStringValue(&nameCopy) + + (openParen + 1 - part1); + part2[-1] = 0; + part1 = Tcl_DStringValue(&nameCopy); + copiedName = 1; + } + break; + } + } + } + flags &= ~PART1_NOT_PARSED; + + /* + * Invoke traces on the array containing the variable, if relevant. + */ + + result = NULL; + active.nextPtr = iPtr->activeTracePtr; + iPtr->activeTracePtr = &active; + if (arrayPtr != NULL) { + arrayPtr->refCount++; + active.varPtr = arrayPtr; + for (tracePtr = arrayPtr->tracePtr; tracePtr != NULL; + tracePtr = active.nextTracePtr) { + active.nextTracePtr = tracePtr->nextPtr; + if (!(tracePtr->flags & flags)) { + continue; + } + result = (*tracePtr->traceProc)(tracePtr->clientData, + (Tcl_Interp *) iPtr, part1, part2, flags); + if (result != NULL) { + if (flags & TCL_TRACE_UNSETS) { + result = NULL; + } else { + goto done; + } + } + } + } + + /* + * Invoke traces on the variable itself. + */ + + if (flags & TCL_TRACE_UNSETS) { + flags |= TCL_TRACE_DESTROYED; + } + active.varPtr = varPtr; + for (tracePtr = varPtr->tracePtr; tracePtr != NULL; + tracePtr = active.nextTracePtr) { + active.nextTracePtr = tracePtr->nextPtr; + if (!(tracePtr->flags & flags)) { + continue; + } + result = (*tracePtr->traceProc)(tracePtr->clientData, + (Tcl_Interp *) iPtr, part1, part2, flags); + if (result != NULL) { + if (flags & TCL_TRACE_UNSETS) { + result = NULL; + } else { + goto done; + } + } + } + + /* + * Restore the variable's flags, remove the record of our active + * traces, and then return. + */ + + done: + if (arrayPtr != NULL) { + arrayPtr->refCount--; + } + if (copiedName) { + Tcl_DStringFree(&nameCopy); + } + varPtr->flags &= ~VAR_TRACE_ACTIVE; + varPtr->refCount--; + iPtr->activeTracePtr = active.nextPtr; + return result; +} + +/* + *---------------------------------------------------------------------- + * + * NewVar -- + * + * Create a new variable with a given amount of storage + * space. + * + * Results: + * The return value is a pointer to the new variable structure. + * The variable will not be part of any hash table yet. Its + * initial value is empty. + * + * Side effects: + * Storage gets allocated. + * + *---------------------------------------------------------------------- + */ + +static Var * +NewVar() +{ + register Var *varPtr; + + varPtr = (Var *) ckalloc(sizeof(Var)); + varPtr->valueLength = 0; + varPtr->valueSpace = 0; + varPtr->value.string = NULL; + varPtr->hPtr = NULL; + varPtr->refCount = 0; + varPtr->tracePtr = NULL; + varPtr->searchPtr = NULL; + varPtr->flags = VAR_UNDEFINED; + return varPtr; +} + +/* + *---------------------------------------------------------------------- + * + * ParseSearchId -- + * + * This procedure translates from a string to a pointer to an + * active array search (if there is one that matches the string). + * + * Results: + * The return value is a pointer to the array search indicated + * by string, or NULL if there isn't one. If NULL is returned, + * interp->result contains an error message. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static ArraySearch * +ParseSearchId(interp, varPtr, varName, string) + Tcl_Interp *interp; /* Interpreter containing variable. */ + Var *varPtr; /* Array variable search is for. */ + char *varName; /* Name of array variable that search is + * supposed to be for. */ + char *string; /* String containing id of search. Must have + * form "search-num-var" where "num" is a + * decimal number and "var" is a variable + * name. */ +{ + char *end; + int id; + ArraySearch *searchPtr; + + /* + * Parse the id into the three parts separated by dashes. + */ + + if ((string[0] != 's') || (string[1] != '-')) { + syntax: + Tcl_AppendResult(interp, "illegal search identifier \"", string, + "\"", (char *) NULL); + return NULL; + } + id = strtoul(string+2, &end, 10); + if ((end == (string+2)) || (*end != '-')) { + goto syntax; + } + if (strcmp(end+1, varName) != 0) { + Tcl_AppendResult(interp, "search identifier \"", string, + "\" isn't for variable \"", varName, "\"", (char *) NULL); + return NULL; + } + + /* + * Search through the list of active searches on the interpreter + * to see if the desired one exists. + */ + + for (searchPtr = varPtr->searchPtr; searchPtr != NULL; + searchPtr = searchPtr->nextPtr) { + if (searchPtr->id == id) { + return searchPtr; + } + } + Tcl_AppendResult(interp, "couldn't find search \"", string, "\"", + (char *) NULL); + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * DeleteSearches -- + * + * This procedure is called to free up all of the searches + * associated with an array variable. + * + * Results: + * None. + * + * Side effects: + * Memory is released to the storage allocator. + * + *---------------------------------------------------------------------- + */ + +static void +DeleteSearches(arrayVarPtr) + register Var *arrayVarPtr; /* Variable whose searches are + * to be deleted. */ +{ + ArraySearch *searchPtr; + + while (arrayVarPtr->searchPtr != NULL) { + searchPtr = arrayVarPtr->searchPtr; + arrayVarPtr->searchPtr = searchPtr->nextPtr; + ckfree((char *) searchPtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * TclDeleteVars -- + * + * This procedure is called to recycle all the storage space + * associated with a table of variables. For this procedure + * to work correctly, it must not be possible for any of the + * variable in the table to be accessed from Tcl commands + * (e.g. from trace procedures). + * + * Results: + * None. + * + * Side effects: + * Variables are deleted and trace procedures are invoked, if + * any are declared. + * + *---------------------------------------------------------------------- + */ + +void +TclDeleteVars(iPtr, tablePtr) + Interp *iPtr; /* Interpreter to which variables belong. */ + Tcl_HashTable *tablePtr; /* Hash table containing variables to + * delete. */ +{ + Tcl_HashSearch search; + Tcl_HashEntry *hPtr; + register Var *varPtr; + Var *upvarPtr; + int flags; + ActiveVarTrace *activePtr; + + flags = TCL_TRACE_UNSETS; + if (tablePtr == &iPtr->globalTable) { + flags |= TCL_INTERP_DESTROYED | TCL_GLOBAL_ONLY; + } + for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL; + hPtr = Tcl_NextHashEntry(&search)) { + varPtr = (Var *) Tcl_GetHashValue(hPtr); + + /* + * For global/upvar variables referenced in procedures, decrement + * the reference count on the variable referred to, and free + * the referenced variable if it's no longer needed. Don't delete + * the hash entry for the other variable if it's in the same table + * as us: this will happen automatically later on. + */ + + if (varPtr->flags & VAR_UPVAR) { + upvarPtr = varPtr->value.upvarPtr; + upvarPtr->refCount--; + if ((upvarPtr->refCount == 0) && (upvarPtr->flags & VAR_UNDEFINED) + && (upvarPtr->tracePtr == NULL)) { + if (upvarPtr->hPtr == NULL) { + ckfree((char *) upvarPtr); + } else if (upvarPtr->hPtr->tablePtr != tablePtr) { + Tcl_DeleteHashEntry(upvarPtr->hPtr); + ckfree((char *) upvarPtr); + } + } + } + + /* + * Invoke traces on the variable that is being deleted, then + * free up the variable's space (no need to free the hash entry + * here, unless we're dealing with a global variable: the + * hash entries will be deleted automatically when the whole + * table is deleted). + */ + + if (varPtr->tracePtr != NULL) { + (void) CallTraces(iPtr, (Var *) NULL, varPtr, + Tcl_GetHashKey(tablePtr, hPtr), (char *) NULL, flags); + while (varPtr->tracePtr != NULL) { + VarTrace *tracePtr = varPtr->tracePtr; + varPtr->tracePtr = tracePtr->nextPtr; + ckfree((char *) tracePtr); + } + for (activePtr = iPtr->activeTracePtr; activePtr != NULL; + activePtr = activePtr->nextPtr) { + if (activePtr->varPtr == varPtr) { + activePtr->nextTracePtr = NULL; + } + } + } + if (varPtr->flags & VAR_ARRAY) { + DeleteArray(iPtr, Tcl_GetHashKey(tablePtr, hPtr), varPtr, flags); + } + if (varPtr->valueSpace > 0) { + /* + * SPECIAL TRICK: it's possible that the interpreter's result + * currently points to this variable (for example, a "set" or + * "lappend" command was the last command in a procedure that's + * being returned from). If this is the case, then just pass + * ownership of the value string to the Tcl interpreter. + */ + + if (iPtr->result == varPtr->value.string) { + iPtr->freeProc = TCL_DYNAMIC; + } else { + ckfree(varPtr->value.string); + } + varPtr->valueSpace = 0; + } + varPtr->hPtr = NULL; + varPtr->tracePtr = NULL; + varPtr->flags = VAR_UNDEFINED; + + /* + * Recycle the variable's memory space if there aren't any upvar's + * pointing to it. If there are upvars, then the variable will + * get freed when the last upvar goes away. + */ + + if (varPtr->refCount == 0) { + ckfree((char *) varPtr); + } + } + Tcl_DeleteHashTable(tablePtr); +} + +/* + *---------------------------------------------------------------------- + * + * DeleteArray -- + * + * This procedure is called to free up everything in an array + * variable. It's the caller's responsibility to make sure + * that the array is no longer accessible before this procedure + * is called. + * + * Results: + * None. + * + * Side effects: + * All storage associated with varPtr's array elements is deleted + * (including the hash table). Delete trace procedures for + * array elements are invoked. + * + *---------------------------------------------------------------------- + */ + +static void +DeleteArray(iPtr, arrayName, varPtr, flags) + Interp *iPtr; /* Interpreter containing array. */ + char *arrayName; /* Name of array (used for trace + * callbacks). */ + Var *varPtr; /* Pointer to variable structure. */ + int flags; /* Flags to pass to CallTraces: + * TCL_TRACE_UNSETS and sometimes + * TCL_INTERP_DESTROYED and/or + * TCL_GLOBAL_ONLY. */ +{ + Tcl_HashSearch search; + register Tcl_HashEntry *hPtr; + register Var *elPtr; + ActiveVarTrace *activePtr; + + DeleteSearches(varPtr); + for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + elPtr = (Var *) Tcl_GetHashValue(hPtr); + if (elPtr->valueSpace != 0) { + /* + * SPECIAL TRICK: it's possible that the interpreter's result + * currently points to this element (for example, a "set" or + * "lappend" command was the last command in a procedure that's + * being returned from). If this is the case, then just pass + * ownership of the value string to the Tcl interpreter. + */ + + if (iPtr->result == elPtr->value.string) { + iPtr->freeProc = TCL_DYNAMIC; + } else { + ckfree(elPtr->value.string); + } + elPtr->valueSpace = 0; + } + elPtr->hPtr = NULL; + if (elPtr->tracePtr != NULL) { + elPtr->flags &= ~VAR_TRACE_ACTIVE; + (void) CallTraces(iPtr, (Var *) NULL, elPtr, arrayName, + Tcl_GetHashKey(varPtr->value.tablePtr, hPtr), flags); + while (elPtr->tracePtr != NULL) { + VarTrace *tracePtr = elPtr->tracePtr; + elPtr->tracePtr = tracePtr->nextPtr; + ckfree((char *) tracePtr); + } + for (activePtr = iPtr->activeTracePtr; activePtr != NULL; + activePtr = activePtr->nextPtr) { + if (activePtr->varPtr == elPtr) { + activePtr->nextTracePtr = NULL; + } + } + } + elPtr->flags = VAR_UNDEFINED; + if (elPtr->refCount == 0) { + ckfree((char *) elPtr); + } + } + Tcl_DeleteHashTable(varPtr->value.tablePtr); + ckfree((char *) varPtr->value.tablePtr); +} + +/* + *---------------------------------------------------------------------- + * + * CleanupVar -- + * + * This procedure is called when it looks like it may be OK + * to free up the variable's record and hash table entry, and + * those of its containing parent. It's called, for example, + * when a trace on a variable deletes the variable. + * + * Results: + * None. + * + * Side effects: + * If the variable (or its containing array) really is dead then + * its record, and possibly its hash table entry, gets freed up. + * + *---------------------------------------------------------------------- + */ + +static void +CleanupVar(varPtr, arrayPtr) + Var *varPtr; /* Pointer to variable that may be a + * candidate for being expunged. */ + Var *arrayPtr; /* Array that contains the variable, or + * NULL if this variable isn't an array + * element. */ +{ + if ((varPtr->flags & VAR_UNDEFINED) && (varPtr->refCount == 0) + && (varPtr->tracePtr == NULL)) { + if (varPtr->hPtr != NULL) { + Tcl_DeleteHashEntry(varPtr->hPtr); + } + ckfree((char *) varPtr); + } + if (arrayPtr != NULL) { + if ((arrayPtr->flags & VAR_UNDEFINED) && (arrayPtr->refCount == 0) + && (arrayPtr->tracePtr == NULL)) { + if (arrayPtr->hPtr != NULL) { + Tcl_DeleteHashEntry(arrayPtr->hPtr); + } + ckfree((char *) arrayPtr); + } + } + return; +} + +/* + *---------------------------------------------------------------------- + * + * VarErrMsg -- + * + * Generate a reasonable error message describing why a variable + * operation failed. + * + * Results: + * None. + * + * Side effects: + * Interp->result is reset to hold a message identifying the + * variable given by part1 and part2 and describing why the + * variable operation failed. + * + *---------------------------------------------------------------------- + */ + +static void +VarErrMsg(interp, part1, part2, operation, reason) + Tcl_Interp *interp; /* Interpreter in which to record message. */ + char *part1, *part2; /* Variable's two-part name. */ + char *operation; /* String describing operation that failed, + * e.g. "read", "set", or "unset". */ + char *reason; /* String describing why operation failed. */ +{ + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "can't ", operation, " \"", part1, (char *) NULL); + if (part2 != NULL) { + Tcl_AppendResult(interp, "(", part2, ")", (char *) NULL); + } + Tcl_AppendResult(interp, "\": ", reason, (char *) NULL); +} |