diff options
author | hobbs <hobbs> | 1999-09-21 04:20:28 (GMT) |
---|---|---|
committer | hobbs <hobbs> | 1999-09-21 04:20:28 (GMT) |
commit | a583a768fbe40ec2b7d661fe32d8347a34632fcf (patch) | |
tree | 8063ba8ff9da4fa71559d95b2c2389d1a8b516c0 /generic | |
parent | 1f66507f55794f140cf5952e6d45da60c066c014 (diff) | |
download | tcl-a583a768fbe40ec2b7d661fe32d8347a34632fcf.zip tcl-a583a768fbe40ec2b7d661fe32d8347a34632fcf.tar.gz tcl-a583a768fbe40ec2b7d661fe32d8347a34632fcf.tar.bz2 |
1999-09-16 Jeff Hobbs <hobbs@scriptics.com>
* tests/timer.test: changed after delay in timer test 6.29 from
1 to 10. [Bug: 2796]
* tests/pkg.test:
* generic/tclPkg.c: fixed package version check to disallow 1.2..3
[Bug: 2539]
* unix/Makefile.in: fixed gendate target - this never worked
since RCS was intro'd.
* generic/tclGetDate.y: updated to reflect previous changes
to tclDate.c (leap year calc) and added CEST and UCT time zone
recognition. Fixed 4 missing UCHAR() casts. [Bug: 2717, 954,
1245, 1249]
* generic/tclCkalloc.c: changed Tcl_DumpActiveMemory to really
dump to stderr and close it [Bug: 725] and changed Tcl_Ckrealloc
and Tcl_Ckfree to not bomb when NULL was passed in [Bug: 1719]
and changed Tcl_Alloc, et al to not panic when a alloc request
for zero came through and NULL was returned (valid on AIX, Tru64)
[Bug: 2795, etc]
* tests/clock.test:
* doc/clock.n:
* generic/tclClock.c: added -milliseconds switch to clock clicks
to guarantee that the return value of clicks is in the millisecs
granularity [Bug: 2682, 1332]
1999-09-15 Jeff Hobbs <hobbs@scriptics.com>
* generic/tclIOCmd.c: fixed potential core dump in conjunction
with stacked channels with result obj manipulation in
Tcl_ReadChars [Bug: 2623]
* tests/format.test:
* generic/tclCmdAH.c: fixed translation of %0#s in format [Bug: 2605]
* doc/msgcat.n: fixed \\ bug in example [Bug: 2548]
* unix/tcl.m4:
* unix/aclocal.m4: added fix for FreeBSD-[1-2] recognition
[Bug: 2070] and fix for IRIX SHLIB_LB_LIBS. [Bug: 2610]
* doc/array.n:
* tests/var.test:
* tests/set.test:
* generic/tclVar.c: added an array unset operation, with docs
and tests. Variation of [Bug: 1775]. Added fix in TclArraySet
to check when trying to set in a non-existent namespace. [Bug: 2613]
1999-09-14 Jeff Hobbs <hobbs@scriptics.com>
* tests/linsert.test:
* doc/linsert.n:
* generic/tclCmdIL.c: fixed end-int interpretation of linsert
to correctly calculate value for end, added test and docs [Bug: 2693]
* doc/regexp.n:
* doc/regsub.n:
* tests/regexp.test:
* generic/tclCmdMZ.c: add -start switch to regexp and regsub
with docs and tests
* doc/switch.n: added proper use of comments to example.
* generic/tclCmdMZ.c: changed switch to complain when an error
occurs that seems to be due to a misplaced comment.
* generic/tclCmdMZ.c: fixed illegal ref for \[0-9] substitutions
in regsub [Bug: 2723]
* generic/tclCmdMZ.c: changed [string equal] to return an Int
type object (was a Boolean)
Diffstat (limited to 'generic')
-rw-r--r-- | generic/tclCkalloc.c | 104 | ||||
-rw-r--r-- | generic/tclClock.c | 36 | ||||
-rw-r--r-- | generic/tclCmdAH.c | 23 | ||||
-rw-r--r-- | generic/tclCmdIL.c | 10 | ||||
-rw-r--r-- | generic/tclCmdMZ.c | 119 | ||||
-rw-r--r-- | generic/tclDate.c | 80 | ||||
-rw-r--r-- | generic/tclGetDate.y | 38 | ||||
-rw-r--r-- | generic/tclIOCmd.c | 8 | ||||
-rw-r--r-- | generic/tclPkg.c | 13 | ||||
-rw-r--r-- | generic/tclUtil.c | 47 | ||||
-rw-r--r-- | generic/tclVar.c | 64 |
11 files changed, 369 insertions, 173 deletions
diff --git a/generic/tclCkalloc.c b/generic/tclCkalloc.c index 61e744c..c24d9e0 100644 --- a/generic/tclCkalloc.c +++ b/generic/tclCkalloc.c @@ -13,7 +13,7 @@ * * This code contributed by Karl Lehenbauer and Mark Diekhans * - * RCS: @(#) $Id: tclCkalloc.c,v 1.5 1999/08/10 02:42:12 welch Exp $ + * RCS: @(#) $Id: tclCkalloc.c,v 1.6 1999/09/21 04:20:39 hobbs Exp $ */ #include "tclInt.h" @@ -165,18 +165,18 @@ void TclDumpMemoryInfo(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); + 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); } /* @@ -294,7 +294,7 @@ Tcl_DumpActiveMemory (fileName) char *address; if (fileName == NULL) { - fileP = stdout; + fileP = stderr; } else { fileP = fopen(fileName, "w"); if (fileP == NULL) { @@ -354,8 +354,7 @@ Tcl_DbCkalloc(size, file, line) if (result == NULL) { fflush(stdout); TclDumpMemoryInfo(stderr); - panic("unable to alloc %d bytes, %s line %d", size, file, - line); + panic("unable to alloc %d bytes, %s line %d", size, file, line); } /* @@ -445,10 +444,16 @@ Tcl_DbCkalloc(size, file, line) int Tcl_DbCkfree(ptr, file, line) - char * ptr; - char *file; - int line; + char *ptr; + char *file; + int line; { + struct mem_header *memp; + + if (ptr == NULL) { + return; + } + /* * The following cast is *very* tricky. Must convert the pointer * to an integer before doing arithmetic on it, because otherwise @@ -457,15 +462,16 @@ Tcl_DbCkfree(ptr, file, line) * even though BODY_OFFSET is in words on these machines). */ - struct mem_header *memp = (struct mem_header *) - (((unsigned long) ptr) - BODY_OFFSET); + memp = (struct mem_header *) (((unsigned long) ptr) - BODY_OFFSET); - if (alloc_tracing) + if (alloc_tracing) { fprintf(stderr, "ckfree %lx %ld %s %d\n", (long unsigned int) memp->body, memp->length, file, line); + } - if (validate_memory) + if (validate_memory) { Tcl_ValidateAllMemory(file, line); + } Tcl_MutexLock(ckallocMutexPtr); ValidateMemory(memp, file, line, TRUE); @@ -520,14 +526,18 @@ Tcl_DbCkrealloc(ptr, size, file, line) { char *new; unsigned int copySize; + struct mem_header *memp; + + if (ptr == NULL) { + return Tcl_DbCkalloc(size, file, line); + } /* * See comment from Tcl_DbCkfree before you change the following * line. */ - struct mem_header *memp = (struct mem_header *) - (((unsigned long) ptr) - BODY_OFFSET); + memp = (struct mem_header *) (((unsigned long) ptr) - BODY_OFFSET); copySize = size; if (copySize > (unsigned int) memp->length) { @@ -777,6 +787,8 @@ Tcl_InitMemory(interp) #else /* TCL_MEM_DEBUG */ +/* This is the !TCL_MEM_DEBUG case */ + #undef Tcl_InitMemory #undef Tcl_DumpActiveMemory #undef Tcl_ValidateAllMemory @@ -796,12 +808,22 @@ char * Tcl_Alloc (size) unsigned int size; { - char *result; + char *result; - result = TclpAlloc(size); - if (result == NULL) - panic("unable to alloc %d bytes", size); - return result; + result = TclpAlloc(size); + /* + * Most systems will not alloc(0), instead bumping it to one so + * that NULL isn't returned. Some systems (AIX, Tru64) will alloc(0) + * by returning NULL, so we have to check that the NULL we get is + * not in response to alloc(0). + * + * The ANSI spec actually says that systems either return NULL *or* + * a special pointer on failure, but we only check for NULL + */ + if ((result == NULL) && size) { + panic("unable to alloc %d bytes", size); + } + return result; } char * @@ -814,10 +836,9 @@ Tcl_DbCkalloc(size, file, line) result = (char *) TclpAlloc(size); - if (result == NULL) { + if ((result == NULL) && size) { fflush(stdout); - panic("unable to alloc %d bytes, %s line %d", size, file, - line); + panic("unable to alloc %d bytes, %s line %d", size, file, line); } return result; } @@ -841,8 +862,10 @@ Tcl_Realloc(ptr, size) char *result; result = TclpRealloc(ptr, size); - if (result == NULL) + + if ((result == NULL) && size) { panic("unable to realloc %d bytes", size); + } return result; } @@ -857,10 +880,9 @@ Tcl_DbCkrealloc(ptr, size, file, line) result = (char *) TclpRealloc(ptr, size); - if (result == NULL) { + if ((result == NULL) && size) { fflush(stdout); - panic("unable to realloc %d bytes, %s line %d", size, file, - line); + panic("unable to realloc %d bytes, %s line %d", size, file, line); } return result; } @@ -880,14 +902,14 @@ void Tcl_Free (ptr) char *ptr; { - TclpFree(ptr); + TclpFree(ptr); } int Tcl_DbCkfree(ptr, file, line) - char * ptr; - char *file; - int line; + char *ptr; + char *file; + int line; { TclpFree(ptr); return 0; diff --git a/generic/tclClock.c b/generic/tclClock.c index 2015f53..d46058f 100644 --- a/generic/tclClock.c +++ b/generic/tclClock.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclClock.c,v 1.4 1999/04/16 00:46:43 stanton Exp $ + * RCS: @(#) $Id: tclClock.c,v 1.5 1999/09/21 04:20:39 hobbs Exp $ */ #include "tcl.h" @@ -68,7 +68,7 @@ Tcl_ClockObjCmd (client, interp, objc, objv) char *scanStr; static char *switches[] = - {"clicks", "format", "scan", "seconds", (char *) NULL}; + {"clicks", "format", "scan", "seconds", (char *) NULL}; static char *formatSwitches[] = {"-format", "-gmt", (char *) NULL}; static char *scanSwitches[] = {"-base", "-gmt", (char *) NULL}; @@ -83,13 +83,37 @@ Tcl_ClockObjCmd (client, interp, objc, objv) return TCL_ERROR; } switch (index) { - case 0: /* clicks */ - if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, NULL); + case 0: { /* clicks */ + int forceMilli = 0; + + if (objc == 3) { + format = Tcl_GetStringFromObj(objv[2], &index); + if (strncmp(format, "-milliseconds", + (unsigned int) index) == 0) { + forceMilli = 1; + } else { + Tcl_AppendStringsToObj(resultPtr, + "bad switch \"", format, + "\": must be -milliseconds", (char *) NULL); + return TCL_ERROR; + } + } else if (objc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, "?-milliseconds?"); return TCL_ERROR; } - Tcl_SetLongObj(resultPtr, (long) TclpGetClicks()); + if (forceMilli) { + /* + * We can enforce at least millisecond granularity + */ + Tcl_Time time; + TclpGetTime(&time); + Tcl_SetLongObj(resultPtr, + (long) (time.sec*1000 + time.usec/1000)); + } else { + Tcl_SetLongObj(resultPtr, (long) TclpGetClicks()); + } return TCL_OK; + } case 1: /* format */ if ((objc < 3) || (objc > 7)) { wrongFmtArgs: diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 14ac7f6..b86ea42 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCmdAH.c,v 1.8 1999/08/19 02:59:08 hobbs Exp $ + * RCS: @(#) $Id: tclCmdAH.c,v 1.9 1999/09/21 04:20:39 hobbs Exp $ */ #include "tclInt.h" @@ -1917,6 +1917,8 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) * been seen in the current field. */ int gotPrecision; /* Non-zero indicates that a precision has * been set for the current field. */ + int gotZero; /* Non-zero indicates that a zero flag has + * been seen in the current field. */ /* * This procedure is a bit nasty. The goal is to use sprintf to @@ -1945,7 +1947,7 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) register char *newPtr = newFormat; width = precision = noPercent = useShort = 0; - gotMinus = gotPrecision = 0; + gotZero = gotMinus = gotPrecision = 0; whichValue = PTR_VALUE; /* @@ -2014,6 +2016,13 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) if (*format == '-') { gotMinus = 1; } + if (*format == '0') { + /* + * This will be handled by sprintf for numbers, but we + * need to do the char/string ones ourselves + */ + gotZero = 1; + } *newPtr = *format; newPtr++; format++; @@ -2201,21 +2210,23 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) } case CHAR_VALUE: { char *ptr; + char padChar = (gotZero ? '0' : ' '); ptr = dst; if (!gotMinus) { for ( ; --width > 0; ptr++) { - *ptr = ' '; + *ptr = padChar; } } ptr += Tcl_UniCharToUtf(intValue, ptr); for ( ; --width > 0; ptr++) { - *ptr = ' '; + *ptr = padChar; } *ptr = '\0'; break; } case STRING_VALUE: { char *ptr; + char padChar = (gotZero ? '0' : ' '); int pad; ptr = dst; @@ -2227,7 +2238,7 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) if (!gotMinus) { while (pad > 0) { - *ptr++ = ' '; + *ptr++ = padChar; pad--; } } @@ -2238,7 +2249,7 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) ptr += size; } while (pad > 0) { - *ptr++ = ' '; + *ptr++ = padChar; pad--; } *ptr = '\0'; diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index aff66e2..49d9b77 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -14,7 +14,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCmdIL.c,v 1.15 1999/08/10 17:35:18 redman Exp $ + * RCS: @(#) $Id: tclCmdIL.c,v 1.16 1999/09/21 04:20:40 hobbs Exp $ */ #include "tclInt.h" @@ -1954,8 +1954,12 @@ Tcl_LinsertObjCmd(dummy, interp, objc, objv) * will invalidate the list's internal representation. */ - result = TclGetIntForIndex(interp, objv[2], /*endValue*/ INT_MAX, - &index); + result = Tcl_ListObjLength(interp, objv[1], &len); + if (result != TCL_OK) { + return result; + } + + result = TclGetIntForIndex(interp, objv[2], /*endValue*/ len, &index); if (result != TCL_OK) { return result; } diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 585ffa7..8758660 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -13,7 +13,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCmdMZ.c,v 1.19 1999/07/22 21:50:54 redman Exp $ + * RCS: @(#) $Id: tclCmdMZ.c,v 1.20 1999/09/21 04:20:40 hobbs Exp $ */ #include "tclInt.h" @@ -126,19 +126,19 @@ Tcl_RegexpObjCmd(dummy, interp, objc, objv) int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { - int i, indices, match, about; + int i, indices, match, about, offset; int cflags, eflags; Tcl_RegExp regExpr; Tcl_Obj *objPtr; Tcl_RegExpInfo info; static char *options[] = { "-indices", "-nocase", "-about", "-expanded", - "-line", "-linestop", "-lineanchor", + "-line", "-linestop", "-lineanchor", "-start", "--", (char *) NULL }; enum options { REGEXP_INDICES, REGEXP_NOCASE, REGEXP_ABOUT, REGEXP_EXPANDED, - REGEXP_LINE, REGEXP_LINESTOP, REGEXP_LINEANCHOR, + REGEXP_LINE, REGEXP_LINESTOP, REGEXP_LINEANCHOR, REGEXP_START, REGEXP_LAST }; @@ -146,6 +146,7 @@ Tcl_RegexpObjCmd(dummy, interp, objc, objv) about = 0; cflags = TCL_REG_ADVANCED; eflags = 0; + offset = 0; for (i = 1; i < objc; i++) { char *name; @@ -188,6 +189,18 @@ Tcl_RegexpObjCmd(dummy, interp, objc, objv) cflags |= TCL_REG_NLANCH; break; } + case REGEXP_START: { + if (++i >= objc) { + goto endOfForLoop; + } + if (Tcl_GetIntFromObj(interp, objv[i], &offset) != TCL_OK) { + return TCL_ERROR; + } + if (offset < 0) { + offset = 0; + } + break; + } case REGEXP_LAST: { i++; goto endOfForLoop; @@ -217,7 +230,15 @@ Tcl_RegexpObjCmd(dummy, interp, objc, objv) return TCL_OK; } - match = Tcl_RegExpExecObj(interp, regExpr, objPtr, 0 /* offset */, + if (offset > 0) { + /* + * Add flag if using offset (string is part of a larger string), + * so that "^" won't match. + */ + eflags |= TCL_REG_NOTBOL; + } + + match = Tcl_RegExpExecObj(interp, regExpr, objPtr, offset /* offset */, objc-2 /* nmatches */, eflags); if (match < 0) { @@ -252,15 +273,15 @@ Tcl_RegexpObjCmd(dummy, interp, objc, objv) Tcl_Obj *objs[2]; if (i <= info.nsubs) { - start = info.matches[i].start; - end = info.matches[i].end; + start = offset + info.matches[i].start; + end = offset + info.matches[i].end; /* * Adjust index so it refers to the last character in the * match instead of the first character after the match. */ - if (end >= 0) { + if (end >= offset) { end--; } } else { @@ -274,8 +295,8 @@ Tcl_RegexpObjCmd(dummy, interp, objc, objv) newPtr = Tcl_NewListObj(2, objs); } else { if (i <= info.nsubs) { - newPtr = Tcl_GetRange(objPtr, info.matches[i].start, - info.matches[i].end - 1); + newPtr = Tcl_GetRange(objPtr, offset + info.matches[i].start, + offset + info.matches[i].end - 1); } else { newPtr = Tcl_NewObj(); @@ -331,17 +352,18 @@ Tcl_RegsubObjCmd(dummy, interp, objc, objv) static char *options[] = { "-all", "-nocase", "-expanded", - "-line", "-linestop", "-lineanchor", + "-line", "-linestop", "-lineanchor", "-start", "--", NULL }; enum options { REGSUB_ALL, REGSUB_NOCASE, REGSUB_EXPANDED, - REGSUB_LINE, REGSUB_LINESTOP, REGSUB_LINEANCHOR, + REGSUB_LINE, REGSUB_LINESTOP, REGSUB_LINEANCHOR, REGSUB_START, REGSUB_LAST }; cflags = TCL_REG_ADVANCED; all = 0; + offset = 0; for (i = 1; i < objc; i++) { char *name; @@ -380,6 +402,18 @@ Tcl_RegsubObjCmd(dummy, interp, objc, objv) cflags |= TCL_REG_NLANCH; break; } + case REGSUB_START: { + if (++i >= objc) { + goto endOfForLoop; + } + if (Tcl_GetIntFromObj(interp, objv[i], &offset) != TCL_OK) { + return TCL_ERROR; + } + if (offset < 0) { + offset = 0; + } + break; + } case REGSUB_LAST: { i++; goto endOfForLoop; @@ -418,8 +452,7 @@ Tcl_RegsubObjCmd(dummy, interp, objc, objv) */ numMatches = 0; - offset = 0; - for (offset = 0; offset < wlen; ) { + for ( ; offset < wlen; ) { int start, end, subStart, subEnd, match; char *src, *firstChar; char c; @@ -440,6 +473,12 @@ Tcl_RegsubObjCmd(dummy, interp, objc, objv) if (match == 0) { break; } + if ((numMatches == 0) && (offset > 0)) { + /* Copy the initial portion of the string in if an offset + * was specified. + */ + Tcl_AppendUnicodeToObj(resultPtr, wstring, offset); + } numMatches++; /* @@ -485,11 +524,13 @@ Tcl_RegsubObjCmd(dummy, interp, objc, objv) if (firstChar != src) { Tcl_AppendToObj(resultPtr, firstChar, src - firstChar); } - subStart = info.matches[index].start; - subEnd = info.matches[index].end; - if ((subStart >= 0) && (subEnd >= 0)) { - Tcl_AppendUnicodeToObj(resultPtr, wstring + offset + subStart, - subEnd - subStart); + if (index <= info.nsubs) { + subStart = info.matches[index].start; + subEnd = info.matches[index].end; + if ((subStart >= 0) && (subEnd >= 0)) { + Tcl_AppendUnicodeToObj(resultPtr, + wstring + offset + subStart, subEnd - subStart); + } } if (*src == '\\') { src++; @@ -519,7 +560,13 @@ Tcl_RegsubObjCmd(dummy, interp, objc, objv) * result variable. */ - if ((offset < wlen) || (numMatches == 0)) { + if (numMatches == 0) { + /* + * On zero matches, just ignore the offset, since it shouldn't + * matter to us in this case, and the user may have skewed it. + */ + Tcl_AppendUnicodeToObj(resultPtr, wstring, wlen); + } else if (offset < wlen) { Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, wlen - offset); } if (Tcl_ObjSetVar2(interp, varPtr, NULL, resultPtr, 0) == NULL) { @@ -935,8 +982,7 @@ Tcl_StringObjCmd(dummy, interp, objc, objv) match = Tcl_UtfNcasecmp(string1, string2, (unsigned) length); } else { - match = Tcl_UtfNcmp(string1, string2, - (unsigned) length); + match = Tcl_UtfNcmp(string1, string2, (unsigned) length); } if ((match == 0) && (reqlength > length)) { match = length1 - length2; @@ -949,7 +995,7 @@ Tcl_StringObjCmd(dummy, interp, objc, objv) } if ((enum options) index == STR_EQUAL) { - Tcl_SetBooleanObj(resultPtr, (match) ? 0 : 1); + Tcl_SetIntObj(resultPtr, (match) ? 0 : 1); } else { Tcl_SetIntObj(resultPtr, ((match > 0) ? 1 : (match < 0) ? -1 : 0)); @@ -2136,7 +2182,7 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv) int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { - int i, j, index, mode, matched, result; + int i, j, index, mode, matched, result, splitObjs, seenComment; char *string, *pattern; Tcl_Obj *stringObj; static char *options[] = { @@ -2179,6 +2225,7 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv) * argument, split them out again. */ + splitObjs = 0; if (objc == 1) { Tcl_Obj **listv; @@ -2186,13 +2233,26 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv) return TCL_ERROR; } objv = listv; + splitObjs = 1; } + seenComment = 0; for (i = 0; i < objc; i += 2) { if (i == objc - 1) { Tcl_ResetResult(interp); Tcl_AppendToObj(Tcl_GetObjResult(interp), "extra switch pattern with no body", -1); + + /* + * Check if this can be due to a badly placed comment + * in the switch block + */ + + if (splitObjs && seenComment) { + Tcl_AppendToObj(Tcl_GetObjResult(interp), + ", this may be due to a comment incorrectly placed outside of a switch body - see the \"switch\" documentation", -1); + } + return TCL_ERROR; } @@ -2201,6 +2261,17 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv) */ pattern = Tcl_GetString(objv[i]); + + /* + * The following is an heuristic to detect the infamous + * "comment in switch" error: just check if a pattern + * begins with '#'. + */ + + if (splitObjs && *pattern == '#') { + seenComment = 1; + } + matched = 0; if ((i == objc - 2) && (*pattern == 'd') diff --git a/generic/tclDate.c b/generic/tclDate.c index 3544737..3f8336a 100644 --- a/generic/tclDate.c +++ b/generic/tclDate.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclDate.c,v 1.5 1999/05/14 18:29:50 stanton Exp $ + * RCS: @(#) $Id: tclDate.c,v 1.6 1999/09/21 04:20:40 hobbs Exp $ */ #include "tclInt.h" @@ -135,22 +135,27 @@ typedef union -#ifdef __cplusplus +#if defined(__cplusplus) || defined(__STDC__) + +#if defined(__cplusplus) && defined(__EXTERN_C__) +extern "C" { +#endif #ifndef TclDateerror +#if defined(__cplusplus) void TclDateerror(const char *); #endif - +#endif #ifndef TclDatelex -#ifdef __EXTERN_C__ - extern "C" { int TclDatelex(void); } -#else int TclDatelex(void); #endif -#endif int TclDateparse(void); +#if defined(__cplusplus) && defined(__EXTERN_C__) +} +#endif #endif + #define TclDateclearin TclDatechar = -1 #define TclDateerrok TclDateerrflag = 0 extern int TclDatechar; @@ -258,7 +263,8 @@ 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 */ + { "uct", tZONE, HOUR( 0) }, /* Universal Coordinated Time */ + { "wet", tZONE, HOUR( 0) }, /* Western European */ { "bst", tDAYZONE, HOUR( 0) }, /* British Summer */ { "wat", tZONE, HOUR( 1) }, /* West Africa */ { "at", tZONE, HOUR( 2) }, /* Azores */ @@ -290,6 +296,7 @@ static TABLE TimezoneTable[] = { { "nt", tZONE, HOUR(11) }, /* Nome */ { "idlw", tZONE, HOUR(12) }, /* International Date Line West */ { "cet", tZONE, -HOUR( 1) }, /* Central European */ + { "cest", tDAYZONE, -HOUR( 1) }, /* Central European Summer */ { "met", tZONE, -HOUR( 1) }, /* Middle European */ { "mewt", tZONE, -HOUR( 1) }, /* Middle European Winter */ { "mest", tDAYZONE, -HOUR( 1) }, /* Middle European Summer */ @@ -419,11 +426,11 @@ Convert(Month, Day, Year, Hours, Minutes, Seconds, Meridian, DSTmode, TimePtr) time_t Julian; int i; - DaysInMonth[1] = Year % 4 == 0 && (Year % 100 != 0 || Year % 400 == 0) + 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]) + || 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++) @@ -656,14 +663,14 @@ TclDatelex() int sign; for ( ; ; ) { - while (isspace((unsigned char) (*TclDateInput))) { + while (isspace(UCHAR(*TclDateInput))) { TclDateInput++; } - if (isdigit(c = *TclDateInput) || c == '-' || c == '+') { /* INTL: digit */ + if (isdigit(UCHAR(c = *TclDateInput)) || c == '-' || c == '+') { /* INTL: digit */ if (c == '-' || c == '+') { sign = c == '-' ? -1 : 1; - if (!isdigit(*++TclDateInput)) { /* INTL: digit */ + if (!isdigit(UCHAR(*++TclDateInput))) { /* INTL: digit */ /* * skip the '-' sign */ @@ -673,7 +680,7 @@ TclDatelex() sign = 0; } for (TclDatelval.Number = 0; - isdigit(c = *TclDateInput++); ) { /* INTL: digit */ + isdigit(UCHAR(c = *TclDateInput++)); ) { /* INTL: digit */ TclDatelval.Number = 10 * TclDatelval.Number + c - '0'; } TclDateInput--; @@ -683,7 +690,7 @@ TclDatelex() return sign ? tSNUMBER : tUNUMBER; } if (!(c & 0x80) && isalpha(UCHAR(c))) { /* INTL: ISO only. */ - for (p = buff; isalpha(c = *TclDateInput++) /* INTL: ISO only. */ + for (p = buff; isalpha(UCHAR(c = *TclDateInput++)) /* INTL: ISO only. */ || c == '.'; ) { if (p < &buff[sizeof buff - 1]) { *p++ = c; @@ -803,14 +810,14 @@ TclGetDate(p, now, zone, timePtr) *timePtr = Start; return 0; } -TclDatetabelem TclDateexca[] ={ +static const TclDatetabelem TclDateexca[] ={ -1, 1, 0, -1, -2, 0, }; # define YYNPROD 41 # define YYLAST 227 -TclDatetabelem TclDateact[]={ +static const TclDatetabelem TclDateact[]={ 14, 11, 23, 28, 17, 12, 19, 18, 16, 9, 10, 13, 42, 21, 46, 45, 44, 48, 41, 37, @@ -835,39 +842,39 @@ TclDatetabelem TclDateact[]={ 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[]={ +static const 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[]={ +static const TclDatetabelem TclDatepgo[]={ 0, 28, 39, 38, 37, 36, 35, 34, 33, 32, 31 }; -TclDatetabelem TclDater1[]={ +static const 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[]={ +static const 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[]={ +static const 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[]={ +static const TclDatetabelem TclDatedef[]={ 1, -2, 2, 3, 4, 5, 6, 7, 8, 38, 15, 16, 0, 25, 17, 28, 0, 31, 34, 37, @@ -979,7 +986,7 @@ char * TclDatereds[] = #define YYRECOVERING() (!!TclDateerrflag) #define YYNEW(type) malloc(sizeof(type) * TclDatenewmax) #define YYCOPY(to, from, type) \ - (type *) memcpy(to, (char *) from, TclDatenewmax * sizeof(type)) + (type *) memcpy(to, (char *) from, TclDatemaxdepth * sizeof (type)) #define YYENLARGE( from, type) \ (type *) realloc((char *) from, TclDatenewmax * sizeof(type)) #ifndef YYDEBUG @@ -1063,12 +1070,12 @@ int TclDateparse(void) int TclDateparse() #endif { - register YYSTYPE *TclDatepvt; /* top of value stack for $vars */ + register YYSTYPE *TclDatepvt = 0; /* 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. + hacks to please C++ and lint - goto's inside + switch should never be executed */ static int __yaccpar_lint_hack__ = 0; switch (__yaccpar_lint_hack__) @@ -1076,7 +1083,6 @@ int TclDateparse() case 1: goto TclDateerrlab; case 2: goto TclDatenewstate; } - TclDatepvt = 0; #endif /* @@ -1167,9 +1173,9 @@ int TclDateparse() ** 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); + long TclDateps_index = (TclDate_ps - TclDates); + long TclDatepv_index = (TclDate_pv - TclDatev); + long TclDatepvt_index = (TclDatepvt - TclDatev); int TclDatenewmax; #ifdef YYEXPAND TclDatenewmax = YYEXPAND(TclDatemaxdepth); @@ -1295,7 +1301,7 @@ int TclDateparse() ** look through exception table */ { - register int *TclDatexi = TclDateexca; + register const int *TclDatexi = TclDateexca; while ( ( *TclDatexi != -1 ) || ( TclDatexi[1] != TclDate_state ) ) @@ -1572,10 +1578,10 @@ case 24:{ TclDateDay = TclDatepvt[-1].Number; } break; case 25:{ - TclDateMonth = 1; - TclDateDay = 1; - TclDateYear = EPOCH; - } break; + TclDateMonth = 1; + TclDateDay = 1; + TclDateYear = EPOCH; + } break; case 26:{ TclDateMonth = TclDatepvt[-1].Number; TclDateDay = TclDatepvt[-2].Number; diff --git a/generic/tclGetDate.y b/generic/tclGetDate.y index 2f519dce..6d73026 100644 --- a/generic/tclGetDate.y +++ b/generic/tclGetDate.y @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclGetDate.y,v 1.4 1999/04/16 00:46:46 stanton Exp $ + * RCS: @(#) $Id: tclGetDate.y,v 1.5 1999/09/21 04:20:40 hobbs Exp $ */ %{ @@ -250,11 +250,11 @@ date : tUNUMBER '/' tUNUMBER { yyMonth = $2; yyDay = $1; } - | tEPOCH { - yyMonth = 1; - yyDay = 1; - yyYear = EPOCH; - } + | tEPOCH { + yyMonth = 1; + yyDay = 1; + yyYear = EPOCH; + } | tUNUMBER tMONTH tUNUMBER { yyMonth = $2; yyDay = $1; @@ -413,7 +413,8 @@ 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 */ + { "uct", tZONE, HOUR( 0) }, /* Universal Coordinated Time */ + { "wet", tZONE, HOUR( 0) }, /* Western European */ { "bst", tDAYZONE, HOUR( 0) }, /* British Summer */ { "wat", tZONE, HOUR( 1) }, /* West Africa */ { "at", tZONE, HOUR( 2) }, /* Azores */ @@ -445,6 +446,7 @@ static TABLE TimezoneTable[] = { { "nt", tZONE, HOUR(11) }, /* Nome */ { "idlw", tZONE, HOUR(12) }, /* International Date Line West */ { "cet", tZONE, -HOUR( 1) }, /* Central European */ + { "cest", tDAYZONE, -HOUR( 1) }, /* Central European Summer */ { "met", tZONE, -HOUR( 1) }, /* Middle European */ { "mewt", tZONE, -HOUR( 1) }, /* Middle European Winter */ { "mest", tDAYZONE, -HOUR( 1) }, /* Middle European Summer */ @@ -574,21 +576,23 @@ Convert(Month, Day, Year, Hours, Minutes, Seconds, Meridian, DSTmode, TimePtr) time_t Julian; int i; - DaysInMonth[1] = Year % 4 == 0 && (Year % 100 != 0 || Year % 400 == 0) + 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]) + || 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); + Julian += 365 + (((i % 4) == 0) && + (((i % 100) != 0) || ((i % 400) == 0))); } else { for (i = Year; i < EPOCH; i++) - Julian -= 365 + (i % 4 == 0); + Julian -= 365 + (((i % 4) == 0) && + (((i % 100) != 0) || ((i % 400) == 0))); } Julian *= SECSPERDAY; Julian += yyTimezone * 60L; @@ -809,14 +813,14 @@ yylex() int sign; for ( ; ; ) { - while (isspace((unsigned char) (*yyInput))) { + while (isspace(UCHAR(*yyInput))) { yyInput++; } - if (isdigit(c = *yyInput) || c == '-' || c == '+') { /* INTL: digit */ + if (isdigit(UCHAR(c = *yyInput)) || c == '-' || c == '+') { /* INTL: digit */ if (c == '-' || c == '+') { sign = c == '-' ? -1 : 1; - if (!isdigit(*++yyInput)) { /* INTL: digit */ + if (!isdigit(UCHAR(*++yyInput))) { /* INTL: digit */ /* * skip the '-' sign */ @@ -826,7 +830,7 @@ yylex() sign = 0; } for (yylval.Number = 0; - isdigit(c = *yyInput++); ) { /* INTL: digit */ + isdigit(UCHAR(c = *yyInput++)); ) { /* INTL: digit */ yylval.Number = 10 * yylval.Number + c - '0'; } yyInput--; @@ -836,7 +840,7 @@ yylex() return sign ? tSNUMBER : tUNUMBER; } if (!(c & 0x80) && isalpha(UCHAR(c))) { /* INTL: ISO only. */ - for (p = buff; isalpha(c = *yyInput++) /* INTL: ISO only. */ + for (p = buff; isalpha(UCHAR(c = *yyInput++)) /* INTL: ISO only. */ || c == '.'; ) { if (p < &buff[sizeof buff - 1]) { *p++ = c; diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index bbb4e4e..e3f0a6e 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIOCmd.c,v 1.6 1999/05/05 01:19:43 stanton Exp $ + * RCS: @(#) $Id: tclIOCmd.c,v 1.7 1999/09/21 04:20:40 hobbs Exp $ */ #include "tclInt.h" @@ -350,12 +350,14 @@ Tcl_ReadObjCmd(dummy, interp, objc, objv) } } - resultPtr = Tcl_GetObjResult(interp); + resultPtr = Tcl_NewObj(); + Tcl_IncrRefCount(resultPtr); charactersRead = Tcl_ReadChars(chan, resultPtr, toRead, 0); if (charactersRead < 0) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "error reading \"", name, "\": ", Tcl_PosixError(interp), (char *) NULL); + Tcl_DecrRefCount(resultPtr); return TCL_ERROR; } @@ -372,6 +374,8 @@ Tcl_ReadObjCmd(dummy, interp, objc, objv) Tcl_SetObjLength(resultPtr, length - 1); } } + Tcl_SetObjResult(interp, resultPtr); + Tcl_DecrRefCount(resultPtr); return TCL_OK; } diff --git a/generic/tclPkg.c b/generic/tclPkg.c index 5cb1818..11211d9 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclPkg.c,v 1.4 1999/04/16 00:46:51 stanton Exp $ + * RCS: @(#) $Id: tclPkg.c,v 1.5 1999/09/21 04:20:40 hobbs Exp $ */ #include "tclInt.h" @@ -871,16 +871,19 @@ CheckVersion(interp, string) * by dots. */ { char *p = string; - + char prevChar; + if (!isdigit(UCHAR(*p))) { /* INTL: digit */ goto error; } - for (p++; *p != 0; p++) { - if (!isdigit(UCHAR(*p)) && (*p != '.')) { /* INTL: digit */ + for (prevChar = *p, p++; *p != 0; p++) { + if (!isdigit(UCHAR(*p)) && + ((*p != '.') || (prevChar == '.'))) { /* INTL: digit */ goto error; } + prevChar = *p; } - if (p[-1] != '.') { + if (prevChar != '.') { return TCL_OK; } diff --git a/generic/tclUtil.c b/generic/tclUtil.c index d60e409..0a6085b 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclUtil.c,v 1.12 1999/05/22 01:20:13 stanton Exp $ + * RCS: @(#) $Id: tclUtil.c,v 1.13 1999/09/21 04:20:41 hobbs Exp $ */ #include "tclInt.h" @@ -2223,34 +2223,33 @@ TclGetIntForIndex(interp, objPtr, endValue, indexPtr) bytes = Tcl_GetStringFromObj(objPtr, &length); - if ((*bytes != 'e') || - (strncmp(bytes, "end", (size_t)((length > 3) ? 3 : length)) != 0)) { - if (Tcl_GetIntFromObj(NULL, objPtr, &offset) != TCL_OK) { - goto intforindex_error; - } - *indexPtr = offset; - return TCL_OK; + if ((*bytes != 'e') || (strncmp(bytes, "end", + (size_t)((length > 3) ? 3 : length)) != 0)) { + if (Tcl_GetIntFromObj(NULL, objPtr, &offset) != TCL_OK) { + goto intforindex_error; + } + *indexPtr = offset; + return TCL_OK; } if (length <= 3) { - *indexPtr = endValue; + *indexPtr = endValue; } else if (bytes[3] == '-') { - /* - * This is our limited string expression evaluator - */ - if (Tcl_GetInt(interp, bytes+3, &offset) != TCL_OK) { - return TCL_ERROR; - } - *indexPtr = endValue + offset; + /* + * This is our limited string expression evaluator + */ + if (Tcl_GetInt(interp, bytes+3, &offset) != TCL_OK) { + return TCL_ERROR; + } + *indexPtr = endValue + offset; } else { - intforindex_error: - if ((Interp *)interp != NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "bad index \"", bytes, - "\": must be integer or end?-integer?", - (char *) NULL); - } - return TCL_ERROR; + intforindex_error: + if ((Interp *)interp != NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "bad index \"", bytes, + "\": must be integer or end?-integer?", (char *) NULL); + } + return TCL_ERROR; } return TCL_OK; } diff --git a/generic/tclVar.c b/generic/tclVar.c index 67a5cab..f7ceedc 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -14,7 +14,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclVar.c,v 1.12 1999/08/10 02:42:14 welch Exp $ + * RCS: @(#) $Id: tclVar.c,v 1.13 1999/09/21 04:20:41 hobbs Exp $ */ #include "tclInt.h" @@ -2845,10 +2845,11 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) enum {ARRAY_ANYMORE, ARRAY_DONESEARCH, ARRAY_EXISTS, ARRAY_GET, ARRAY_NAMES, ARRAY_NEXTELEMENT, ARRAY_SET, ARRAY_SIZE, - ARRAY_STARTSEARCH}; - static char *arrayOptions[] = {"anymore", "donesearch", "exists", - "get", "names", "nextelement", "set", - "size", "startsearch", (char *) NULL}; + ARRAY_STARTSEARCH, ARRAY_UNSET}; + static char *arrayOptions[] = { + "anymore", "donesearch", "exists", "get", "names", "nextelement", + "set", "size", "startsearch", "unset", (char *) NULL + }; Interp *iPtr = (Interp *) interp; Var *varPtr, *arrayPtr; @@ -3161,6 +3162,46 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) varPtr->searchPtr = searchPtr; break; } + case ARRAY_UNSET: { + Tcl_HashSearch search; + Var *varPtr2; + char *pattern = NULL; + char *name; + + if ((objc != 3) && (objc != 4)) { + Tcl_WrongNumArgs(interp, 2, objv, "arrayName ?pattern?"); + return TCL_ERROR; + } + if (notArray) { + return TCL_OK; + } + if (objc == 3) { + /* + * When no pattern is given, just unset the whole array + */ + if (Tcl_UnsetVar2(interp, varName, (char *) NULL, 0) + != TCL_OK) { + return TCL_ERROR; + } + } else { + pattern = Tcl_GetString(objv[3]); + for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, + &search); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + varPtr2 = (Var *) Tcl_GetHashValue(hPtr); + if (TclIsVarUndefined(varPtr2)) { + continue; + } + name = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr); + if (Tcl_StringMatch(name, pattern) && + (Tcl_UnsetVar2(interp, varName, name, 0) + != TCL_OK)) { + return TCL_ERROR; + } + } + } + break; + } } return TCL_OK; @@ -3255,8 +3296,7 @@ TclArraySet(interp, arrayNameObj, arrayElemObj) return TCL_OK; } - if (TclIsVarArrayElement(varPtr) || - !TclIsVarUndefined(varPtr)) { + if (TclIsVarArrayElement(varPtr) || !TclIsVarUndefined(varPtr)) { /* * Either an array element, or a scalar: lose! */ @@ -3269,9 +3309,17 @@ TclArraySet(interp, arrayNameObj, arrayElemObj) * Create variable for new array. */ - varPtr = TclLookupVar(interp, varName, (char *) NULL, 0, 0, + varPtr = TclLookupVar(interp, varName, (char *) NULL, + TCL_LEAVE_ERR_MSG, "set", /*createPart1*/ 1, /*createPart2*/ 0, &arrayPtr); + /* + * Still couldn't do it - this can occur if a non-existent + * namespace was specified + */ + if (varPtr == NULL) { + return TCL_ERROR; + } } TclSetVarArray(varPtr); TclClearVarUndefined(varPtr); |