summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
Diffstat (limited to 'generic')
-rw-r--r--generic/tclCkalloc.c104
-rw-r--r--generic/tclClock.c36
-rw-r--r--generic/tclCmdAH.c23
-rw-r--r--generic/tclCmdIL.c10
-rw-r--r--generic/tclCmdMZ.c119
-rw-r--r--generic/tclDate.c80
-rw-r--r--generic/tclGetDate.y38
-rw-r--r--generic/tclIOCmd.c8
-rw-r--r--generic/tclPkg.c13
-rw-r--r--generic/tclUtil.c47
-rw-r--r--generic/tclVar.c64
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);
generated by cgit v0.12 at 2024-11-08 09:38:06 (GMT)