From a583a768fbe40ec2b7d661fe32d8347a34632fcf Mon Sep 17 00:00:00 2001 From: hobbs Date: Tue, 21 Sep 1999 04:20:28 +0000 Subject: 1999-09-16 Jeff Hobbs * 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 * 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 * 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) --- ChangeLog | 75 ++++++++++++++++++++++++++++++++ doc/array.n | 13 +++++- doc/clock.n | 13 ++++-- doc/lindex.n | 4 +- doc/linsert.n | 22 +++++----- doc/msgcat.n | 4 +- doc/regexp.n | 15 ++++++- doc/regsub.n | 15 ++++++- doc/switch.n | 11 ++++- generic/tclCkalloc.c | 104 ++++++++++++++++++++++++++------------------ generic/tclClock.c | 36 +++++++++++++--- generic/tclCmdAH.c | 23 +++++++--- generic/tclCmdIL.c | 10 +++-- generic/tclCmdMZ.c | 119 ++++++++++++++++++++++++++++++++++++++++----------- generic/tclDate.c | 80 ++++++++++++++++++---------------- generic/tclGetDate.y | 38 ++++++++-------- generic/tclIOCmd.c | 8 +++- generic/tclPkg.c | 13 +++--- generic/tclUtil.c | 47 ++++++++++---------- generic/tclVar.c | 64 +++++++++++++++++++++++---- tests/clock.test | 19 ++++++-- tests/format.test | 15 ++++++- tests/linsert.test | 5 ++- tests/pkg.test | 5 ++- tests/regexp.test | 54 +++++++++++++++++++++-- tests/set-old.test | 13 +++++- tests/timer.test | 4 +- tests/var.test | 20 ++++++++- 28 files changed, 634 insertions(+), 215 deletions(-) diff --git a/ChangeLog b/ChangeLog index 730fe32..96aa4a2 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,78 @@ +1999-09-16 Jeff Hobbs + + * 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 + + * 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 + + * 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) + 1999-09-01 Jeff Hobbs * generic/tclParseExpr.c: changed '"' to '\"' to make FreeBSD diff --git a/doc/array.n b/doc/array.n index 42fc193..2a5b1fc 100644 --- a/doc/array.n +++ b/doc/array.n @@ -5,10 +5,10 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: array.n,v 1.3 1999/08/09 16:30:35 hobbs Exp $ +'\" RCS: @(#) $Id: array.n,v 1.4 1999/09/21 04:20:35 hobbs Exp $ '\" .so man.macros -.TH array n 7.4 Tcl "Tcl Built-In Commands" +.TH array n 8.3 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME @@ -111,6 +111,15 @@ The return value is a search identifier that must be used in \fBarray nextelement\fR and \fBarray donesearch\fR commands; it allows multiple searches to be underway simultaneously for the same array. +.VS 8.3 +.TP +\fBarray unset \fIarrayName\fR ?\fIpattern\fR? +Unsets all of the elements in the array that match \fIpattern\fR (using the +matching rules of \fBstring match\fR). If \fIarrayName\fR isn't the name +of an array variable or there are no matching elements in the array, then +an empty string is returned. If \fIpattern\fR is omitted and is it an +array variable, then the command unsets the entire array. +.VE 8.3 .SH KEYWORDS array, element names, search diff --git a/doc/clock.n b/doc/clock.n index 168d0c0..ed3daa9 100644 --- a/doc/clock.n +++ b/doc/clock.n @@ -1,6 +1,7 @@ '\" '\" Copyright (c) 1992-1995 Karl Lehenbauer and Mark Diekhans. '\" Copyright (c) 1995-1997 Sun Microsystems, Inc. +'\" Copyright (c) 1998-1999 Scriptics Corporation '\" '\" This documentation is derived from the time and date facilities of '\" TclX, by Mark Diekhans and Karl Lehenbauer. @@ -8,10 +9,10 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: clock.n,v 1.3 1999/08/09 16:30:35 hobbs Exp $ +'\" RCS: @(#) $Id: clock.n,v 1.4 1999/09/21 04:20:35 hobbs Exp $ '\" .so man.macros -.TH clock n 7.4 Tcl "Tcl Built-In Commands" +.TH clock n 8.3 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME @@ -28,12 +29,16 @@ time. The \fIoption\fR argument determines what action is carried out by the command. The legal \fIoptions\fR (which may be abbreviated) are: .TP -\fBclock clicks\fR +.VS 8.3 +\fBclock clicks\fR ?\fB\-milliseconds\fR? Return a high-resolution time value as a system-dependent integer value. The unit of the value is system-dependent but should be the highest resolution clock available on the system such as a CPU cycle -counter. This value should only be used for the relative measurement +counter. If \fB\-milliseconds\fR is specified, then the value is +guaranteed to be of millisecond granularity. +This value should only be used for the relative measurement of elapsed time. +.VE 8.3 .TP \fBclock format \fIclockValue\fR ?\fB\-format \fIstring\fR? ?\fB\-gmt \fIboolean\fR? Converts an integer time value, typically returned by diff --git a/doc/lindex.n b/doc/lindex.n index 58bc2b5..70cf1cf 100644 --- a/doc/lindex.n +++ b/doc/lindex.n @@ -5,10 +5,10 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: lindex.n,v 1.3 1999/08/09 16:30:35 hobbs Exp $ +'\" RCS: @(#) $Id: lindex.n,v 1.4 1999/09/21 04:20:36 hobbs Exp $ '\" .so man.macros -.TH lindex n 7.4 Tcl "Tcl Built-In Commands" +.TH lindex n 8.2 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME diff --git a/doc/linsert.n b/doc/linsert.n index 4877e03..69d7f4a 100644 --- a/doc/linsert.n +++ b/doc/linsert.n @@ -5,10 +5,10 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: linsert.n,v 1.2 1998/09/14 18:39:53 stanton Exp $ +'\" RCS: @(#) $Id: linsert.n,v 1.3 1999/09/21 04:20:36 hobbs Exp $ '\" .so man.macros -.TH linsert n 7.4 Tcl "Tcl Built-In Commands" +.TH linsert n 8.2 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME @@ -19,15 +19,15 @@ linsert \- Insert elements into a list .SH DESCRIPTION .PP -This command produces a new list from \fIlist\fR by inserting all -of the \fIelement\fR arguments just before the \fIindex\fRth -element of \fIlist\fR. Each \fIelement\fR argument will become -a separate element of the new list. If \fIindex\fR is less than -or equal to zero, then the new elements are inserted at the -beginning of the list. If \fIindex\fR -has the value \fBend\fR, -or if it is greater than or equal to the number of elements in the list, -then the new elements are appended to the list. +This command produces a new list from \fIlist\fR by inserting all of the +\fIelement\fR arguments just before the \fIindex\fRth element of +\fIlist\fR. Each \fIelement\fR argument will become a separate element of +the new list. If \fIindex\fR is less than or equal to zero, then the new +elements are inserted at the beginning of the list. If \fIindex\fR has the +value \fBend\fR, or if it is greater than or equal to the number of +elements in the list, then the new elements are appended to the list. +\fBend\-\fIinteger\fR refers to the last element in the list minus the +specified integer offset. .SH KEYWORDS element, insert, list diff --git a/doc/msgcat.n b/doc/msgcat.n index 02f4085..748d023 100644 --- a/doc/msgcat.n +++ b/doc/msgcat.n @@ -191,8 +191,8 @@ format "In location %s we produced %d units" $city $num This can be handled by using the positional parameters: .CS -format "We produced %1\\\\$d units in location %2\\\\$s" $num $city -format "In location %2\\\\$s we produced %1\\\\$d units" $num $city +format "We produced %1\\$d units in location %2\\$s" $num $city +format "In location %2\\$s we produced %1\\$d units" $num $city .CE .PP Similarly, positional parameters can be used with \fBscan\fR to diff --git a/doc/regexp.n b/doc/regexp.n index 03010e3..3b19420 100644 --- a/doc/regexp.n +++ b/doc/regexp.n @@ -4,10 +4,10 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: regexp.n,v 1.6 1999/06/24 21:15:13 jpeek Exp $ +'\" RCS: @(#) $Id: regexp.n,v 1.7 1999/09/21 04:20:36 hobbs Exp $ '\" .so man.macros -.TH regexp n 8.1 Tcl "Tcl Built-In Commands" +.TH regexp n 8.3 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME @@ -83,6 +83,17 @@ element of the list is a subexpression count. The second element is a list of property names that describe various attributes of the regular expression. This switch is primarily intended for debugging purposes. .VE 8.1 +.VS 8.3 +.TP 15 +\fB\-start\fR \fIindex\fR +Specifies a character index offset into the string to start +matching the regular expression at. When using this switch, `^' +will not match the beginning of the line, and \\A will still +match the start of the string at \fIindex\fR. If \fB\-indices\fR +is specified, the indices will be indexed starting from the +absolute beginning of the input string. +\fIindex\fR will be constrained to the bounds of the input string. +.VE 8.3 .TP 15 \fB\-\|\-\fR Marks the end of switches. The argument following this one will diff --git a/doc/regsub.n b/doc/regsub.n index 65c22a6..b895bdb 100644 --- a/doc/regsub.n +++ b/doc/regsub.n @@ -5,10 +5,10 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: regsub.n,v 1.3 1999/06/24 21:15:13 jpeek Exp $ +'\" RCS: @(#) $Id: regsub.n,v 1.4 1999/09/21 04:20:36 hobbs Exp $ '\" .so man.macros -.TH regsub n 7.4 Tcl "Tcl Built-In Commands" +.TH regsub n 8.3 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME @@ -60,6 +60,17 @@ from the corresponding match. Upper-case characters in \fIstring\fR will be converted to lower-case before matching against \fIexp\fR; however, substitutions specified by \fIsubSpec\fR use the original unconverted form of \fIstring\fR. +.VS 8.3 +.TP 10 +\fB\-start\fR \fIindex\fR +Specifies a character index offset into the string to start +matching the regular expression at. When using this switch, `^' +will not match the beginning of the line, and \\A will still +match the start of the string at \fIindex\fR. If \fB\-indices\fR +is specified, the indices will be indexed starting from the +absolute beginning of the input string. +\fIindex\fR will be constrained to the bounds of the input string. +.VE 8.3 .TP 10 \fB\-\|\-\fR Marks the end of switches. The argument following this one will diff --git a/doc/switch.n b/doc/switch.n index fb7ac60..c454a3d 100644 --- a/doc/switch.n +++ b/doc/switch.n @@ -5,7 +5,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: switch.n,v 1.3 1999/06/24 21:15:14 jpeek Exp $ +'\" RCS: @(#) $Id: switch.n,v 1.4 1999/09/21 04:20:36 hobbs Exp $ '\" .so man.macros .TH switch n 7.0 Tcl "Tcl Built-In Commands" @@ -75,6 +75,10 @@ then the body after that is used, and so on). This feature makes it possible to share a single \fIbody\fR among several patterns. .PP +Beware of how you place comments in \fBswitch\fR commands. Comments +should only be placed \fBinside\fR the execution body of one of the +patterns, and not intermingled with the patterns. +.PP Below are some examples of \fBswitch\fR commands: .CS \fBswitch\0abc\0a\0\-\0b\0{format 1}\0abc\0{format 2}\0default\0{format 3}\fR @@ -94,7 +98,10 @@ will return \fB1\fR, and a \- b - {format 1} + { + # Correct Comment Placement + format 1 + } a* {format 2} default 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); diff --git a/tests/clock.test b/tests/clock.test index d0192cd..1b1632f 100644 --- a/tests/clock.test +++ b/tests/clock.test @@ -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: clock.test,v 1.4 1999/06/26 03:54:10 jenn Exp $ +# RCS: @(#) $Id: clock.test,v 1.5 1999/09/21 04:20:44 hobbs Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -30,14 +30,25 @@ test clock-2.1 {clock clicks tests} { concat {} } {} test clock-2.2 {clock clicks tests} { - list [catch {clock clicks foo} msg] $msg -} {1 {wrong # args: should be "clock clicks"}} -test clock-2.3 {clock clicks tests} { set start [clock clicks] after 10 set end [clock clicks] expr "$end > $start" } {1} +test clock-2.3 {clock clicks tests} { + list [catch {clock clicks foo} msg] $msg +} {1 {bad switch "foo": must be -milliseconds}} +test clock-2.3 {clock clicks tests} { + expr [clock clicks -milliseconds]+1 + concat {} +} {} +test clock-2.2 {clock clicks tests, millisecond timing test} { + set start [clock clicks -milli] + after 10 + set end [clock clicks -milli] + # assume, even with slow interp'ing, the diff is less than 60 msecs + expr {($end > $start) && (($end - $start) < 60)} +} {1} # clock format test clock-3.1 {clock format tests} {unixOnly} { diff --git a/tests/format.test b/tests/format.test index 58f142f..3d3b88e 100644 --- a/tests/format.test +++ b/tests/format.test @@ -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: format.test,v 1.6 1999/08/17 21:34:45 jenn Exp $ +# RCS: @(#) $Id: format.test,v 1.7 1999/09/21 04:20:44 hobbs Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -467,6 +467,19 @@ test format-14.2 {testing MAX_FLOAT_SIZE for 0 and 1} { format {%s} "a" } {a} +test format-15.1 {testing %0..s 0 padding for chars/strings} { + format %05s a +} {0000a} +test format-15.2 {testing %0..s 0 padding for chars/strings} { + format "% 5s" a +} { a} +test format-15.3 {testing %0..s 0 padding for chars/strings} { + format %5s a +} { a} +test format-15.4 {testing %0..s 0 padding for chars/strings} { + format %05c 61 +} {0000=} + set a "0123456789" set b "" for {set i 0} {$i < 290} {incr i} { diff --git a/tests/linsert.test b/tests/linsert.test index c1e42a6..1a1ee82 100644 --- a/tests/linsert.test +++ b/tests/linsert.test @@ -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: linsert.test,v 1.6 1999/06/26 03:54:16 jenn Exp $ +# RCS: @(#) $Id: linsert.test,v 1.7 1999/09/21 04:20:44 hobbs Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -78,6 +78,9 @@ test linsert-1.18 {linsert command} { test linsert-1.19 {linsert command} { linsert {} end q r } {q r} +test linsert-1.20 {linsert command, use of end-int index} { + linsert {a b c d} end-2 e f +} {a b e f c d} test linsert-2.1 {linsert errors} { list [catch linsert msg] $msg diff --git a/tests/pkg.test b/tests/pkg.test index 82cc7a5..806a5fb 100644 --- a/tests/pkg.test +++ b/tests/pkg.test @@ -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: pkg.test,v 1.6 1999/06/26 20:55:09 rjohnson Exp $ +# RCS: @(#) $Id: pkg.test,v 1.7 1999/09/21 04:20:44 hobbs Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -529,6 +529,9 @@ test pkg-5.3 {CheckVersion procedure} { test pkg-5.4 {CheckVersion procedure} { list [catch {package vcompare 1.2.3. 2.1} msg] $msg } {1 {expected version number but got "1.2.3."}} +test pkg-5.5 {CheckVersion procedure} { + list [catch {package vcompare 1.2..3 2.1} msg] $msg +} {1 {expected version number but got "1.2..3"}} test pkg-6.1 {ComparePkgVersions procedure} { package vcompare 1.23 1.22 diff --git a/tests/regexp.test b/tests/regexp.test index b0f101c..6bff015 100644 --- a/tests/regexp.test +++ b/tests/regexp.test @@ -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: regexp.test,v 1.9 1999/08/23 17:54:59 jenn Exp $ +# RCS: @(#) $Id: regexp.test,v 1.10 1999/09/21 04:20:45 hobbs Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -190,7 +190,7 @@ test regexp-6.2 {regexp errors} { } {1 {wrong # args: should be "regexp ?switches? exp string ?matchVar? ?subMatchVar subMatchVar ...?"}} test regexp-6.3 {regexp errors} { list [catch {regexp -gorp a} msg] $msg -} {1 {bad switch "-gorp": must be -indices, -nocase, -about, -expanded, -line, -linestop, -lineanchor, or --}} +} {1 {bad switch "-gorp": must be -indices, -nocase, -about, -expanded, -line, -linestop, -lineanchor, -start, or --}} test regexp-6.4 {regexp errors} { list [catch {regexp a( b} msg] $msg } {1 {couldn't compile regular expression pattern: parentheses () not balanced}} @@ -208,6 +208,9 @@ test regexp-6.8 {regexp errors} { set f1 44 list [catch {regexp abc abc f1(f2)} msg] $msg } {1 {couldn't set variable "f1(f2)"}} +test regexp-6.9 {regexp errors, -start bad int check} { + list [catch {regexp -start bogus {^$} {}} msg] $msg +} {1 {expected integer but got "bogus"}} test regexp-7.1 {basic regsub operation} { list [regsub aa+ xaxaaaxaa 111&222 foo] $foo @@ -353,7 +356,7 @@ test regexp-11.4 {regsub errors} { } {1 {wrong # args: should be "regsub ?switches? exp string subSpec varName"}} test regexp-11.5 {regsub errors} { list [catch {regsub -gorp a b c} msg] $msg -} {1 {bad switch "-gorp": must be -all, -nocase, -expanded, -line, -linestop, -lineanchor, or --}} +} {1 {bad switch "-gorp": must be -all, -nocase, -expanded, -line, -linestop, -lineanchor, -start, or --}} test regexp-11.6 {regsub errors} { list [catch {regsub -nocase a( b c d} msg] $msg } {1 {couldn't compile regular expression pattern: parentheses () not balanced}} @@ -362,6 +365,9 @@ test regexp-11.7 {regsub errors} { set f1 44 list [catch {regsub -nocase aaa aaa xxx f1(f2)} msg] $msg } {1 {couldn't set variable "f1(f2)"}} +test regexp-11.8 {regsub errors, -start bad int check} { + list [catch {regsub -start bogus pattern string rep var} msg] $msg +} {1 {expected integer but got "bogus"}} # This test crashes on the Mac unless you increase the Stack Space to about 1 # Meg. This is probably bigger than most users want... @@ -414,6 +420,48 @@ test regexp-14.3 {unixOrPc} {CompileRegexp: regexp cache, empty regexp and empty exec $::tcltest::tcltest junk.tcl } 1 +test regexp-15.1 {regexp -start} { + catch {unset x} + list [regexp -start -10 {\d} 1abc2de3 x] $x +} {1 1} +test regexp-15.2 {regexp -start} { + catch {unset x} + list [regexp -start 2 {\d} 1abc2de3 x] $x +} {1 2} +test regexp-15.3 {regexp -start} { + catch {unset x} + list [regexp -start 4 {\d} 1abc2de3 x] $x +} {1 2} +test regexp-15.4 {regexp -start} { + catch {unset x} + list [regexp -start 5 {\d} 1abc2de3 x] $x +} {1 3} +test regexp-15.5 {regexp -start, over end of string} { + catch {unset x} + list [regexp -start [string length 1abc2de3] {\d} 1abc2de3 x] [info exists x] +} {0 0} +test regexp-15.6 {regexp -start, loss of ^$ behavior} { + list [regexp -start 2 {^$} {}] +} {0} + +test regexp-16.1 {regsub -start} { + catch {unset x} + list [regsub -all -start 2 {\d} a1b2c3d4e5 {/&} x] $x +} {4 a1b/2c/3d/4e/5} +test regexp-16.2 {regsub -start} { + catch {unset x} + list [regsub -all -start -25 {z} hello {/&} x] $x +} {0 hello} +test regexp-16.3 {regsub -start} { + catch {unset x} + list [regsub -all -start 3 {z} hello {/&} x] $x +} {0 hello} +test regexp-16.4 {regsub -start, \A behavior} { + set out {} + lappend out [regsub -start 0 -all {\A(\w)} {abcde} {/\1} x] $x + lappend out [regsub -start 2 -all {\A(\w)} {abcde} {/\1} x] $x +} {5 /a/b/c/d/e 3 ab/c/d/e} + set x 1 set y 2 regexp "$x$y" 123 diff --git a/tests/set-old.test b/tests/set-old.test index 7fec23e..02bc702 100644 --- a/tests/set-old.test +++ b/tests/set-old.test @@ -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: set-old.test,v 1.6 1999/06/26 20:55:12 rjohnson Exp $ +# RCS: @(#) $Id: set-old.test,v 1.7 1999/09/21 04:20:45 hobbs Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -296,7 +296,7 @@ test set-old-8.6 {array command} { catch {unset a} set a(22) 3 list [catch {array gorp a} msg] $msg -} {1 {bad option "gorp": must be anymore, donesearch, exists, get, names, nextelement, set, size, or startsearch}} +} {1 {bad option "gorp": must be anymore, donesearch, exists, get, names, nextelement, set, size, startsearch, or unset}} test set-old-8.7 {array command, anymore option} { catch {unset a} list [catch {array anymore a x} msg] $msg @@ -501,6 +501,15 @@ test set-old-8.37.4 {array command, empty set with populated array} { array set aVaRnAmE [list e3 v3] list [lsort [array names aVaRnAmE]] [catch {set aVaRnAmE(e2)} msg] $msg } {{e1 e2 e3} 0 v2} +test set-old-8.37.5 {array command, set with non-existent namespace} { + list [catch {array set bogusnamespace::var {}} msg] $msg +} {1 {can't set "bogusnamespace::var": parent namespace doesn't exist}} +test set-old-8.37.6 {array command, set with non-existent namespace} { + list [catch {array set bogusnamespace::var {a b}} msg] $msg +} {1 {can't set "bogusnamespace::var(a)": parent namespace doesn't exist}} +test set-old-8.37.7 {array command, set with non-existent namespace} { + list [catch {array set bogusnamespace::var(0) {a b}} msg] $msg +} {1 {can't set "bogusnamespace::var(0)": variable isn't array}} test set-old-8.38 {array command, size option} { catch {unset a} array size a diff --git a/tests/timer.test b/tests/timer.test index 4a85cda..b9ed530 100644 --- a/tests/timer.test +++ b/tests/timer.test @@ -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: timer.test,v 1.5 1999/06/26 20:55:15 rjohnson Exp $ +# RCS: @(#) $Id: timer.test,v 1.6 1999/09/21 04:20:45 hobbs Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -412,7 +412,7 @@ test timer-6.29 {Tcl_AfterCmd procedure, info option, script with NULL} { } set x "hello world" set id junk - set id [after 1 set x ab\0cd] + set id [after 10 set x ab\0cd] update set y [string length [lindex [lindex [after info $id] 0] 2]] foreach i [after info] { diff --git a/tests/var.test b/tests/var.test index d9d0fe0..af962a8 100644 --- a/tests/var.test +++ b/tests/var.test @@ -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: var.test,v 1.8 1999/07/22 21:50:55 redman Exp $ +# RCS: @(#) $Id: var.test,v 1.9 1999/09/21 04:20:45 hobbs Exp $ # if {[lsearch [namespace children] ::tcltest] == -1} { @@ -584,6 +584,24 @@ test var-10.2 {can't nest arrays with array set} { list [catch {array set arr(x) {}} res] $res } {1 {can't set "arr(x)": variable isn't array}} +test var-11.1 {array unset} { + catch {unset a} + array set a { 1,1 a 1,2 b 2,1 c 2,3 d } + array unset a 1,* + lsort -dict [array names a] +} {2,1 2,3} +test var-11.2 {array unset} { + catch {unset a} + array set a { 1,1 a 1,2 b } + array unset a + array exists a +} 0 +test var-11.3 {array unset errors} { + catch {unset a} + array set a { 1,1 a 1,2 b } + list [catch {array unset a pattern too} msg] $msg +} {1 {wrong # args: should be "array unset arrayName ?pattern?"}} + catch {namespace delete ns} catch {unset arr} catch {unset v} -- cgit v0.12