summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authormig <mig>2013-02-11 13:50:47 (GMT)
committermig <mig>2013-02-11 13:50:47 (GMT)
commit0055995ec13ad8f27603d140ca19d7858725ef95 (patch)
tree14f5697a44b71bd7eb3091709c9cac4fe3868025
parenteb1adf553cfd18472faa6c11b1d46434c15e064f (diff)
parent30f60173c4738c76675b58db3a7a5aaa62ca79ea (diff)
downloadtcl-mig_alloc_reform.zip
tcl-mig_alloc_reform.tar.gz
tcl-mig_alloc_reform.tar.bz2
merge trunkmig_alloc_reform
-rw-r--r--ChangeLog153
-rw-r--r--doc/namespace.n2
-rw-r--r--doc/string.n4
-rw-r--r--doc/try.n2
-rw-r--r--generic/regc_nfa.c4
-rw-r--r--generic/tcl.h9
-rw-r--r--generic/tclAssembly.c17
-rw-r--r--generic/tclBasic.c5
-rw-r--r--generic/tclBinary.c11
-rw-r--r--generic/tclCkalloc.c4
-rw-r--r--generic/tclCmdMZ.c3
-rw-r--r--generic/tclCompCmds.c128
-rw-r--r--generic/tclCompCmdsSZ.c10
-rw-r--r--generic/tclCompExpr.c2
-rw-r--r--generic/tclCompile.c18
-rw-r--r--generic/tclDecls.h12
-rw-r--r--generic/tclDictObj.c56
-rw-r--r--generic/tclEncoding.c8
-rw-r--r--generic/tclEnsemble.c30
-rw-r--r--generic/tclExecute.c210
-rw-r--r--generic/tclGet.c2
-rw-r--r--generic/tclIO.c4
-rw-r--r--generic/tclIOUtil.c3
-rw-r--r--generic/tclIndexObj.c40
-rw-r--r--generic/tclInt.decls46
-rw-r--r--generic/tclInt.h3
-rw-r--r--generic/tclIntDecls.h61
-rw-r--r--generic/tclListObj.c16
-rw-r--r--generic/tclLoadNone.c33
-rw-r--r--generic/tclOO.c2
-rw-r--r--generic/tclOOBasic.c55
-rw-r--r--generic/tclOOCall.c11
-rw-r--r--generic/tclOOMethod.c2
-rw-r--r--generic/tclObj.c15
-rw-r--r--generic/tclPathObj.c8
-rw-r--r--generic/tclPort.h5
-rw-r--r--generic/tclProc.c37
-rw-r--r--generic/tclRegexp.c10
-rw-r--r--generic/tclResult.c2
-rw-r--r--generic/tclStringObj.c4
-rw-r--r--generic/tclStubInit.c37
-rw-r--r--generic/tclTestObj.c8
-rw-r--r--generic/tclThreadTest.c3
-rw-r--r--generic/tclTrace.c2
-rw-r--r--generic/tclVar.c56
-rw-r--r--generic/tclZlib.c4
-rw-r--r--library/auto.tcl25
-rw-r--r--library/http/http.tcl64
-rw-r--r--library/init.tcl83
-rw-r--r--library/package.tcl26
-rw-r--r--library/platform/pkgIndex.tcl2
-rw-r--r--library/platform/platform.tcl4
-rw-r--r--library/tcltest/tcltest.tcl198
-rw-r--r--library/tm.tcl10
-rw-r--r--library/word.tcl10
-rw-r--r--macosx/tclMacOSXFCmd.c4
-rw-r--r--tests/assocd.test8
-rw-r--r--tests/basic.test18
-rw-r--r--tests/cmdInfo.test8
-rw-r--r--tests/dcall.test8
-rw-r--r--tests/expr-old.test14
-rw-r--r--tests/http.test7
-rw-r--r--tests/main.test26
-rw-r--r--tests/msgcat.test12
-rw-r--r--tests/oo.test19
-rw-r--r--tests/parse.test27
-rw-r--r--tests/parseExpr.test8
-rw-r--r--tests/parseOld.test22
-rw-r--r--tests/pkgMkIndex.test16
-rw-r--r--tests/platform.test17
-rw-r--r--tests/reg.test75
-rw-r--r--tests/result.test6
-rw-r--r--tests/set.test5
-rw-r--r--tests/stack.test6
-rwxr-xr-xtests/tcltest.test17
-rw-r--r--tests/thread.test22
-rw-r--r--tests/tm.test2
-rw-r--r--tests/trace.test295
-rw-r--r--tests/unixInit.test16
-rw-r--r--tests/unknown.test10
-rw-r--r--tests/var.test69
-rw-r--r--tests/zlib.test19
-rw-r--r--unix/Makefile.in41
-rw-r--r--unix/tclUnixCompat.c15
-rw-r--r--unix/tclUnixFCmd.c2
-rw-r--r--unix/tclUnixFile.c6
-rw-r--r--unix/tclUnixPort.h52
-rw-r--r--unix/tclUnixSock.c6
-rw-r--r--unix/tclUnixTest.c10
-rw-r--r--unix/tclUnixTime.c2
-rw-r--r--win/Makefile.in11
-rw-r--r--win/tcl.m4236
-rw-r--r--win/tclWinConsole.c1
-rw-r--r--win/tclWinFile.c13
-rw-r--r--win/tclWinPipe.c2
-rw-r--r--win/tclWinSerial.c2
-rw-r--r--win/tclWinTest.c2
-rw-r--r--win/tclWinThrd.c1
98 files changed, 1628 insertions, 1109 deletions
diff --git a/ChangeLog b/ChangeLog
index 83e7053..64d80c1 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,23 +1,147 @@
+2013-02-11 Donal K. Fellows <dkf@users.sf.net>
+
+ * generic/tclZlib.c (ZlibTransformOutput): [Bug 3603553]: Ensure that
+ data gets written to the underlying stream by compressing transforms
+ when the amount of data to be written is one buffer's-worth; problem
+ was particularly likely to occur when compressing large quantities of
+ not-very-compressible data. Many thanks to Piera Poggio (vampiera) for
+ reporting.
+
+2013-02-09 Donal K. Fellows <dkf@users.sf.net>
+
+ * generic/tclOOBasic.c (TclOO_Object_VarName): [Bug 3603695]: Change
+ the way that the 'varname' method is implemented so that there are no
+ longer problems with interactions due to the resolver. Thanks to
+ Taylor Venable <tcvena@gmail.com> for identifying the problem.
+
+2013-02-08 Donal K. Fellows <dkf@users.sf.net>
+
+ * generic/regc_nfa.c (duptraverse): [Bug 3603557]: Increase the
+ maximum depth of recursion used when duplicating an automaton in
+ response to encountering a "wild" RE that hit the previous limit.
+ Allow the limit (DUPTRAVERSE_MAX_DEPTH) to be set by defining its
+ value in the Makefile. Problem reported by Jonathan Mills.
+
+2013-02-05 Don Porter <dgp@users.sourceforge.net>
+
+ * win/tclWinFile.c: [Bug 3603434] Make sure TclpObjNormalizePath()
+ properly declares "a:/" to be normalized, even when no "A:" drive is
+ present on the system.
+
+2013-02-05 Donal K. Fellows <dkf@users.sf.net>
+
+ * generic/tclLoadNone.c (TclpLoadMemory): [Bug 3433012]: Added dummy
+ version of this function to use in the event that a platform thinks it
+ can load from memory but cannot actually do so due to it being
+ disabled at configuration time.
+
+2013-02-04 Donal K. Fellows <dkf@users.sf.net>
+
+ * generic/tclCompCmds.c (TclCompileArraySetCmd): [Bug 3603163]: Stop
+ crash in weird case where [eval] is used to make [array set] get
+ confused about whether there is a local variable table or not. Thanks
+ to Poor Yorick for identifying a reproducible crashing case.
+
+2013-01-30 Andreas Kupries <andreask@activestate.com>
+
+ * library/platform/platform.tcl (::platform::LibcVersion): See
+ * library/platform/pkgIndex.tcl: [Bug 3599098]: Fixed the RE
+ * unix/Makefile.in: extracting the version to avoid issues with
+ * win/Makefile.in: recent changes to the glibc banner. Now
+ targeting a less variable part of the string. Bumped package to
+ version 1.0.11.
+
+2013-01-28 Donal K. Fellows <dkf@users.sf.net>
+
+ * generic/tclCompCmds.c (TclCompileArraySetCmd)
+ (TclCompileArrayUnsetCmd, TclCompileDictAppendCmd)
+ (TclCompileDictCreateCmd, CompileDictEachCmd, TclCompileDictIncrCmd)
+ (TclCompileDictLappendCmd, TclCompileDictMergeCmd)
+ (TclCompileDictUnsetCmd, TclCompileDictUpdateCmd)
+ (TclCompileDictWithCmd, TclCompileInfoCommandsCmd):
+ * generic/tclCompCmdsSZ.c (TclCompileStringMatchCmd)
+ (TclCompileStringMapCmd): Improve the code generation in cases where
+ full compilation is impossible but a full ensemble invoke is provably
+ not necessary.
+
+2013-01-26 Jan Nijtmans <nijtmans@users.sf.net>
+
+ * unix/tclUnixCompat.c: [Bug 3601804]: platformCPUID segmentation
+ fault on Darwin.
+
+2013-01-23 Donal K. Fellows <dkf@users.sf.net>
+
+ * library/http/http.tcl (http::geturl): [Bug 2911139]: Do not do vwait
+ for connect to avoid reentrancy problems (except when operating
+ without a -command option). Internally, this means that all sockets
+ created by the http package will always be operated in asynchronous
+ mode.
+
+2013-01-21 Jan Nijtmans <nijtmans@users.sf.net>
+
+ * generic/tclInt.decls: Put back Tcl[GS]etStartupScript(Path|FileName)
+ in private stub table, so extensions using this (like Tk 8.4) will
+ continue to work in all Tcl 8.x versions. Extensions using this
+ still cannot be compiled against Tcl 8.6 headers.
+
+2013-01-18 Jan Nijtmans <nijtmans@users.sf.net>
+
+ * generic/tclPort.h: [Bug 3598300]: unix: tcl.h does not include
+ sys/stat.h
+
+2013-01-17 Donal K. Fellows <dkf@users.sf.net>
+
+ * generic/tclCompCmds.c (PushVarName): [Bug 3600328]: Added mechanism
+ for suppressing compilation of variables when we couldn't cope with
+ the results. Useful for some [array] subcommands.
+ * generic/tclEnsemble.c (CompileToCompiledCommand): Must restore the
+ compilation environment when a command compiler fails.
+
+2013-01-16 Donal K. Fellows <dkf@users.sf.net>
+
+ * generic/tclZlib.c (TclZlibInit): [Bug 3601086]: Register the config
+ info in the iso8859-1 encoding as that is guaranteed to be present.
+
+2013-01-16 Jan Nijtmans <nijtmans@users.sf.net>
+
+ * Makefile.in: Allow win32 build with -DTCL_NO_DEPRECATED, just as
+ * generic/tcl.h: in the UNIX build. Define Tcl_EvalObj and
+ * generic/tclDecls.h: Tcl_GlobalEvalObj as macros, even when
+ * generic/tclBasic.c: TCL_NO_DEPRECATED is defined, so Tk can benefit
+ from it too.
+
+2013-01-14 Jan Nijtmans <nijtmans@users.sf.net>
+
+ * win/tcl.m4: More flexible search for win32 tclConfig.sh, backported
+ from TEA (not actually used in Tcl, only for Tk)
+
+2013-01-14 Jan Nijtmans <nijtmans@users.sf.net>
+
+ * generic/tclInt.decls: Put back Tcl_[GS]etStartupScript in internal
+ stub table, so extensions using this, compiled against 8.5 headers
+ still run in Tcl 8.6.
+
2013-01-13 Alexandre Ferrieux <ferrieux@users.sourceforge.net>
- * doc/fileevent.n: Clarify readable fileevent "false positives" in
- the case of multibyte encodings/transforms [Bug 3436609].
+
+ * doc/fileevent.n: [Bug 3436609]: Clarify readable fileevent "false
+ positives" in the case of multibyte encodings/transforms.
2013-01-13 Jan Nijtmans <nijtmans@users.sf.net>
- * generic/tclIntDecls.h: If TCL_NO_DEPRECATED is defined, make
- sure that TIP #139 functions all are taken from the public stub
- table, even if the inclusion is through tclInt.h.
+ * generic/tclIntDecls.h: If TCL_NO_DEPRECATED is defined, make sure
+ that TIP #139 functions all are taken from the public stub table, even
+ if the inclusion is through tclInt.h.
2013-01-12 Jan Nijtmans <nijtmans@users.sf.net>
- * generic/tclInt.decls: Put back TclBackgroundException in
- internal stub table, so extensions using this, compiled
- against 8.5 headers still run in Tcl 8.6.
+ * generic/tclInt.decls: Put back TclBackgroundException in internal
+ stub table, so extensions using this, compiled against 8.5 headers
+ still run in Tcl 8.6.
2013-01-09 Jan Nijtmans <nijtmans@users.sf.net>
- * library/http/http.tcl: [Bug 3599395]: http assumes status line
- is a proper tcl list.
+ * library/http/http.tcl: [Bug 3599395]: http assumes status line is a
+ proper Tcl list.
2013-01-08 Jan Nijtmans <nijtmans@users.sf.net>
@@ -28,10 +152,10 @@
2013-01-07 Jan Nijtmans <nijtmans@users.sf.net>
* generic/tclOOStubLib.c: Restrict the stub library to only use
- * generic/tclTomMathStubLib.c: Tcl_PkgRequireEx, Tcl_ResetResult
- and Tcl_AppendResult, not any other function. This puts least
- restrictions on eventual Tcl 9 stubs re-organization, and it
- works on the widest range of Tcl versions.
+ * generic/tclTomMathStubLib.c: Tcl_PkgRequireEx, Tcl_ResetResult and
+ Tcl_AppendResult, not any other function. This puts least restrictions
+ on eventual Tcl 9 stubs re-organization, and it works on the widest
+ range of Tcl versions.
2013-01-06 Jan Nijtmans <nijtmans@users.sf.net>
@@ -4128,6 +4252,7 @@
* generic/*Decls.h: (regenerated)
2010-08-18 Miguel Sofer <msofer@users.sf.net>
+
* generic/tclBasic.c: New redesign of [tailcall]: find
* generic/tclExecute.c: errors early on, so that errorInfo
* generic/tclInt.h: contains the proper info [Bug 3047235]
diff --git a/doc/namespace.n b/doc/namespace.n
index b06d27a..f2812b2 100644
--- a/doc/namespace.n
+++ b/doc/namespace.n
@@ -287,7 +287,7 @@ This command is the complement of the \fBnamespace qualifiers\fR command.
It does not check whether the namespace names are, in fact,
the names of currently defined namespaces.
.TP
-\fBnamespace upvar\fR \fInamespace\fR ?\fIotherVar myVar \fR...
+\fBnamespace upvar\fR \fInamespace\fR ?\fIotherVar myVar \fR...?
.
This command arranges for zero or more local variables in the current
procedure to refer to variables in \fInamespace\fR. The namespace name is
diff --git a/doc/string.n b/doc/string.n
index f5eae39..351c865 100644
--- a/doc/string.n
+++ b/doc/string.n
@@ -19,7 +19,7 @@ string \- Manipulate strings
Performs one of several string operations, depending on \fIoption\fR.
The legal \fIoption\fRs (which may be abbreviated) are:
.TP
-\fBstring compare\fR ?\fB\-nocase\fR? ?\fB\-length int\fR? \fIstring1 string2\fR
+\fBstring compare\fR ?\fB\-nocase\fR? ?\fB\-length\fI length\fR? \fIstring1 string2\fR
.
Perform a character-by-character comparison of strings \fIstring1\fR
and \fIstring2\fR. Returns \-1, 0, or 1, depending on whether
@@ -29,7 +29,7 @@ first \fIlength\fR characters are used in the comparison. If
\fB\-length\fR is negative, it is ignored. If \fB\-nocase\fR is
specified, then the strings are compared in a case-insensitive manner.
.TP
-\fBstring equal\fR ?\fB\-nocase\fR? ?\fB\-length int\fR? \fIstring1 string2\fR
+\fBstring equal\fR ?\fB\-nocase\fR? ?\fB\-length\fI length\fR? \fIstring1 string2\fR
.
Perform a character-by-character comparison of strings \fIstring1\fR
and \fIstring2\fR. Returns 1 if \fIstring1\fR and \fIstring2\fR are
diff --git a/doc/try.n b/doc/try.n
index 393fe5b..78a006d 100644
--- a/doc/try.n
+++ b/doc/try.n
@@ -87,7 +87,7 @@ Handle different reasons for a file to not be openable for reading:
.PP
.CS
\fBtry\fR {
- set f [open /some/file/name]
+ set f [open /some/file/name w]
} \fBtrap\fR {POSIX EISDIR} {} {
puts "failed to open /some/file/name: it's a directory"
} \fBtrap\fR {POSIX ENOENT} {} {
diff --git a/generic/regc_nfa.c b/generic/regc_nfa.c
index 4fb3ea6..2c2397f 100644
--- a/generic/regc_nfa.c
+++ b/generic/regc_nfa.c
@@ -759,7 +759,9 @@ duptraverse(
* Arbitrary depth limit. Needs tuning, but this value is sufficient to
* make all normal tests (not reg-33.14) pass.
*/
-#define DUPTRAVERSE_MAX_DEPTH 500
+#ifndef DUPTRAVERSE_MAX_DEPTH
+#define DUPTRAVERSE_MAX_DEPTH 700
+#endif
if (depth++ > DUPTRAVERSE_MAX_DEPTH) {
NERR(REG_ESPACE);
diff --git a/generic/tcl.h b/generic/tcl.h
index 3003abf..2556a9a 100644
--- a/generic/tcl.h
+++ b/generic/tcl.h
@@ -472,7 +472,7 @@ typedef unsigned TCL_WIDE_INT_TYPE Tcl_WideUInt;
struct {long tv_sec;} st_ctim;
/* Here is a 4-byte gap */
} Tcl_StatBuf;
-#elif defined(HAVE_STRUCT_STAT64)
+#elif defined(HAVE_STRUCT_STAT64) && !defined(__APPLE__)
typedef struct stat64 Tcl_StatBuf;
#else
typedef struct stat Tcl_StatBuf;
@@ -2602,13 +2602,6 @@ EXTERN void Tcl_GetMemoryInfo(Tcl_DString *dsPtr);
*/
#ifndef TCL_NO_DEPRECATED
-# undef Tcl_EvalObj
-# define Tcl_EvalObj(interp,objPtr) \
- Tcl_EvalObjEx((interp),(objPtr),0)
-# undef Tcl_GlobalEvalObj
-# define Tcl_GlobalEvalObj(interp,objPtr) \
- Tcl_EvalObjEx((interp),(objPtr),TCL_EVAL_GLOBAL)
-
/*
* These function have been renamed. The old names are deprecated, but we
* define these macros for backwards compatibilty.
diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c
index 0674e87..6e62d4d 100644
--- a/generic/tclAssembly.c
+++ b/generic/tclAssembly.c
@@ -798,12 +798,10 @@ TclNRAssembleObjCmd(
if (codePtr == NULL) {
Tcl_AddErrorInfo(interp, "\n (\"");
- Tcl_AddErrorInfo(interp, Tcl_GetString(objv[0]));
+ Tcl_AppendObjToErrorInfo(interp, objv[0]);
Tcl_AddErrorInfo(interp, "\" body, line ");
backtrace = Tcl_NewIntObj(Tcl_GetErrorLine(interp));
- Tcl_IncrRefCount(backtrace);
- Tcl_AddErrorInfo(interp, Tcl_GetString(backtrace));
- Tcl_DecrRefCount(backtrace);
+ Tcl_AppendObjToErrorInfo(interp, backtrace);
Tcl_AddErrorInfo(interp, ")");
return TCL_ERROR;
}
@@ -860,7 +858,7 @@ CompileAssembleObj(
if (objPtr->typePtr == &assembleCodeType) {
namespacePtr = iPtr->varFramePtr->nsPtr;
- codePtr = objPtr->internalRep.otherValuePtr;
+ codePtr = objPtr->internalRep.twoPtrValue.ptr1;
if (((Interp *) *codePtr->interpHandle == iPtr)
&& (codePtr->compileEpoch == iPtr->compileEpoch)
&& (codePtr->nsPtr == namespacePtr)
@@ -945,7 +943,7 @@ CompileAssembleObj(
* Record the local variable context to which the bytecode pertains
*/
- codePtr = objPtr->internalRep.otherValuePtr;
+ codePtr = objPtr->internalRep.twoPtrValue.ptr1;
if (iPtr->varFramePtr->localCachePtr) {
codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr;
codePtr->localCachePtr->refCount++;
@@ -4263,11 +4261,11 @@ AddBasicBlockRangeToErrorInfo(
Tcl_AddErrorInfo(interp, "\n in assembly code between lines ");
lineNo = Tcl_NewIntObj(bbPtr->startLine);
Tcl_IncrRefCount(lineNo);
- Tcl_AddErrorInfo(interp, Tcl_GetString(lineNo));
+ Tcl_AppendObjToErrorInfo(interp, lineNo);
Tcl_AddErrorInfo(interp, " and ");
if (bbPtr->successor1 != NULL) {
Tcl_SetIntObj(lineNo, bbPtr->successor1->startLine);
- Tcl_AddErrorInfo(interp, Tcl_GetString(lineNo));
+ Tcl_AppendObjToErrorInfo(interp, lineNo);
} else {
Tcl_AddErrorInfo(interp, "end of assembly code");
}
@@ -4331,14 +4329,13 @@ static void
FreeAssembleCodeInternalRep(
Tcl_Obj *objPtr)
{
- ByteCode *codePtr = objPtr->internalRep.otherValuePtr;
+ ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1;
codePtr->refCount--;
if (codePtr->refCount <= 0) {
TclCleanupByteCode(codePtr);
}
objPtr->typePtr = NULL;
- objPtr->internalRep.otherValuePtr = NULL;
}
/*
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index f437bde..b32f5b1 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -4173,9 +4173,6 @@ TclNREvalObjv(
}
cmdPtrPtr = (Command **) &(callbackPtr->data[0]);
- callbackPtr->data[2] = INT2PTR(objc);
- callbackPtr->data[3] = (ClientData) objv;
-
iPtr->numLevels++;
result = TclInterpReady(interp);
@@ -5840,7 +5837,6 @@ Tcl_Eval(
*----------------------------------------------------------------------
*/
-#undef Tcl_EvalObj
int
Tcl_EvalObj(
Tcl_Interp *interp,
@@ -5848,7 +5844,6 @@ Tcl_EvalObj(
{
return Tcl_EvalObjEx(interp, objPtr, 0);
}
-#undef Tcl_GlobalEvalObj
int
Tcl_GlobalEvalObj(
Tcl_Interp *interp,
diff --git a/generic/tclBinary.c b/generic/tclBinary.c
index 455b5a6..3e9ab01 100644
--- a/generic/tclBinary.c
+++ b/generic/tclBinary.c
@@ -204,9 +204,10 @@ typedef struct ByteArray {
#define BYTEARRAY_SIZE(len) \
((unsigned) (TclOffset(ByteArray, bytes) + (len)))
#define GET_BYTEARRAY(objPtr) \
- ((ByteArray *) (objPtr)->internalRep.otherValuePtr)
+ ((ByteArray *) (objPtr)->internalRep.twoPtrValue.ptr1)
#define SET_BYTEARRAY(objPtr, baPtr) \
- (objPtr)->internalRep.otherValuePtr = (void *) (baPtr)
+ (objPtr)->internalRep.twoPtrValue.ptr1 = (VOID *) (baPtr)
+
/*
*----------------------------------------------------------------------
@@ -325,7 +326,7 @@ Tcl_SetByteArrayObj(
Tcl_Panic("%s called with shared object", "Tcl_SetByteArrayObj");
}
TclFreeIntRep(objPtr);
- Tcl_InvalidateStringRep(objPtr);
+ TclInvalidateStringRep(objPtr);
if (length < 0) {
length = 0;
@@ -420,7 +421,7 @@ Tcl_SetByteArrayLength(
byteArrayPtr->allocated = length;
SET_BYTEARRAY(objPtr, byteArrayPtr);
}
- Tcl_InvalidateStringRep(objPtr);
+ TclInvalidateStringRep(objPtr);
byteArrayPtr->used = length;
return byteArrayPtr->bytes;
}
@@ -691,7 +692,7 @@ TclAppendBytesToByteArray(
if (len > 0) {
memcpy(byteArrayPtr->bytes + byteArrayPtr->used, bytes, len);
byteArrayPtr->used += len;
- Tcl_InvalidateStringRep(objPtr);
+ TclInvalidateStringRep(objPtr);
}
}
diff --git a/generic/tclCkalloc.c b/generic/tclCkalloc.c
index 2973678..ce57cd5 100644
--- a/generic/tclCkalloc.c
+++ b/generic/tclCkalloc.c
@@ -156,6 +156,10 @@ TclInitDbCkalloc(void)
if (!ckallocInit) {
ckallocInit = 1;
ckallocMutexPtr = Tcl_GetAllocMutex();
+#ifndef TCL_THREADS
+ /* Silence compiler warning */
+ (void)ckallocMutexPtr;
+#endif
}
}
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index d5acc05..ae4113c 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -1540,7 +1540,8 @@ StringIsCmd(
case STR_IS_BOOL:
case STR_IS_TRUE:
case STR_IS_FALSE:
- if (TCL_OK != Tcl_ConvertToType(NULL, objPtr, &tclBooleanType)) {
+ if ((objPtr->typePtr != &tclBooleanType)
+ && (TCL_OK != TclSetBooleanFromAny(NULL, objPtr))) {
if (strict) {
result = 0;
} else {
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index b4e517f..c7cfb97 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -107,6 +107,7 @@ static int CompileDictEachCmd(Tcl_Interp *interp,
*/
#define TCL_NO_LARGE_INDEX 1 /* Do not return localIndex value > 255 */
+#define TCL_NO_ELEMENT 2 /* Do not push the array element. */
/*
* The structures below define the AuxData types defined in this file.
@@ -259,7 +260,7 @@ TclCompileArrayExistsCmd(
}
tokenPtr = TokenAfter(parsePtr->tokenPtr);
- PushVarNameWord(interp, tokenPtr, envPtr, 0,
+ PushVarNameWord(interp, tokenPtr, envPtr, TCL_NO_ELEMENT,
&localIndex, &simpleVarName, &isScalar, 1);
if (!isScalar) {
return TCL_ERROR;
@@ -283,7 +284,7 @@ TclCompileArraySetCmd(
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
- Tcl_Token *tokenPtr;
+ Tcl_Token *varTokenPtr, *dataTokenPtr;
int simpleVarName, isScalar, localIndex;
int dataVar, iterVar, keyVar, valVar, infoIndex;
int back, fwd, offsetBack, offsetFwd, savedStackDepth;
@@ -293,20 +294,21 @@ TclCompileArraySetCmd(
return TCL_ERROR;
}
- tokenPtr = TokenAfter(parsePtr->tokenPtr);
- PushVarNameWord(interp, tokenPtr, envPtr, 0,
+ varTokenPtr = TokenAfter(parsePtr->tokenPtr);
+ PushVarNameWord(interp, varTokenPtr, envPtr, TCL_NO_ELEMENT,
&localIndex, &simpleVarName, &isScalar, 1);
+ dataTokenPtr = TokenAfter(varTokenPtr);
if (!isScalar) {
return TCL_ERROR;
}
- tokenPtr = TokenAfter(tokenPtr);
/*
* Special case: literal empty value argument is just an "ensure array"
* operation.
*/
- if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD && tokenPtr[1].size == 0) {
+ if (dataTokenPtr->type == TCL_TOKEN_SIMPLE_WORD
+ && dataTokenPtr[1].size == 0) {
if (localIndex >= 0) {
TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex, envPtr);
TclEmitInstInt1(INST_JUMP_TRUE1, 7, envPtr);
@@ -329,14 +331,38 @@ TclCompileArraySetCmd(
* Prepare for the internal foreach.
*/
- if (envPtr->procPtr == NULL) {
- return TCL_ERROR;
- }
dataVar = TclFindCompiledLocal(NULL, 0, 1, envPtr);
iterVar = TclFindCompiledLocal(NULL, 0, 1, envPtr);
keyVar = TclFindCompiledLocal(NULL, 0, 1, envPtr);
valVar = TclFindCompiledLocal(NULL, 0, 1, envPtr);
+ if (dataVar < 0) {
+ /*
+ * Right number of arguments, but not compilable as we can't allocate
+ * (unnamed) local variables to manage the internal iteration.
+ */
+
+ Tcl_Obj *objPtr = Tcl_NewObj();
+ char *bytes;
+ int length, cmdLit;
+
+ Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr);
+ bytes = Tcl_GetStringFromObj(objPtr, &length);
+ cmdLit = TclRegisterNewCmdLiteral(envPtr, bytes, length);
+ TclSetCmdNameObj(interp, envPtr->literalArrayPtr[cmdLit].objPtr,
+ cmdPtr);
+ TclEmitPush(cmdLit, envPtr);
+ TclDecrRefCount(objPtr);
+ if (localIndex >= 0) {
+ CompileWord(envPtr, varTokenPtr, interp, 1);
+ } else {
+ TclEmitInstInt4(INST_REVERSE, 2, envPtr);
+ }
+ CompileWord(envPtr, dataTokenPtr, interp, 2);
+ TclEmitInstInt1(INST_INVOKE_STK1, 3, envPtr);
+ return TCL_OK;
+ }
+
infoPtr = ckalloc(sizeof(ForeachInfo) + sizeof(ForeachVarList *));
infoPtr->numLists = 1;
infoPtr->firstValueTemp = dataVar;
@@ -351,7 +377,7 @@ TclCompileArraySetCmd(
* Start issuing instructions to write to the array.
*/
- CompileWord(envPtr, tokenPtr, interp, 2);
+ CompileWord(envPtr, dataTokenPtr, interp, 2);
TclEmitOpcode( INST_DUP, envPtr);
TclEmitOpcode( INST_LIST_LENGTH, envPtr);
PushLiteral(envPtr, "1", 1);
@@ -434,10 +460,10 @@ TclCompileArrayUnsetCmd(
int simpleVarName, isScalar, localIndex, savedStackDepth;
if (parsePtr->numWords != 2) {
- return TCL_ERROR;
+ return TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
- PushVarNameWord(interp, tokenPtr, envPtr, 0,
+ PushVarNameWord(interp, tokenPtr, envPtr, TCL_NO_ELEMENT,
&localIndex, &simpleVarName, &isScalar, 1);
if (!isScalar) {
return TCL_ERROR;
@@ -928,7 +954,7 @@ TclCompileDictIncrCmd(
incrTokenPtr = TokenAfter(keyTokenPtr);
if (incrTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
- return TCL_ERROR;
+ return TclCompileBasic2Or3ArgCmd(interp, parsePtr,cmdPtr, envPtr);
}
word = incrTokenPtr[1].start;
numBytes = incrTokenPtr[1].size;
@@ -938,7 +964,7 @@ TclCompileDictIncrCmd(
code = TclGetIntFromObj(NULL, intObj, &incrAmount);
TclDecrRefCount(intObj);
if (code != TCL_OK) {
- return TCL_ERROR;
+ return TclCompileBasic2Or3ArgCmd(interp, parsePtr,cmdPtr, envPtr);
}
} else {
incrAmount = 1;
@@ -951,16 +977,16 @@ TclCompileDictIncrCmd(
*/
if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
- return TCL_ERROR;
+ return TclCompileBasic2Or3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
name = varTokenPtr[1].start;
nameChars = varTokenPtr[1].size;
if (!TclIsLocalScalar(name, nameChars)) {
- return TCL_ERROR;
+ return TclCompileBasic2Or3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, envPtr);
if (dictVarIndex < 0) {
- return TCL_ERROR;
+ return TclCompileBasic2Or3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
/*
@@ -1078,16 +1104,16 @@ TclCompileDictUnsetCmd(
tokenPtr = TokenAfter(parsePtr->tokenPtr);
if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
- return TCL_ERROR;
+ return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
name = tokenPtr[1].start;
nameChars = tokenPtr[1].size;
if (!TclIsLocalScalar(name, nameChars)) {
- return TCL_ERROR;
+ return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, envPtr);
if (dictVarIndex < 0) {
- return TCL_ERROR;
+ return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
/*
@@ -1178,7 +1204,7 @@ TclCompileDictCreateCmd(
nonConstant:
worker = TclFindCompiledLocal(NULL, 0, 1, envPtr);
if (worker < 0) {
- return TCL_ERROR;
+ return TclCompileBasicMin0ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
PushLiteral(envPtr, "", 0);
@@ -1239,7 +1265,7 @@ TclCompileDictMergeCmd(
workerIndex = TclFindCompiledLocal(NULL, 0, 1, envPtr);
if (workerIndex < 0) {
- return TCL_ERROR;
+ return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
infoIndex = TclFindCompiledLocal(NULL, 0, 1, envPtr);
@@ -1365,11 +1391,11 @@ CompileDictEachCmd(
Tcl_DString buffer;
/*
- * There must be at least three argument after the command.
+ * There must be three arguments after the command.
*/
if (parsePtr->numWords != 4) {
- return TCL_ERROR;
+ return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
varsTokenPtr = TokenAfter(parsePtr->tokenPtr);
@@ -1377,7 +1403,7 @@ CompileDictEachCmd(
bodyTokenPtr = TokenAfter(dictTokenPtr);
if (varsTokenPtr->type != TCL_TOKEN_SIMPLE_WORD ||
bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
- return TCL_ERROR;
+ return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
/*
@@ -1389,7 +1415,7 @@ CompileDictEachCmd(
collectVar = TclFindCompiledLocal(NULL, /*nameChars*/ 0, /*create*/ 1,
envPtr);
if (collectVar < 0) {
- return TCL_ERROR;
+ return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
}
@@ -1403,31 +1429,31 @@ CompileDictEachCmd(
if (Tcl_SplitList(NULL, Tcl_DStringValue(&buffer), &numVars,
&argv) != TCL_OK) {
Tcl_DStringFree(&buffer);
- return TCL_ERROR;
+ return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
Tcl_DStringFree(&buffer);
if (numVars != 2) {
ckfree(argv);
- return TCL_ERROR;
+ return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
nameChars = strlen(argv[0]);
if (!TclIsLocalScalar(argv[0], nameChars)) {
ckfree(argv);
- return TCL_ERROR;
+ return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
keyVarIndex = TclFindCompiledLocal(argv[0], nameChars, 1, envPtr);
nameChars = strlen(argv[1]);
if (!TclIsLocalScalar(argv[1], nameChars)) {
ckfree(argv);
- return TCL_ERROR;
+ return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
valueVarIndex = TclFindCompiledLocal(argv[1], nameChars, 1, envPtr);
ckfree(argv);
if ((keyVarIndex < 0) || (valueVarIndex < 0)) {
- return TCL_ERROR;
+ return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
/*
@@ -1439,7 +1465,7 @@ CompileDictEachCmd(
infoIndex = TclFindCompiledLocal(NULL, 0, 1, envPtr);
if (infoIndex < 0) {
- return TCL_ERROR;
+ return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
/*
@@ -1636,16 +1662,16 @@ TclCompileDictUpdateCmd(
dictVarTokenPtr = TokenAfter(parsePtr->tokenPtr);
if (dictVarTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
- return TCL_ERROR;
+ return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
name = dictVarTokenPtr[1].start;
nameChars = dictVarTokenPtr[1].size;
if (!TclIsLocalScalar(name, nameChars)) {
- return TCL_ERROR;
+ return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
dictIndex = TclFindCompiledLocal(name, nameChars, 1, envPtr);
if (dictIndex < 0) {
- return TCL_ERROR;
+ return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
/*
@@ -1695,7 +1721,7 @@ TclCompileDictUpdateCmd(
failedUpdateInfoAssembly:
ckfree(duiPtr);
ckfree(keyTokenPtrs);
- return TCL_ERROR;
+ return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
bodyTokenPtr = tokenPtr;
@@ -1793,17 +1819,17 @@ TclCompileDictAppendCmd(
tokenPtr = TokenAfter(parsePtr->tokenPtr);
if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
- return TCL_ERROR;
+ return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
} else {
register const char *name = tokenPtr[1].start;
register int nameChars = tokenPtr[1].size;
if (!TclIsLocalScalar(name, nameChars)) {
- return TCL_ERROR;
+ return TclCompileBasicMin2ArgCmd(interp, parsePtr,cmdPtr, envPtr);
}
dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, envPtr);
if (dictVarIndex < 0) {
- return TCL_ERROR;
+ return TclCompileBasicMin2ArgCmd(interp, parsePtr,cmdPtr, envPtr);
}
}
@@ -1854,16 +1880,16 @@ TclCompileDictLappendCmd(
keyTokenPtr = TokenAfter(varTokenPtr);
valueTokenPtr = TokenAfter(keyTokenPtr);
if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
- return TCL_ERROR;
+ return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
name = varTokenPtr[1].start;
nameChars = varTokenPtr[1].size;
if (!TclIsLocalScalar(name, nameChars)) {
- return TCL_ERROR;
+ return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
dictVarIndex = TclFindCompiledLocal(name, nameChars, 1, envPtr);
if (dictVarIndex < 0) {
- return TCL_ERROR;
+ return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
CompileWord(envPtr, keyTokenPtr, interp, 3);
CompileWord(envPtr, valueTokenPtr, interp, 4);
@@ -1907,7 +1933,7 @@ TclCompileDictWithCmd(
tokenPtr = TokenAfter(tokenPtr);
}
if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
- return TCL_ERROR;
+ return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
/*
@@ -1919,7 +1945,8 @@ TclCompileDictWithCmd(
for (ptr=tokenPtr[1].start,end=ptr+tokenPtr[1].size ; ptr!=end ; ptr++) {
if (*ptr!=' ' && *ptr!='\t' && *ptr!='\n' && *ptr!='\r') {
if (envPtr->procPtr == NULL) {
- return TCL_ERROR;
+ return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr,
+ envPtr);
}
bodyIsEmpty = 0;
break;
@@ -3745,7 +3772,9 @@ TclCompileInfoCommandsCmd(
* We require one compile-time known argument for the case we can compile.
*/
- if (parsePtr->numWords != 2) {
+ if (parsePtr->numWords == 1) {
+ return TclCompileBasic0ArgCmd(interp, parsePtr, cmdPtr, envPtr);
+ } else if (parsePtr->numWords != 2) {
return TCL_ERROR;
}
tokenPtr = TokenAfter(parsePtr->tokenPtr);
@@ -3782,7 +3811,7 @@ TclCompileInfoCommandsCmd(
notCompilable:
Tcl_DecrRefCount(objPtr);
- return TCL_ERROR;
+ return TclCompileBasic1ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
int
@@ -6004,7 +6033,7 @@ PushVarName(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Token *varTokenPtr, /* Points to a variable token. */
CompileEnv *envPtr, /* Holds resulting instructions. */
- int flags, /* TCL_NO_LARGE_INDEX. */
+ int flags, /* TCL_NO_LARGE_INDEX | TCL_NO_ELEMENT. */
int *localIndexPtr, /* Must not be NULL. */
int *simpleVarNamePtr, /* Must not be NULL. */
int *isScalarPtr, /* Must not be NULL. */
@@ -6185,10 +6214,11 @@ PushVarName(
}
/*
- * Compile the element script, if any.
+ * Compile the element script, if any, and only if not inhibited. [Bug
+ * 3600328]
*/
- if (elName != NULL) {
+ if (elName != NULL && !(flags & TCL_NO_ELEMENT)) {
if (elNameChars) {
envPtr->line = line;
envPtr->clNext = clNext;
diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c
index 5333fcf..5c1e6eb 100644
--- a/generic/tclCompCmdsSZ.c
+++ b/generic/tclCompCmdsSZ.c
@@ -448,7 +448,7 @@ TclCompileStringMatchCmd(
if (parsePtr->numWords == 4) {
if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
- return TCL_ERROR;
+ return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
str = tokenPtr[1].start;
length = tokenPtr[1].size;
@@ -457,7 +457,7 @@ TclCompileStringMatchCmd(
* Fail at run time, not in compilation.
*/
- return TCL_ERROR;
+ return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
nocase = 1;
tokenPtr = TokenAfter(tokenPtr);
@@ -578,13 +578,13 @@ TclCompileStringMapCmd(
Tcl_IncrRefCount(mapObj);
if (!TclWordKnownAtCompileTime(mapTokenPtr, mapObj)) {
Tcl_DecrRefCount(mapObj);
- return TCL_ERROR;
+ return TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
} else if (Tcl_ListObjGetElements(NULL, mapObj, &len, &objv) != TCL_OK) {
Tcl_DecrRefCount(mapObj);
- return TCL_ERROR;
+ return TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
} else if (len != 2) {
Tcl_DecrRefCount(mapObj);
- return TCL_ERROR;
+ return TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
/*
diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c
index ab5de1c..0938e3b 100644
--- a/generic/tclCompExpr.c
+++ b/generic/tclCompExpr.c
@@ -2207,7 +2207,7 @@ ExecConstantExprTree(
TclInitByteCodeObj(byteCodeObj, envPtr);
TclFreeCompileEnv(envPtr);
ckfree(envPtr);
- byteCodePtr = byteCodeObj->internalRep.otherValuePtr;
+ byteCodePtr = byteCodeObj->internalRep.twoPtrValue.ptr1;
TclNRExecuteByteCode(interp, byteCodePtr);
code = TclNRRunCallbacks(interp, TCL_OK, rootPtr);
Tcl_DecrRefCount(byteCodeObj);
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 30e7d34..e8f778a 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -789,8 +789,7 @@ SetByteCodeFromAny(
if (interp == NULL) {
return TCL_ERROR;
}
- TclSetByteCodeFromAny(interp, objPtr, NULL, NULL);
- return TCL_OK;
+ return TclSetByteCodeFromAny(interp, objPtr, NULL, NULL);
}
/*
@@ -844,10 +843,9 @@ static void
FreeByteCodeInternalRep(
register Tcl_Obj *objPtr) /* Object whose internal rep to free. */
{
- register ByteCode *codePtr = objPtr->internalRep.otherValuePtr;
+ register ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1;
objPtr->typePtr = NULL;
- objPtr->internalRep.otherValuePtr = NULL;
codePtr->refCount--;
if (codePtr->refCount <= 0) {
TclCleanupByteCode(codePtr);
@@ -867,9 +865,8 @@ FreeByteCodeInternalRep(
* None.
*
* Side effects:
- * Frees objPtr's bytecode internal representation and sets its type and
- * objPtr->internalRep.otherValuePtr NULL. Also releases its literals and
- * frees its auxiliary data items.
+ * Frees objPtr's bytecode internal representation and sets its type NULL
+ * Also releases its literals and frees its auxiliary data items.
*
*----------------------------------------------------------------------
*/
@@ -1144,7 +1141,7 @@ CompileSubstObj(
objPtr->typePtr = &substCodeType;
TclFreeCompileEnv(&compEnv);
- codePtr = objPtr->internalRep.otherValuePtr;
+ codePtr = objPtr->internalRep.twoPtrValue.ptr1;
objPtr->internalRep.ptrAndLongRep.ptr = codePtr;
objPtr->internalRep.ptrAndLongRep.value = flags;
if (iPtr->varFramePtr->localCachePtr) {
@@ -1183,7 +1180,6 @@ FreeSubstCodeInternalRep(
register ByteCode *codePtr = objPtr->internalRep.ptrAndLongRep.ptr;
objPtr->typePtr = NULL;
- objPtr->internalRep.otherValuePtr = NULL;
codePtr->refCount--;
if (codePtr->refCount <= 0) {
TclCleanupByteCode(codePtr);
@@ -2639,7 +2635,7 @@ TclInitByteCodeObj(
*/
TclFreeIntRep(objPtr);
- objPtr->internalRep.otherValuePtr = codePtr;
+ objPtr->internalRep.twoPtrValue.ptr1 = codePtr;
objPtr->typePtr = &tclByteCodeType;
/*
@@ -4058,7 +4054,7 @@ Tcl_Obj *
TclDisassembleByteCodeObj(
Tcl_Obj *objPtr) /* The bytecode object to disassemble. */
{
- ByteCode *codePtr = objPtr->internalRep.otherValuePtr;
+ ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1;
unsigned char *codeStart, *codeLimit, *pc;
unsigned char *codeDeltaNext, *codeLengthNext;
unsigned char *srcDeltaNext, *srcLengthNext;
diff --git a/generic/tclDecls.h b/generic/tclDecls.h
index 2801102..fe9ba2b 100644
--- a/generic/tclDecls.h
+++ b/generic/tclDecls.h
@@ -3803,4 +3803,16 @@ extern const TclStubs *tclStubsPtr;
#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS DLLIMPORT
+/*
+ * Deprecated Tcl procedures:
+ */
+#if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS)
+# undef Tcl_EvalObj
+# define Tcl_EvalObj(interp,objPtr) \
+ Tcl_EvalObjEx((interp),(objPtr),0)
+# undef Tcl_GlobalEvalObj
+# define Tcl_GlobalEvalObj(interp,objPtr) \
+ Tcl_EvalObjEx((interp),(objPtr),TCL_EVAL_GLOBAL)
+#endif
+
#endif /* _TCLDECLS */
diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c
index 3c3e0b1..891f07a 100644
--- a/generic/tclDictObj.c
+++ b/generic/tclDictObj.c
@@ -361,7 +361,7 @@ DupDictInternalRep(
Tcl_Obj *srcPtr,
Tcl_Obj *copyPtr)
{
- Dict *oldDict = srcPtr->internalRep.otherValuePtr;
+ Dict *oldDict = srcPtr->internalRep.twoPtrValue.ptr1;
Dict *newDict = ckalloc(sizeof(Dict));
ChainEntry *cPtr;
@@ -396,7 +396,7 @@ DupDictInternalRep(
* Store in the object.
*/
- copyPtr->internalRep.otherValuePtr = newDict;
+ copyPtr->internalRep.twoPtrValue.ptr1 = newDict;
copyPtr->typePtr = &tclDictType;
}
@@ -422,14 +422,12 @@ static void
FreeDictInternalRep(
Tcl_Obj *dictPtr)
{
- Dict *dict = dictPtr->internalRep.otherValuePtr;
+ Dict *dict = dictPtr->internalRep.twoPtrValue.ptr1;
dict->refcount--;
if (dict->refcount <= 0) {
DeleteDict(dict);
}
-
- dictPtr->internalRep.otherValuePtr = NULL; /* Belt and braces! */
dictPtr->typePtr = NULL;
}
@@ -489,7 +487,7 @@ UpdateStringOfDict(
{
#define LOCAL_SIZE 20
int localFlags[LOCAL_SIZE], *flagPtr = NULL;
- Dict *dict = dictPtr->internalRep.otherValuePtr;
+ Dict *dict = dictPtr->internalRep.twoPtrValue.ptr1;
ChainEntry *cPtr;
Tcl_Obj *keyPtr, *valuePtr;
int i, length, bytesNeeded = 0;
@@ -715,7 +713,7 @@ SetDictFromAny(
dict->epoch = 0;
dict->chain = NULL;
dict->refcount = 1;
- objPtr->internalRep.otherValuePtr = dict;
+ objPtr->internalRep.twoPtrValue.ptr1 = dict;
objPtr->typePtr = &tclDictType;
return TCL_OK;
@@ -784,7 +782,7 @@ TclTraceDictPath(
return NULL;
}
}
- dict = dictPtr->internalRep.otherValuePtr;
+ dict = dictPtr->internalRep.twoPtrValue.ptr1;
if (flags & DICT_PATH_UPDATE) {
dict->chain = NULL;
}
@@ -827,7 +825,7 @@ TclTraceDictPath(
}
}
- newDict = tmpObj->internalRep.otherValuePtr;
+ newDict = tmpObj->internalRep.twoPtrValue.ptr1;
if (flags & DICT_PATH_UPDATE) {
if (Tcl_IsShared(tmpObj)) {
TclDecrRefCount(tmpObj);
@@ -835,7 +833,7 @@ TclTraceDictPath(
Tcl_IncrRefCount(tmpObj);
Tcl_SetHashValue(hPtr, tmpObj);
dict->epoch++;
- newDict = tmpObj->internalRep.otherValuePtr;
+ newDict = tmpObj->internalRep.twoPtrValue.ptr1;
}
newDict->chain = dictPtr;
@@ -870,17 +868,17 @@ static void
InvalidateDictChain(
Tcl_Obj *dictObj)
{
- Dict *dict = dictObj->internalRep.otherValuePtr;
+ Dict *dict = dictObj->internalRep.twoPtrValue.ptr1;
do {
- Tcl_InvalidateStringRep(dictObj);
+ TclInvalidateStringRep(dictObj);
dict->epoch++;
dictObj = dict->chain;
if (dictObj == NULL) {
break;
}
dict->chain = NULL;
- dict = dictObj->internalRep.otherValuePtr;
+ dict = dictObj->internalRep.twoPtrValue.ptr1;
} while (dict != NULL);
}
@@ -927,9 +925,9 @@ Tcl_DictObjPut(
}
if (dictPtr->bytes != NULL) {
- Tcl_InvalidateStringRep(dictPtr);
+ TclInvalidateStringRep(dictPtr);
}
- dict = dictPtr->internalRep.otherValuePtr;
+ dict = dictPtr->internalRep.twoPtrValue.ptr1;
hPtr = CreateChainEntry(dict, keyPtr, &isNew);
Tcl_IncrRefCount(valuePtr);
if (!isNew) {
@@ -980,7 +978,7 @@ Tcl_DictObjGet(
}
}
- dict = dictPtr->internalRep.otherValuePtr;
+ dict = dictPtr->internalRep.twoPtrValue.ptr1;
hPtr = Tcl_FindHashEntry(&dict->table, keyPtr);
if (hPtr == NULL) {
*valuePtrPtr = NULL;
@@ -1029,9 +1027,9 @@ Tcl_DictObjRemove(
}
if (dictPtr->bytes != NULL) {
- Tcl_InvalidateStringRep(dictPtr);
+ TclInvalidateStringRep(dictPtr);
}
- dict = dictPtr->internalRep.otherValuePtr;
+ dict = dictPtr->internalRep.twoPtrValue.ptr1;
if (DeleteChainEntry(dict, keyPtr)) {
dict->epoch++;
}
@@ -1071,7 +1069,7 @@ Tcl_DictObjSize(
}
}
- dict = dictPtr->internalRep.otherValuePtr;
+ dict = dictPtr->internalRep.twoPtrValue.ptr1;
*sizePtr = dict->table.numEntries;
return TCL_OK;
}
@@ -1126,7 +1124,7 @@ Tcl_DictObjFirst(
}
}
- dict = dictPtr->internalRep.otherValuePtr;
+ dict = dictPtr->internalRep.twoPtrValue.ptr1;
cPtr = dict->entryChainHead;
if (cPtr == NULL) {
searchPtr->epoch = -1;
@@ -1301,7 +1299,7 @@ Tcl_DictObjPutKeyList(
return TCL_ERROR;
}
- dict = dictPtr->internalRep.otherValuePtr;
+ dict = dictPtr->internalRep.twoPtrValue.ptr1;
hPtr = CreateChainEntry(dict, keyv[keyc-1], &isNew);
Tcl_IncrRefCount(valuePtr);
if (!isNew) {
@@ -1357,7 +1355,7 @@ Tcl_DictObjRemoveKeyList(
return TCL_ERROR;
}
- dict = dictPtr->internalRep.otherValuePtr;
+ dict = dictPtr->internalRep.twoPtrValue.ptr1;
DeleteChainEntry(dict, keyv[keyc-1]);
InvalidateDictChain(dictPtr);
return TCL_OK;
@@ -1397,13 +1395,13 @@ Tcl_NewDictObj(void)
Dict *dict;
TclNewObj(dictPtr);
- Tcl_InvalidateStringRep(dictPtr);
+ TclInvalidateStringRep(dictPtr);
dict = ckalloc(sizeof(Dict));
InitChainTable(dict);
dict->epoch = 0;
dict->chain = NULL;
dict->refcount = 1;
- dictPtr->internalRep.otherValuePtr = dict;
+ dictPtr->internalRep.twoPtrValue.ptr1 = dict;
dictPtr->typePtr = &tclDictType;
return dictPtr;
#endif
@@ -1446,13 +1444,13 @@ Tcl_DbNewDictObj(
Dict *dict;
TclDbNewObj(dictPtr, file, line);
- Tcl_InvalidateStringRep(dictPtr);
+ TclInvalidateStringRep(dictPtr);
dict = ckalloc(sizeof(Dict));
InitChainTable(dict);
dict->epoch = 0;
dict->chain = NULL;
dict->refcount = 1;
- dictPtr->internalRep.otherValuePtr = dict;
+ dictPtr->internalRep.twoPtrValue.ptr1 = dict;
dictPtr->typePtr = &tclDictType;
return dictPtr;
#else /* !TCL_MEM_DEBUG */
@@ -2064,7 +2062,7 @@ DictInfoCmd(
return result;
}
}
- dict = dictPtr->internalRep.otherValuePtr;
+ dict = dictPtr->internalRep.twoPtrValue.ptr1;
statsStr = Tcl_HashStats(&dict->table);
Tcl_SetObjResult(interp, Tcl_NewStringObj(statsStr, -1));
@@ -2179,7 +2177,7 @@ DictIncrCmd(
}
}
if (code == TCL_OK) {
- Tcl_InvalidateStringRep(dictPtr);
+ TclInvalidateStringRep(dictPtr);
valuePtr = Tcl_ObjSetVar2(interp, objv[1], NULL,
dictPtr, TCL_LEAVE_ERR_MSG);
if (valuePtr == NULL) {
@@ -2268,7 +2266,7 @@ DictLappendCmd(
if (allocatedValue) {
Tcl_DictObjPut(interp, dictPtr, objv[2], valuePtr);
} else if (dictPtr->bytes != NULL) {
- Tcl_InvalidateStringRep(dictPtr);
+ TclInvalidateStringRep(dictPtr);
}
resultPtr = Tcl_ObjSetVar2(interp, objv[1], NULL, dictPtr,
diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c
index 7a55724..2cc55d6 100644
--- a/generic/tclEncoding.c
+++ b/generic/tclEncoding.c
@@ -270,7 +270,7 @@ static int Iso88591ToUtfProc(ClientData clientData,
int *dstCharsPtr);
/*
- * A Tcl_ObjType for holding a cached Tcl_Encoding in the otherValuePtr field
+ * A Tcl_ObjType for holding a cached Tcl_Encoding in the twoPtrValue.ptr1 field
* of the intrep. This should help the lifetime of encodings be more useful.
* See concerns raised in [Bug 1077262].
*/
@@ -313,7 +313,7 @@ Tcl_GetEncodingFromObj(
return TCL_ERROR;
}
TclFreeIntRep(objPtr);
- objPtr->internalRep.otherValuePtr = encoding;
+ objPtr->internalRep.twoPtrValue.ptr1 = encoding;
objPtr->typePtr = &encodingType;
}
*encodingPtr = Tcl_GetEncoding(NULL, name);
@@ -334,7 +334,7 @@ static void
FreeEncodingIntRep(
Tcl_Obj *objPtr)
{
- Tcl_FreeEncoding(objPtr->internalRep.otherValuePtr);
+ Tcl_FreeEncoding(objPtr->internalRep.twoPtrValue.ptr1);
objPtr->typePtr = NULL;
}
@@ -353,7 +353,7 @@ DupEncodingIntRep(
Tcl_Obj *srcPtr,
Tcl_Obj *dupPtr)
{
- dupPtr->internalRep.otherValuePtr = Tcl_GetEncoding(NULL, srcPtr->bytes);
+ dupPtr->internalRep.twoPtrValue.ptr1 = Tcl_GetEncoding(NULL, srcPtr->bytes);
}
/*
diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c
index 058590a..bf9dac2 100644
--- a/generic/tclEnsemble.c
+++ b/generic/tclEnsemble.c
@@ -1718,7 +1718,7 @@ NsEnsembleImplementationCmdNR(
if (objv[1+ensemblePtr->numParameters]->typePtr==&tclEnsembleCmdType){
EnsembleCmdRep *ensembleCmd = objv[1+ensemblePtr->numParameters]
- ->internalRep.otherValuePtr;
+ ->internalRep.twoPtrValue.ptr1;
if (ensembleCmd->nsPtr == ensemblePtr->nsPtr &&
ensembleCmd->epoch == ensemblePtr->epoch &&
@@ -2196,7 +2196,7 @@ EnsembleUnknownCallback(
}
Tcl_AddErrorInfo(interp, "\n result of "
"ensemble unknown subcommand handler: ");
- Tcl_AddErrorInfo(interp, TclGetString(unknownCmd));
+ Tcl_AppendObjToErrorInfo(interp, unknownCmd);
Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "UNKNOWN_RESULT",
NULL);
} else {
@@ -2238,7 +2238,7 @@ MakeCachedEnsembleCommand(
int length;
if (objPtr->typePtr == &tclEnsembleCmdType) {
- ensembleCmd = objPtr->internalRep.otherValuePtr;
+ ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1;
Tcl_DecrRefCount(ensembleCmd->realPrefixObj);
TclNsDecrRefCount(ensembleCmd->nsPtr);
ckfree(ensembleCmd->fullSubcmdName);
@@ -2250,7 +2250,7 @@ MakeCachedEnsembleCommand(
TclFreeIntRep(objPtr);
ensembleCmd = ckalloc(sizeof(EnsembleCmdRep));
- objPtr->internalRep.otherValuePtr = ensembleCmd;
+ objPtr->internalRep.twoPtrValue.ptr1 = ensembleCmd;
objPtr->typePtr = &tclEnsembleCmdType;
}
@@ -2645,7 +2645,7 @@ static void
FreeEnsembleCmdRep(
Tcl_Obj *objPtr)
{
- EnsembleCmdRep *ensembleCmd = objPtr->internalRep.otherValuePtr;
+ EnsembleCmdRep *ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1;
Tcl_DecrRefCount(ensembleCmd->realPrefixObj);
ckfree(ensembleCmd->fullSubcmdName);
@@ -2677,12 +2677,12 @@ DupEnsembleCmdRep(
Tcl_Obj *objPtr,
Tcl_Obj *copyPtr)
{
- EnsembleCmdRep *ensembleCmd = objPtr->internalRep.otherValuePtr;
+ EnsembleCmdRep *ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1;
EnsembleCmdRep *ensembleCopy = ckalloc(sizeof(EnsembleCmdRep));
int length = strlen(ensembleCmd->fullSubcmdName);
copyPtr->typePtr = &tclEnsembleCmdType;
- copyPtr->internalRep.otherValuePtr = ensembleCopy;
+ copyPtr->internalRep.twoPtrValue.ptr1 = ensembleCopy;
ensembleCopy->nsPtr = ensembleCmd->nsPtr;
ensembleCopy->epoch = ensembleCmd->epoch;
ensembleCopy->token = ensembleCmd->token;
@@ -2715,7 +2715,7 @@ static void
StringOfEnsembleCmdRep(
Tcl_Obj *objPtr)
{
- EnsembleCmdRep *ensembleCmd = objPtr->internalRep.otherValuePtr;
+ EnsembleCmdRep *ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1;
int length = strlen(ensembleCmd->fullSubcmdName);
objPtr->length = length;
@@ -3056,6 +3056,9 @@ CompileToCompiledCommand(
Tcl_Parse synthetic;
Tcl_Token *tokenPtr;
int result, i;
+ int savedNumCmds = envPtr->numCommands;
+ int savedStackDepth = envPtr->currStackDepth;
+ unsigned savedCodeNext = envPtr->codeNext - envPtr->codeStart;
if (cmdPtr->compileProc == NULL) {
return TCL_ERROR;
@@ -3110,6 +3113,17 @@ CompileToCompiledCommand(
result = cmdPtr->compileProc(interp, &synthetic, cmdPtr, envPtr);
/*
+ * If our target fails to compile, revert the number of commands and the
+ * pointer to the place to issue the next instruction. [Bug 3600328]
+ */
+
+ if (result != TCL_OK) {
+ envPtr->numCommands = savedNumCmds;
+ envPtr->currStackDepth = savedStackDepth;
+ envPtr->codeNext = envPtr->codeStart + savedCodeNext;
+ }
+
+ /*
* Clean up if necessary.
*/
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 0b72eb7..2004f4c 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -261,8 +261,11 @@ VarHashCreateVar(
#if TCL_COMPILE_DEBUG
#define CHECK_STACK() \
- ValidatePcAndStackTop(codePtr, pc, CURR_DEPTH, \
- /*checkStack*/ auxObjList == NULL)
+ do { \
+ ValidatePcAndStackTop(codePtr, pc, CURR_DEPTH, \
+ /*checkStack*/ !(starting || auxObjList)); \
+ starting = 0; \
+ } while (0)
#else
#define CHECK_STACK()
#endif
@@ -1090,7 +1093,7 @@ CompileExprObj(
if (objPtr->typePtr == &exprCodeType) {
Namespace *namespacePtr = iPtr->varFramePtr->nsPtr;
- codePtr = objPtr->internalRep.otherValuePtr;
+ codePtr = objPtr->internalRep.twoPtrValue.ptr1;
if (((Interp *) *codePtr->interpHandle != iPtr)
|| (codePtr->compileEpoch != iPtr->compileEpoch)
|| (codePtr->nsPtr != namespacePtr)
@@ -1130,7 +1133,7 @@ CompileExprObj(
TclInitByteCodeObj(objPtr, &compEnv);
objPtr->typePtr = &exprCodeType;
TclFreeCompileEnv(&compEnv);
- codePtr = objPtr->internalRep.otherValuePtr;
+ codePtr = objPtr->internalRep.twoPtrValue.ptr1;
if (iPtr->varFramePtr->localCachePtr) {
codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr;
codePtr->localCachePtr->refCount++;
@@ -1202,10 +1205,9 @@ static void
FreeExprCodeInternalRep(
Tcl_Obj *objPtr)
{
- ByteCode *codePtr = objPtr->internalRep.otherValuePtr;
+ ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1;
objPtr->typePtr = NULL;
- objPtr->internalRep.otherValuePtr = NULL;
codePtr->refCount--;
if (codePtr->refCount <= 0) {
TclCleanupByteCode(codePtr);
@@ -1263,7 +1265,7 @@ TclCompileObj(
* here.
*/
- codePtr = objPtr->internalRep.otherValuePtr;
+ codePtr = objPtr->internalRep.twoPtrValue.ptr1;
if (((Interp *) *codePtr->interpHandle != iPtr)
|| (codePtr->compileEpoch != iPtr->compileEpoch)
|| (codePtr->nsPtr != namespacePtr)
@@ -1391,7 +1393,7 @@ TclCompileObj(
iPtr->invokeWord = word;
TclSetByteCodeFromAny(interp, objPtr, NULL, NULL);
iPtr->invokeCmdFramePtr = NULL;
- codePtr = objPtr->internalRep.otherValuePtr;
+ codePtr = objPtr->internalRep.twoPtrValue.ptr1;
if (iPtr->varFramePtr->localCachePtr) {
codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr;
codePtr->localCachePtr->refCount++;
@@ -1694,7 +1696,8 @@ TEBCresume(
Tcl_Obj **tosPtr; /* Cached pointer to top of evaluation
* stack. */
const unsigned char *pc; /* The current program counter. */
-
+ unsigned char inst; /* The currently running instruction */
+
/*
* Transfer variables - needed only between opcodes, but not while
* executing an instruction.
@@ -1719,6 +1722,7 @@ TEBCresume(
#endif
#ifdef TCL_COMPILE_DEBUG
+ int starting = 1;
traceInstructions = (tclTraceExec == 3);
#endif
@@ -1860,23 +1864,6 @@ TEBCresume(
}
cleanup0:
-#ifdef TCL_COMPILE_DEBUG
- /*
- * Skip the stack depth check if an expansion is in progress.
- */
-
- CHECK_STACK();
- if (traceInstructions) {
- fprintf(stdout, "%2d: %2d ", iPtr->numLevels, (int) CURR_DEPTH);
- TclPrintInstruction(codePtr, pc);
- fflush(stdout);
- }
-#endif /* TCL_COMPILE_DEBUG */
-
-#ifdef TCL_COMPILE_STATS
- iPtr->stats.instructionCount[*pc]++;
-#endif
-
/*
* Check for asynchronous handlers [Bug 746722]; we do the check every
* ASYNC_CHECK_COUNT_MASK instruction, of the form (2**n-1).
@@ -1907,8 +1894,6 @@ TEBCresume(
checkInterp = 1;
}
- TCL_DTRACE_INST_NEXT();
-
/*
* These two instructions account for 26% of all instructions (according
* to measurements on tclbench by Ben Vitale
@@ -1918,13 +1903,53 @@ TEBCresume(
* reduces total obj size.
*/
- if (*pc == INST_LOAD_SCALAR1) {
- goto instLoadScalar1;
- } else if (*pc == INST_PUSH1) {
- goto instPush1Peephole;
+ inst = *pc;
+
+ peepholeStart:
+#ifdef TCL_COMPILE_STATS
+ iPtr->stats.instructionCount[*pc]++;
+#endif
+
+#ifdef TCL_COMPILE_DEBUG
+ /*
+ * Skip the stack depth check if an expansion is in progress.
+ */
+
+ CHECK_STACK();
+ if (traceInstructions) {
+ fprintf(stdout, "%2d: %2d ", iPtr->numLevels, (int) CURR_DEPTH);
+ TclPrintInstruction(codePtr, pc);
+ fflush(stdout);
}
+#endif /* TCL_COMPILE_DEBUG */
- switch (*pc) {
+ TCL_DTRACE_INST_NEXT();
+
+ if (inst == INST_LOAD_SCALAR1) {
+ goto instLoadScalar1;
+ } else if (inst == INST_PUSH1) {
+ PUSH_OBJECT(codePtr->objArrayPtr[TclGetUInt1AtPtr(pc+1)]);
+ TRACE_WITH_OBJ(("%u => ", TclGetInt1AtPtr(pc+1)), OBJ_AT_TOS);
+ inst = *(pc += 2);
+ goto peepholeStart;
+ } else if (inst == INST_START_CMD) {
+ /*
+ * Peephole: do not run INST_START_CMD, just skip it
+ */
+
+ iPtr->cmdCount += TclGetUInt4AtPtr(pc+5);
+ if (checkInterp) {
+ checkInterp = 0;
+ if ((codePtr->compileEpoch != iPtr->compileEpoch)
+ || (codePtr->nsEpoch != iPtr->varFramePtr->nsPtr->resolverEpoch)) {
+ goto instStartCmdFailed;
+ }
+ }
+ inst = *(pc += 9);
+ goto peepholeStart;
+ }
+
+ switch (inst) {
case INST_SYNTAX:
case INST_RETURN_IMM: {
int code = TclGetInt4AtPtr(pc+1);
@@ -2074,23 +2099,6 @@ TEBCresume(
(void) POP_OBJECT();
goto abnormalReturn;
- case INST_PUSH1:
- instPush1Peephole:
- PUSH_OBJECT(codePtr->objArrayPtr[TclGetUInt1AtPtr(pc+1)]);
- TRACE_WITH_OBJ(("%u => ", TclGetInt1AtPtr(pc+1)), OBJ_AT_TOS);
- pc += 2;
-#if !TCL_COMPILE_DEBUG
- /*
- * Runtime peephole optimisation: check if we are pushing again.
- */
-
- if (*pc == INST_PUSH1) {
- TCL_DTRACE_INST_NEXT();
- goto instPush1Peephole;
- }
-#endif
- NEXT_INST_F(0, 0, 0);
-
case INST_PUSH4:
objResultPtr = codePtr->objArrayPtr[TclGetUInt4AtPtr(pc+1)];
TRACE_WITH_OBJ(("%u => ", TclGetUInt4AtPtr(pc+1)), objResultPtr);
@@ -2100,68 +2108,10 @@ TEBCresume(
TRACE_WITH_OBJ(("=> discarding "), OBJ_AT_TOS);
objPtr = POP_OBJECT();
TclDecrRefCount(objPtr);
-
- /*
- * Runtime peephole optimisation: an INST_POP is scheduled at the end
- * of most commands. If the next instruction is an INST_START_CMD,
- * fall through to it.
- */
-
- pc++;
-#if !TCL_COMPILE_DEBUG
- if (*pc == INST_START_CMD) {
- TCL_DTRACE_INST_NEXT();
- goto instStartCmdPeephole;
- }
-#endif
- NEXT_INST_F(0, 0, 0);
-
- case INST_START_CMD:
-#if !TCL_COMPILE_DEBUG
- instStartCmdPeephole:
-#endif
- /*
- * Remark that if the interpreter is marked for deletion its
- * compileEpoch is modified, so that the epoch check also verifies
- * that the interp is not deleted. If no outside call has been made
- * since the last check, it is safe to omit the check.
- */
-
- iPtr->cmdCount += TclGetUInt4AtPtr(pc+5);
- if (!checkInterp) {
- goto instStartCmdOK;
- } else if (((codePtr->compileEpoch == iPtr->compileEpoch)
- && (codePtr->nsEpoch == iPtr->varFramePtr->nsPtr->resolverEpoch))
- || (codePtr->flags & TCL_BYTECODE_PRECOMPILED)) {
- checkInterp = 0;
- instStartCmdOK:
- NEXT_INST_F(9, 0, 0);
- } else {
- const char *bytes;
-
- length = 0;
-
- /*
- * We used to switch to direct eval; for NRE-awareness we now
- * compile and eval the command so that this evaluation does not
- * add a new TEBC instance. [Bug 2910748]
- */
-
- if (TclInterpReady(interp) == TCL_ERROR) {
- goto gotError;
- }
-
- codePtr->flags |= TCL_BYTECODE_RECOMPILE;
- bytes = GetSrcInfoForPc(pc, codePtr, &length, NULL);
- opnd = TclGetUInt4AtPtr(pc+1);
- pc += (opnd-1);
- PUSH_OBJECT(Tcl_NewStringObj(bytes, length));
- goto instEvalStk;
- }
+ NEXT_INST_F(1, 0, 0);
case INST_NOP:
- pc += 1;
- goto cleanup0;
+ NEXT_INST_F(1, 0, 0);
case INST_DUP:
objResultPtr = OBJ_AT_TOS;
@@ -3116,8 +3066,8 @@ TEBCresume(
varPtr = TclObjLookupVarEx(interp, objPtr, part2Ptr,
TCL_LEAVE_ERR_MSG, "read", 1, 1, &arrayPtr);
if (!varPtr) {
- Tcl_AddObjErrorInfo(interp,
- "\n (reading value of variable to increment)", -1);
+ Tcl_AddErrorInfo(interp,
+ "\n (reading value of variable to increment)");
TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
Tcl_DecrRefCount(incrPtr);
goto gotError;
@@ -6657,6 +6607,42 @@ TEBCresume(
ckfree(TD); /* free my stack */
return result;
+
+ /*
+ * INST_START_CMD failure case removed where it doesn't bother that much
+ *
+ * Remark that if the interpreter is marked for deletion its
+ * compileEpoch is modified, so that the epoch check also verifies
+ * that the interp is not deleted. If no outside call has been made
+ * since the last check, it is safe to omit the check.
+
+ * case INST_START_CMD:
+ */
+
+ instStartCmdFailed:
+ {
+ const char *bytes;
+
+ checkInterp = 1;
+ length = 0;
+
+ /*
+ * We used to switch to direct eval; for NRE-awareness we now
+ * compile and eval the command so that this evaluation does not
+ * add a new TEBC instance. [Bug 2910748]
+ */
+
+ if (TclInterpReady(interp) == TCL_ERROR) {
+ goto gotError;
+ }
+
+ codePtr->flags |= TCL_BYTECODE_RECOMPILE;
+ bytes = GetSrcInfoForPc(pc, codePtr, &length, NULL);
+ opnd = TclGetUInt4AtPtr(pc+1);
+ pc += (opnd-1);
+ PUSH_OBJECT(Tcl_NewStringObj(bytes, length));
+ goto instEvalStk;
+ }
}
#undef codePtr
diff --git a/generic/tclGet.c b/generic/tclGet.c
index 4c19b55..97e8c7b 100644
--- a/generic/tclGet.c
+++ b/generic/tclGet.c
@@ -137,7 +137,7 @@ Tcl_GetBoolean(
obj.length = strlen(src);
obj.typePtr = NULL;
- code = Tcl_ConvertToType(interp, &obj, &tclBooleanType);
+ code = TclSetBooleanFromAny(interp, &obj);
if (obj.refCount > 1) {
Tcl_Panic("invalid sharing of Tcl_Obj on C stack");
}
diff --git a/generic/tclIO.c b/generic/tclIO.c
index 715c1ef..f340d59 100644
--- a/generic/tclIO.c
+++ b/generic/tclIO.c
@@ -221,9 +221,9 @@ static const Tcl_ObjType tclChannelType = {
};
#define GET_CHANNELSTATE(objPtr) \
- ((ChannelState *) (objPtr)->internalRep.otherValuePtr)
+ ((ChannelState *) (objPtr)->internalRep.twoPtrValue.ptr1)
#define SET_CHANNELSTATE(objPtr, storePtr) \
- ((objPtr)->internalRep.otherValuePtr = (void *) (storePtr))
+ ((objPtr)->internalRep.twoPtrValue.ptr1 = (void *) (storePtr))
#define GET_CHANNELINTERP(objPtr) \
((Interp *) (objPtr)->internalRep.twoPtrValue.ptr2)
#define SET_CHANNELINTERP(objPtr, storePtr) \
diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c
index ab08353..25ed57c 100644
--- a/generic/tclIOUtil.c
+++ b/generic/tclIOUtil.c
@@ -18,9 +18,6 @@
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
-#if defined(HAVE_SYS_STAT_H) && !defined _WIN32
-# include <sys/stat.h>
-#endif
#include "tclInt.h"
#ifdef __WIN32__
# include "tclWinInt.h"
diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c
index a023401..057246b 100644
--- a/generic/tclIndexObj.c
+++ b/generic/tclIndexObj.c
@@ -53,7 +53,7 @@ static const Tcl_ObjType indexType = {
/*
* The definition of the internal representation of the "index" object; The
- * internalRep.otherValuePtr field of an object of "index" type will be a
+ * internalRep.twoPtrValue.ptr1 field of an object of "index" type will be a
* pointer to one of these structures.
*
* Keep this structure declaration in sync with tclTestObj.c
@@ -69,12 +69,12 @@ typedef struct {
* The following macros greatly simplify moving through a table...
*/
-#define STRING_AT(table, offset, index) \
- (*((const char *const *)(((char *)(table)) + ((offset) * (index)))))
+#define STRING_AT(table, offset) \
+ (*((const char *const *)(((char *)(table)) + (offset))))
#define NEXT_ENTRY(table, offset) \
- (&(STRING_AT(table, offset, 1)))
+ (&(STRING_AT(table, offset)))
#define EXPAND_OF(indexRep) \
- STRING_AT((indexRep)->tablePtr, (indexRep)->offset, (indexRep)->index)
+ STRING_AT((indexRep)->tablePtr, (indexRep)->offset*(indexRep)->index)
/*
*----------------------------------------------------------------------
@@ -121,7 +121,7 @@ Tcl_GetIndexFromObj(
*/
if (objPtr->typePtr == &indexType) {
- IndexRep *indexRep = objPtr->internalRep.otherValuePtr;
+ IndexRep *indexRep = objPtr->internalRep.twoPtrValue.ptr1;
/*
* Here's hoping we don't get hit by unfortunate packing constraints
@@ -238,7 +238,7 @@ GetIndexFromObjList(
* a proper match, then TCL_ERROR is returned and an error message is
* left in interp's result (unless interp is NULL). The msg argument is
* used in the error message; for example, if msg has the value "option"
- * then the error message will say something flag 'bad option "foo": must
+ * then the error message will say something like 'bad option "foo": must
* be ...'
*
* Side effects:
@@ -270,12 +270,16 @@ Tcl_GetIndexFromObjStruct(
Tcl_Obj *resultPtr;
IndexRep *indexRep;
+ /* Protect against invalid values, like -1 or 0. */
+ if (offset < (int)sizeof(char *)) {
+ offset = (int)sizeof(char *);
+ }
/*
* See if there is a valid cached result from a previous lookup.
*/
if (objPtr->typePtr == &indexType) {
- indexRep = objPtr->internalRep.otherValuePtr;
+ indexRep = objPtr->internalRep.twoPtrValue.ptr1;
if (indexRep->tablePtr==tablePtr && indexRep->offset==offset) {
*indexPtr = indexRep->index;
return TCL_OK;
@@ -336,11 +340,11 @@ Tcl_GetIndexFromObjStruct(
*/
if (objPtr->typePtr == &indexType) {
- indexRep = objPtr->internalRep.otherValuePtr;
+ indexRep = objPtr->internalRep.twoPtrValue.ptr1;
} else {
TclFreeIntRep(objPtr);
indexRep = ckalloc(sizeof(IndexRep));
- objPtr->internalRep.otherValuePtr = indexRep;
+ objPtr->internalRep.twoPtrValue.ptr1 = indexRep;
objPtr->typePtr = &indexType;
}
indexRep->tablePtr = (void *) tablePtr;
@@ -443,7 +447,7 @@ static void
UpdateStringOfIndex(
Tcl_Obj *objPtr)
{
- IndexRep *indexRep = objPtr->internalRep.otherValuePtr;
+ IndexRep *indexRep = objPtr->internalRep.twoPtrValue.ptr1;
register char *buf;
register unsigned len;
register const char *indexStr = EXPAND_OF(indexRep);
@@ -478,11 +482,11 @@ DupIndex(
Tcl_Obj *srcPtr,
Tcl_Obj *dupPtr)
{
- IndexRep *srcIndexRep = srcPtr->internalRep.otherValuePtr;
+ IndexRep *srcIndexRep = srcPtr->internalRep.twoPtrValue.ptr1;
IndexRep *dupIndexRep = ckalloc(sizeof(IndexRep));
memcpy(dupIndexRep, srcIndexRep, sizeof(IndexRep));
- dupPtr->internalRep.otherValuePtr = dupIndexRep;
+ dupPtr->internalRep.twoPtrValue.ptr1 = dupIndexRep;
dupPtr->typePtr = &indexType;
}
@@ -507,7 +511,7 @@ static void
FreeIndex(
Tcl_Obj *objPtr)
{
- ckfree(objPtr->internalRep.otherValuePtr);
+ ckfree(objPtr->internalRep.twoPtrValue.ptr1);
objPtr->typePtr = NULL;
}
@@ -948,13 +952,13 @@ Tcl_WrongNumArgs(
if (origObjv[i]->typePtr == &indexType) {
register IndexRep *indexRep =
- origObjv[i]->internalRep.otherValuePtr;
+ origObjv[i]->internalRep.twoPtrValue.ptr1;
elementStr = EXPAND_OF(indexRep);
elemLen = strlen(elementStr);
} else if (origObjv[i]->typePtr == &tclEnsembleCmdType) {
register EnsembleCmdRep *ecrPtr =
- origObjv[i]->internalRep.otherValuePtr;
+ origObjv[i]->internalRep.twoPtrValue.ptr1;
elementStr = ecrPtr->fullSubcmdName;
elemLen = strlen(elementStr);
@@ -1002,12 +1006,12 @@ Tcl_WrongNumArgs(
*/
if (objv[i]->typePtr == &indexType) {
- register IndexRep *indexRep = objv[i]->internalRep.otherValuePtr;
+ register IndexRep *indexRep = objv[i]->internalRep.twoPtrValue.ptr1;
Tcl_AppendStringsToObj(objPtr, EXPAND_OF(indexRep), NULL);
} else if (objv[i]->typePtr == &tclEnsembleCmdType) {
register EnsembleCmdRep *ecrPtr =
- objv[i]->internalRep.otherValuePtr;
+ objv[i]->internalRep.twoPtrValue.ptr1;
Tcl_AppendStringsToObj(objPtr, ecrPtr->fullSubcmdName, NULL);
} else {
diff --git a/generic/tclInt.decls b/generic/tclInt.decls
index af6cc6e..a18517a 100644
--- a/generic/tclInt.decls
+++ b/generic/tclInt.decls
@@ -626,14 +626,14 @@ declare 156 {
declare 157 {
Var *TclVarTraceExists(Tcl_Interp *interp, const char *varName)
}
-# REMOVED - use public Tcl_SetStartupScript()
-#declare 158 {
-# void TclSetStartupScriptFileName(const char *filename)
-#}
-# REMOVED - use public Tcl_GetStartupScript()
-#declare 159 {
-# const char *TclGetStartupScriptFileName(void)
-#}
+# REMOVED (except from stub table) - use public Tcl_SetStartupScript()
+declare 158 {
+ void TclSetStartupScriptFileName(const char *filename)
+}
+# REMOVED (except from stub table) - use public Tcl_GetStartupScript()
+declare 159 {
+ const char *TclGetStartupScriptFileName(void)
+}
#declare 160 {
# int TclpMatchFilesTypes(Tcl_Interp *interp, char *separators,
# Tcl_DString *dirPtr, char *pattern, char *tail,
@@ -678,14 +678,14 @@ declare 166 {
}
# VFS-aware versions of Tcl*StartupScriptFileName (158 and 159 above)
-# REMOVED - use public Tcl_SetStartupScript()
-#declare 167 {
-# void TclSetStartupScriptPath(Tcl_Obj *pathPtr)
-#}
-# REMOVED - use public Tcl_GetStartupScript()
-#declare 168 {
-# Tcl_Obj *TclGetStartupScriptPath(void)
-#}
+# REMOVED (except from stub table) - use public Tcl_SetStartupScript()
+declare 167 {
+ void TclSetStartupScriptPath(Tcl_Obj *pathPtr)
+}
+# REMOVED (except from stub table) - use public Tcl_GetStartupScript()
+declare 168 {
+ Tcl_Obj *TclGetStartupScriptPath(void)
+}
# variant of Tcl_UtfNCmp that takes n as bytes, not chars
declare 169 {
int TclpUtfNcmp2(const char *s1, const char *s2, unsigned long n)
@@ -731,13 +731,13 @@ declare 177 {
void TclVarErrMsg(Tcl_Interp *interp, const char *part1, const char *part2,
const char *operation, const char *reason)
}
-# TIP 338 made these public - now declared in tcl.h
-#declare 178 {
-# void Tcl_SetStartupScript(Tcl_Obj *pathPtr, const char *encodingName)
-#}
-#declare 179 {
-# Tcl_Obj *Tcl_GetStartupScript(const char **encodingNamePtr)
-#}
+# TIP 338 made these public - now declared in tcl.h too
+declare 178 {
+ void Tcl_SetStartupScript(Tcl_Obj *pathPtr, const char *encodingName)
+}
+declare 179 {
+ Tcl_Obj *Tcl_GetStartupScript(const char **encodingNamePtr)
+}
# REMOVED
# Allocate lists without copying arrays
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 2a9ffc4..45550e2 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -396,7 +396,7 @@ struct NamespacePathEntry {
/*
* The data cached in an ensemble subcommand's Tcl_Obj rep (reference in
- * otherValuePtr field). This structure is not shared between Tcl_Objs
+ * twoPtrValue.ptr1 field). This structure is not shared between Tcl_Objs
* referring to the same subcommand, even where one is a duplicate of another.
*/
@@ -3069,6 +3069,7 @@ MODULE_SCOPE void TclSetBgErrorHandler(Tcl_Interp *interp,
Tcl_Obj *cmdPrefix);
MODULE_SCOPE void TclSetBignumIntRep(Tcl_Obj *objPtr,
mp_int *bignumValue);
+MODULE_SCOPE int TclSetBooleanFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
MODULE_SCOPE void TclSetCmdNameObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
Command *cmdPtr);
MODULE_SCOPE void TclSetDuplicateObj(Tcl_Obj *dupPtr, Tcl_Obj *objPtr);
diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h
index 7981c18..5569c79 100644
--- a/generic/tclIntDecls.h
+++ b/generic/tclIntDecls.h
@@ -41,6 +41,8 @@
#undef Tcl_FindCommand
#undef Tcl_GetCommandFromObj
#undef Tcl_GetCommandFullName
+#undef Tcl_SetStartupScript
+#undef Tcl_GetStartupScript
/*
* WARNING: This file is automatically generated by the tools/genStubs.tcl
@@ -390,8 +392,10 @@ EXTERN void TclRegError(Tcl_Interp *interp, const char *msg,
/* 157 */
EXTERN Var * TclVarTraceExists(Tcl_Interp *interp,
const char *varName);
-/* Slot 158 is reserved */
-/* Slot 159 is reserved */
+/* 158 */
+EXTERN void TclSetStartupScriptFileName(const char *filename);
+/* 159 */
+EXTERN const char * TclGetStartupScriptFileName(void);
/* Slot 160 is reserved */
/* 161 */
EXTERN int TclChannelTransform(Tcl_Interp *interp,
@@ -409,8 +413,10 @@ EXTERN void TclpSetInitialEncodings(void);
EXTERN int TclListObjSetElement(Tcl_Interp *interp,
Tcl_Obj *listPtr, int index,
Tcl_Obj *valuePtr);
-/* Slot 167 is reserved */
-/* Slot 168 is reserved */
+/* 167 */
+EXTERN void TclSetStartupScriptPath(Tcl_Obj *pathPtr);
+/* 168 */
+EXTERN Tcl_Obj * TclGetStartupScriptPath(void);
/* 169 */
EXTERN int TclpUtfNcmp2(const char *s1, const char *s2,
unsigned long n);
@@ -442,8 +448,11 @@ EXTERN void TclCleanupVar(Var *varPtr, Var *arrayPtr);
EXTERN void TclVarErrMsg(Tcl_Interp *interp, const char *part1,
const char *part2, const char *operation,
const char *reason);
-/* Slot 178 is reserved */
-/* Slot 179 is reserved */
+/* 178 */
+EXTERN void Tcl_SetStartupScript(Tcl_Obj *pathPtr,
+ const char *encodingName);
+/* 179 */
+EXTERN Tcl_Obj * Tcl_GetStartupScript(const char **encodingNamePtr);
/* Slot 180 is reserved */
/* Slot 181 is reserved */
/* 182 */
@@ -757,8 +766,8 @@ typedef struct TclIntStubs {
void (*reserved155)(void);
void (*tclRegError) (Tcl_Interp *interp, const char *msg, int status); /* 156 */
Var * (*tclVarTraceExists) (Tcl_Interp *interp, const char *varName); /* 157 */
- void (*reserved158)(void);
- void (*reserved159)(void);
+ void (*tclSetStartupScriptFileName) (const char *filename); /* 158 */
+ const char * (*tclGetStartupScriptFileName) (void); /* 159 */
void (*reserved160)(void);
int (*tclChannelTransform) (Tcl_Interp *interp, Tcl_Channel chan, Tcl_Obj *cmdObjPtr); /* 161 */
void (*tclChannelEventScriptInvoker) (ClientData clientData, int flags); /* 162 */
@@ -766,8 +775,8 @@ typedef struct TclIntStubs {
void (*tclExpandCodeArray) (void *envPtr); /* 164 */
void (*tclpSetInitialEncodings) (void); /* 165 */
int (*tclListObjSetElement) (Tcl_Interp *interp, Tcl_Obj *listPtr, int index, Tcl_Obj *valuePtr); /* 166 */
- void (*reserved167)(void);
- void (*reserved168)(void);
+ void (*tclSetStartupScriptPath) (Tcl_Obj *pathPtr); /* 167 */
+ Tcl_Obj * (*tclGetStartupScriptPath) (void); /* 168 */
int (*tclpUtfNcmp2) (const char *s1, const char *s2, unsigned long n); /* 169 */
int (*tclCheckInterpTraces) (Tcl_Interp *interp, const char *command, int numChars, Command *cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *const objv[]); /* 170 */
int (*tclCheckExecutionTraces) (Tcl_Interp *interp, const char *command, int numChars, Command *cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *const objv[]); /* 171 */
@@ -777,8 +786,8 @@ typedef struct TclIntStubs {
int (*tclCallVarTraces) (Interp *iPtr, Var *arrayPtr, Var *varPtr, const char *part1, const char *part2, int flags, int leaveErrMsg); /* 175 */
void (*tclCleanupVar) (Var *varPtr, Var *arrayPtr); /* 176 */
void (*tclVarErrMsg) (Tcl_Interp *interp, const char *part1, const char *part2, const char *operation, const char *reason); /* 177 */
- void (*reserved178)(void);
- void (*reserved179)(void);
+ void (*tcl_SetStartupScript) (Tcl_Obj *pathPtr, const char *encodingName); /* 178 */
+ Tcl_Obj * (*tcl_GetStartupScript) (const char **encodingNamePtr); /* 179 */
void (*reserved180)(void);
void (*reserved181)(void);
struct tm * (*tclpLocaltime) (const time_t *clock); /* 182 */
@@ -1119,8 +1128,10 @@ extern const TclIntStubs *tclIntStubsPtr;
(tclIntStubsPtr->tclRegError) /* 156 */
#define TclVarTraceExists \
(tclIntStubsPtr->tclVarTraceExists) /* 157 */
-/* Slot 158 is reserved */
-/* Slot 159 is reserved */
+#define TclSetStartupScriptFileName \
+ (tclIntStubsPtr->tclSetStartupScriptFileName) /* 158 */
+#define TclGetStartupScriptFileName \
+ (tclIntStubsPtr->tclGetStartupScriptFileName) /* 159 */
/* Slot 160 is reserved */
#define TclChannelTransform \
(tclIntStubsPtr->tclChannelTransform) /* 161 */
@@ -1134,8 +1145,10 @@ extern const TclIntStubs *tclIntStubsPtr;
(tclIntStubsPtr->tclpSetInitialEncodings) /* 165 */
#define TclListObjSetElement \
(tclIntStubsPtr->tclListObjSetElement) /* 166 */
-/* Slot 167 is reserved */
-/* Slot 168 is reserved */
+#define TclSetStartupScriptPath \
+ (tclIntStubsPtr->tclSetStartupScriptPath) /* 167 */
+#define TclGetStartupScriptPath \
+ (tclIntStubsPtr->tclGetStartupScriptPath) /* 168 */
#define TclpUtfNcmp2 \
(tclIntStubsPtr->tclpUtfNcmp2) /* 169 */
#define TclCheckInterpTraces \
@@ -1153,8 +1166,10 @@ extern const TclIntStubs *tclIntStubsPtr;
(tclIntStubsPtr->tclCleanupVar) /* 176 */
#define TclVarErrMsg \
(tclIntStubsPtr->tclVarErrMsg) /* 177 */
-/* Slot 178 is reserved */
-/* Slot 179 is reserved */
+#define Tcl_SetStartupScript \
+ (tclIntStubsPtr->tcl_SetStartupScript) /* 178 */
+#define Tcl_GetStartupScript \
+ (tclIntStubsPtr->tcl_GetStartupScript) /* 179 */
/* Slot 180 is reserved */
/* Slot 181 is reserved */
#define TclpLocaltime \
@@ -1276,9 +1291,19 @@ extern const TclIntStubs *tclIntStubsPtr;
#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS DLLIMPORT
+#undef TclGetStartupScriptFileName
+#undef TclSetStartupScriptFileName
+#undef TclGetStartupScriptPath
+#undef TclSetStartupScriptPath
#undef TclBackgroundException
#if defined(USE_TCL_STUBS) && defined(TCL_NO_DEPRECATED)
+# undef Tcl_SetStartupScript
+# define Tcl_SetStartupScript \
+ (tclStubsPtr->tcl_SetStartupScript) /* 622 */
+# undef Tcl_GetStartupScript
+# define Tcl_GetStartupScript \
+ (tclStubsPtr->tcl_GetStartupScript) /* 623 */
# undef Tcl_CreateNamespace
# define Tcl_CreateNamespace \
(tclStubsPtr->tcl_CreateNamespace) /* 506 */
diff --git a/generic/tclListObj.c b/generic/tclListObj.c
index 07d2644..fccec0a 100644
--- a/generic/tclListObj.c
+++ b/generic/tclListObj.c
@@ -243,7 +243,7 @@ Tcl_NewListObj(
* Now create the object.
*/
- Tcl_InvalidateStringRep(listPtr);
+ TclInvalidateStringRep(listPtr);
ListSetIntRep(listPtr, listRepPtr);
return listPtr;
}
@@ -308,7 +308,7 @@ Tcl_DbNewListObj(
* Now create the object.
*/
- Tcl_InvalidateStringRep(listPtr);
+ TclInvalidateStringRep(listPtr);
ListSetIntRep(listPtr, listRepPtr);
return listPtr;
@@ -368,7 +368,7 @@ Tcl_SetListObj(
*/
TclFreeIntRep(objPtr);
- Tcl_InvalidateStringRep(objPtr);
+ TclInvalidateStringRep(objPtr);
/*
* Set the object's type to "list" and initialize the internal rep.
@@ -704,7 +704,7 @@ Tcl_ListObjAppendElement(
* representation has changed.
*/
- Tcl_InvalidateStringRep(listPtr);
+ TclInvalidateStringRep(listPtr);
return TCL_OK;
}
@@ -1064,7 +1064,7 @@ Tcl_ListObjReplace(
* reflects the list's internal representation.
*/
- Tcl_InvalidateStringRep(listPtr);
+ TclInvalidateStringRep(listPtr);
return TCL_OK;
}
@@ -1530,7 +1530,7 @@ TclLsetFlat(
* containing lists.
*/
- Tcl_InvalidateStringRep(objPtr);
+ TclInvalidateStringRep(objPtr);
}
/*
@@ -1566,7 +1566,7 @@ TclLsetFlat(
} else {
TclListObjSetElement(NULL, subListPtr, index, valuePtr);
}
- Tcl_InvalidateStringRep(subListPtr);
+ TclInvalidateStringRep(subListPtr);
Tcl_IncrRefCount(retValuePtr);
return retValuePtr;
}
@@ -1743,8 +1743,6 @@ FreeListInternalRep(
ckfree(listRepPtr);
}
- listPtr->internalRep.twoPtrValue.ptr1 = NULL;
- listPtr->internalRep.twoPtrValue.ptr2 = NULL;
listPtr->typePtr = NULL;
}
diff --git a/generic/tclLoadNone.c b/generic/tclLoadNone.c
index f030d89..5a2dc53 100644
--- a/generic/tclLoadNone.c
+++ b/generic/tclLoadNone.c
@@ -82,6 +82,39 @@ TclGuessPackageName(
}
/*
+ * These functions are fallbacks if we somehow determine that the platform can
+ * do loading from memory but the user wishes to disable it. They just report
+ * (gracefully) that they fail.
+ */
+
+#ifdef TCL_LOAD_FROM_MEMORY
+
+MODULE_SCOPE void *
+TclpLoadMemoryGetBuffer(
+ Tcl_Interp *interp, /* Dummy: unused by this implementation */
+ int size) /* Dummy: unused by this implementation */
+{
+ return NULL;
+}
+
+MODULE_SCOPE int
+TclpLoadMemory(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ void *buffer, /* Dummy: unused by this implementation */
+ int size, /* Dummy: unused by this implementation */
+ int codeSize, /* Dummy: unused by this implementation */
+ Tcl_LoadHandle *loadHandle, /* Dummy: unused by this implementation */
+ Tcl_FSUnloadFileProc **unloadProcPtr)
+ /* Dummy: unused by this implementation */
+{
+ Tcl_SetResult(interp, "dynamic loading from memory is not available "
+ "on this system", TCL_STATIC);
+ return TCL_ERROR;
+}
+
+#endif /* TCL_LOAD_FROM_MEMORY */
+
+/*
* Local Variables:
* mode: c
* c-basic-offset: 4
diff --git a/generic/tclOO.c b/generic/tclOO.c
index d6d2d6a..cb22de6 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -843,7 +843,7 @@ ObjectRenamedTrace(
result = Tcl_NRCallObjProc(interp, TclOOInvokeContext,
contextPtr, 0, NULL);
if (result != TCL_OK) {
- Tcl_BackgroundError(interp);
+ Tcl_BackgroundException(interp, result);
}
Tcl_RestoreInterpState(interp, state);
TclOODeleteContext(contextPtr);
diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c
index 0676618..f8cd1a4 100644
--- a/generic/tclOOBasic.c
+++ b/generic/tclOOBasic.c
@@ -687,52 +687,51 @@ TclOO_Object_VarName(
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* The actual arguments. */
{
- Interp *iPtr = (Interp *) interp;
Var *varPtr, *aryVar;
- Tcl_Obj *varNamePtr;
+ Tcl_Obj *varNamePtr, *argPtr;
+ const char *arg;
if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
"varName");
return TCL_ERROR;
}
+ argPtr = objv[objc-1];
+ arg = Tcl_GetString(argPtr);
/*
- * Switch to the object's namespace for the duration of this call. Like
- * this, the variable is looked up in the namespace of the object, and not
- * in the namespace of the caller. Otherwise this would only work if the
- * caller was a method of the object itself, which might not be true if
- * the method was exported. This is a bit of a hack, but the simplest way
- * to do this (pushing a stack frame would be horribly expensive by
- * comparison, and is only done when we'd otherwise interfere with the
- * global namespace).
+ * Convert the variable name to fully-qualified form if it wasn't already.
+ * This has to be done prior to lookup because we can run into problems
+ * with resolvers otherwise. [Bug 3603695]
+ *
+ * We still need to do the lookup; the variable could be linked to another
+ * variable and we want the target's name.
*/
- if (iPtr->varFramePtr == NULL) {
- Tcl_CallFrame *dummyFrame;
-
- TclPushStackFrame(interp, &dummyFrame,
- Tcl_GetObjectNamespace(Tcl_ObjectContextObject(context)),0);
- varPtr = TclObjLookupVar(interp, objv[objc-1], NULL,
- TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG, "refer to",1,1,&aryVar);
- TclPopStackFrame(interp);
+ if (arg[0] == ':' && arg[1] == ':') {
+ varNamePtr = argPtr;
} else {
- Namespace *savedNsPtr;
-
- savedNsPtr = iPtr->varFramePtr->nsPtr;
- iPtr->varFramePtr->nsPtr = (Namespace *)
+ Tcl_Namespace *namespacePtr =
Tcl_GetObjectNamespace(Tcl_ObjectContextObject(context));
- varPtr = TclObjLookupVar(interp, objv[objc-1], NULL,
- TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG, "refer to",1,1,&aryVar);
- iPtr->varFramePtr->nsPtr = savedNsPtr;
- }
+ varNamePtr = Tcl_NewStringObj(namespacePtr->fullName, -1);
+ Tcl_AppendToObj(varNamePtr, "::", 2);
+ Tcl_AppendObjToObj(varNamePtr, argPtr);
+ }
+ Tcl_IncrRefCount(varNamePtr);
+ varPtr = TclObjLookupVar(interp, varNamePtr, NULL,
+ TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG, "refer to", 1, 1, &aryVar);
+ Tcl_DecrRefCount(varNamePtr);
if (varPtr == NULL) {
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARIABLE",
- TclGetString(objv[objc-1]), NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARIABLE", arg, NULL);
return TCL_ERROR;
}
+ /*
+ * Now that we've pinned down what variable we're really talking about
+ * (including traversing variable links), convert back to a name.
+ */
+
varNamePtr = Tcl_NewObj();
if (aryVar != NULL) {
Tcl_HashEntry *hPtr;
diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c
index fd751ff..c595669 100644
--- a/generic/tclOOCall.c
+++ b/generic/tclOOCall.c
@@ -178,7 +178,7 @@ StashCallChain(
callPtr->refCount++;
TclFreeIntRep(objPtr);
objPtr->typePtr = &methodNameType;
- objPtr->internalRep.otherValuePtr = callPtr;
+ objPtr->internalRep.twoPtrValue.ptr1 = callPtr;
}
void
@@ -205,10 +205,10 @@ DupMethodNameRep(
Tcl_Obj *srcPtr,
Tcl_Obj *dstPtr)
{
- register CallChain *callPtr = srcPtr->internalRep.otherValuePtr;
+ register CallChain *callPtr = srcPtr->internalRep.twoPtrValue.ptr1;
dstPtr->typePtr = &methodNameType;
- dstPtr->internalRep.otherValuePtr = callPtr;
+ dstPtr->internalRep.twoPtrValue.ptr1 = callPtr;
callPtr->refCount++;
}
@@ -216,10 +216,9 @@ static void
FreeMethodNameRep(
Tcl_Obj *objPtr)
{
- register CallChain *callPtr = objPtr->internalRep.otherValuePtr;
+ register CallChain *callPtr = objPtr->internalRep.twoPtrValue.ptr1;
TclOODeleteChain(callPtr);
- objPtr->internalRep.otherValuePtr = NULL;
objPtr->typePtr = NULL;
}
@@ -952,7 +951,7 @@ TclOOGetCallContext(
const int reuseMask = ((flags & PUBLIC_METHOD) ? ~0 : ~PUBLIC_METHOD);
if (cacheInThisObj->typePtr == &methodNameType) {
- callPtr = cacheInThisObj->internalRep.otherValuePtr;
+ callPtr = cacheInThisObj->internalRep.twoPtrValue.ptr1;
if (IsStillValid(callPtr, oPtr, flags, reuseMask)) {
callPtr->refCount++;
goto returnContext;
diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c
index e60f737..44e0128 100644
--- a/generic/tclOOMethod.c
+++ b/generic/tclOOMethod.c
@@ -860,7 +860,7 @@ PushMethodCallFrame(
if (pmPtr->procPtr->bodyPtr->typePtr == &tclByteCodeType) {
ByteCode *codePtr =
- pmPtr->procPtr->bodyPtr->internalRep.otherValuePtr;
+ pmPtr->procPtr->bodyPtr->internalRep.twoPtrValue.ptr1;
codePtr->nsPtr = nsPtr;
}
diff --git a/generic/tclObj.c b/generic/tclObj.c
index 5bf20b0..79f7bb5 100644
--- a/generic/tclObj.c
+++ b/generic/tclObj.c
@@ -196,7 +196,6 @@ static Tcl_ThreadDataKey pendingObjDataKey;
*/
static int ParseBoolean(Tcl_Obj *objPtr);
-static int SetBooleanFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
static int SetDoubleFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
static int SetIntFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
static void UpdateStringOfDouble(Tcl_Obj *objPtr);
@@ -238,14 +237,14 @@ static const Tcl_ObjType oldBooleanType = {
NULL, /* freeIntRepProc */
NULL, /* dupIntRepProc */
NULL, /* updateStringProc */
- SetBooleanFromAny /* setFromAnyProc */
+ TclSetBooleanFromAny /* setFromAnyProc */
};
const Tcl_ObjType tclBooleanType = {
"booleanString", /* name */
NULL, /* freeIntRepProc */
NULL, /* dupIntRepProc */
NULL, /* updateStringProc */
- SetBooleanFromAny /* setFromAnyProc */
+ TclSetBooleanFromAny /* setFromAnyProc */
};
const Tcl_ObjType tclDoubleType = {
"double", /* name */
@@ -1810,7 +1809,7 @@ Tcl_GetBooleanFromObj(
/*
*----------------------------------------------------------------------
*
- * SetBooleanFromAny --
+ * TclSetBooleanFromAny --
*
* Attempt to generate a boolean internal form for the Tcl object
* "objPtr".
@@ -1827,8 +1826,8 @@ Tcl_GetBooleanFromObj(
*----------------------------------------------------------------------
*/
-static int
-SetBooleanFromAny(
+int
+TclSetBooleanFromAny(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
register Tcl_Obj *objPtr) /* The object to convert. */
{
@@ -4070,7 +4069,7 @@ Tcl_GetCommandFromObj(
* had is invalid one way or another.
*/
- if (tclCmdNameType.setFromAnyProc(interp, objPtr) != TCL_OK) {
+ if (SetCmdNameFromAny(interp, objPtr) != TCL_OK) {
return NULL;
}
resPtr = objPtr->internalRep.twoPtrValue.ptr1;
@@ -4289,7 +4288,7 @@ SetCmdNameFromAny(
if (cmdPtr) {
cmdPtr->refCount++;
- resPtr = objPtr->internalRep.otherValuePtr;
+ resPtr = objPtr->internalRep.twoPtrValue.ptr1;
if ((objPtr->typePtr == &tclCmdNameType)
&& resPtr && (resPtr->refCount == 1)) {
/*
diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c
index 2b9ff87..b7f3dcf 100644
--- a/generic/tclPathObj.c
+++ b/generic/tclPathObj.c
@@ -109,9 +109,9 @@ typedef struct FsPath {
* fields.
*/
-#define PATHOBJ(pathPtr) ((FsPath *) (pathPtr)->internalRep.otherValuePtr)
+#define PATHOBJ(pathPtr) ((FsPath *) (pathPtr)->internalRep.twoPtrValue.ptr1)
#define SETPATHOBJ(pathPtr,fsPathPtr) \
- ((pathPtr)->internalRep.otherValuePtr = (void *) (fsPathPtr))
+ ((pathPtr)->internalRep.twoPtrValue.ptr1 = (void *) (fsPathPtr))
#define PATHFLAGS(pathPtr) (PATHOBJ(pathPtr)->flags)
/*
@@ -1156,7 +1156,7 @@ Tcl_FSConvertToPathType(
FreeFsPathInternalRep(pathPtr);
}
- return Tcl_ConvertToType(interp, pathPtr, &tclFsPathType);
+ return SetFsPathFromAny(interp, pathPtr);
/*
* We used to have more complex code here:
@@ -1873,7 +1873,7 @@ Tcl_FSGetNormalizedPath(
UpdateStringOfFsPath(pathPtr);
}
FreeFsPathInternalRep(pathPtr);
- if (Tcl_ConvertToType(interp, pathPtr, &tclFsPathType) != TCL_OK) {
+ if (SetFsPathFromAny(interp, pathPtr) != TCL_OK) {
return NULL;
}
fsPathPtr = PATHOBJ(pathPtr);
diff --git a/generic/tclPort.h b/generic/tclPort.h
index 7021b8d..12a60db 100644
--- a/generic/tclPort.h
+++ b/generic/tclPort.h
@@ -19,11 +19,10 @@
#endif
#if defined(_WIN32)
# include "tclWinPort.h"
-#endif
-#include "tcl.h"
-#if !defined(_WIN32)
+#else
# include "tclUnixPort.h"
#endif
+#include "tcl.h"
#if !defined(LLONG_MIN)
# ifdef TCL_WIDE_INT_IS_LONG
diff --git a/generic/tclProc.c b/generic/tclProc.c
index d841dcb..edb9b50 100644
--- a/generic/tclProc.c
+++ b/generic/tclProc.c
@@ -421,7 +421,7 @@ TclCreateProc(
* will be holding a reference to it.
*/
- procPtr = bodyPtr->internalRep.otherValuePtr;
+ procPtr = bodyPtr->internalRep.twoPtrValue.ptr1;
procPtr->iPtr = iPtr;
procPtr->refCount++;
precompiled = 1;
@@ -1196,7 +1196,7 @@ TclInitCompiledLocals(
if (bodyPtr->typePtr != &tclByteCodeType) {
Tcl_Panic("body object for proc attached to frame is not a byte code type");
}
- codePtr = bodyPtr->internalRep.otherValuePtr;
+ codePtr = bodyPtr->internalRep.twoPtrValue.ptr1;
if (framePtr->numCompiledLocals) {
if (!codePtr->localCachePtr) {
@@ -1367,7 +1367,7 @@ InitLocalCache(
Proc *procPtr)
{
Interp *iPtr = procPtr->iPtr;
- ByteCode *codePtr = procPtr->bodyPtr->internalRep.otherValuePtr;
+ ByteCode *codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1;
int localCt = procPtr->numCompiledLocals;
int numArgs = procPtr->numArgs, i = 0;
@@ -1444,7 +1444,7 @@ InitArgsAndLocals(
{
CallFrame *framePtr = ((Interp *)interp)->varFramePtr;
register Proc *procPtr = framePtr->procPtr;
- ByteCode *codePtr = procPtr->bodyPtr->internalRep.otherValuePtr;
+ ByteCode *codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1;
register Var *varPtr, *defPtr;
int localCt = procPtr->numCompiledLocals, numArgs, argCt, i, imax;
Tcl_Obj *const *argObjs;
@@ -1631,7 +1631,7 @@ PushProcCallFrame(
* commands and/or resolver changes are considered).
*/
- codePtr = procPtr->bodyPtr->internalRep.otherValuePtr;
+ codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1;
if (((Interp *) *codePtr->interpHandle != iPtr)
|| (codePtr->compileEpoch != iPtr->compileEpoch)
|| (codePtr->nsPtr != nsPtr)
@@ -1832,7 +1832,7 @@ TclNRInterpProcCore(
*/
procPtr->refCount++;
- codePtr = procPtr->bodyPtr->internalRep.otherValuePtr;
+ codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1;
TclNRAddCallback(interp, InterpProcNR2, procNameObj, errorProc,
NULL, NULL);
@@ -1974,7 +1974,7 @@ TclProcCompileProc(
{
Interp *iPtr = (Interp *) interp;
Tcl_CallFrame *framePtr;
- ByteCode *codePtr = bodyPtr->internalRep.otherValuePtr;
+ ByteCode *codePtr = bodyPtr->internalRep.twoPtrValue.ptr1;
/*
* If necessary, compile the procedure's body. The compiler will allocate
@@ -2094,7 +2094,7 @@ TclProcCompileProc(
iPtr->invokeWord = 0;
iPtr->invokeCmdFramePtr = (hePtr ? Tcl_GetHashValue(hePtr) : NULL);
- tclByteCodeType.setFromAnyProc(interp, bodyPtr);
+ TclSetByteCodeFromAny(interp, bodyPtr, NULL, NULL);
iPtr->invokeCmdFramePtr = NULL;
TclPopStackFrame(interp);
} else if (codePtr->nsEpoch != nsPtr->resolverEpoch) {
@@ -2364,7 +2364,7 @@ TclNewProcBodyObj(
TclNewObj(objPtr);
if (objPtr) {
objPtr->typePtr = &tclProcBodyType;
- objPtr->internalRep.otherValuePtr = procPtr;
+ objPtr->internalRep.twoPtrValue.ptr1 = procPtr;
procPtr->refCount++;
}
@@ -2394,10 +2394,10 @@ ProcBodyDup(
Tcl_Obj *srcPtr, /* Object to copy. */
Tcl_Obj *dupPtr) /* Target object for the duplication. */
{
- Proc *procPtr = srcPtr->internalRep.otherValuePtr;
+ Proc *procPtr = srcPtr->internalRep.twoPtrValue.ptr1;
dupPtr->typePtr = &tclProcBodyType;
- dupPtr->internalRep.otherValuePtr = procPtr;
+ dupPtr->internalRep.twoPtrValue.ptr1 = procPtr;
procPtr->refCount++;
}
@@ -2424,10 +2424,9 @@ static void
ProcBodyFree(
Tcl_Obj *objPtr) /* The object to clean up. */
{
- Proc *procPtr = objPtr->internalRep.otherValuePtr;
+ Proc *procPtr = objPtr->internalRep.twoPtrValue.ptr1;
- procPtr->refCount--;
- if (procPtr->refCount <= 0) {
+ if (procPtr->refCount-- < 2) {
TclProcCleanupProc(procPtr);
}
}
@@ -2720,7 +2719,6 @@ TclNRApplyObjCmd(
else {
/*
* Joe English's suggestion to allow cmdNames to function as lambdas.
- * Also requires making tclCmdNameType non-static in tclObj.c
*/
Tcl_Obj *elemPtr;
@@ -2960,10 +2958,9 @@ Tcl_DisassembleObjCmd(
Tcl_WrongNumArgs(interp, 2, objv, "script");
return TCL_ERROR;
}
- if (objv[2]->typePtr != &tclByteCodeType) {
- if (TclSetByteCodeFromAny(interp, objv[2], NULL, NULL) != TCL_OK){
- return TCL_ERROR;
- }
+ if ((objv[2]->typePtr != &tclByteCodeType)
+ && (TclSetByteCodeFromAny(interp, objv[2], NULL, NULL) != TCL_OK)) {
+ return TCL_ERROR;
}
codeObjPtr = objv[2];
break;
@@ -3060,7 +3057,7 @@ Tcl_DisassembleObjCmd(
* Do the actual disassembly.
*/
- if (((ByteCode *) codeObjPtr->internalRep.otherValuePtr)->flags
+ if (((ByteCode *) codeObjPtr->internalRep.twoPtrValue.ptr1)->flags
& TCL_BYTECODE_PRECOMPILED) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"may not disassemble prebuilt bytecode", -1));
diff --git a/generic/tclRegexp.c b/generic/tclRegexp.c
index 6c1dc08..6348e4a 100644
--- a/generic/tclRegexp.c
+++ b/generic/tclRegexp.c
@@ -578,7 +578,7 @@ Tcl_GetRegExpFromObj(
* TclRegexp* when the type is tclRegexpType.
*/
- regexpPtr = objPtr->internalRep.otherValuePtr;
+ regexpPtr = objPtr->internalRep.twoPtrValue.ptr1;
if ((objPtr->typePtr != &tclRegexpType) || (regexpPtr->flags != flags)) {
pattern = TclGetStringFromObj(objPtr, &length);
@@ -601,7 +601,7 @@ Tcl_GetRegExpFromObj(
*/
TclFreeIntRep(objPtr);
- objPtr->internalRep.otherValuePtr = regexpPtr;
+ objPtr->internalRep.twoPtrValue.ptr1 = regexpPtr;
objPtr->typePtr = &tclRegexpType;
}
return (Tcl_RegExp) regexpPtr;
@@ -749,7 +749,7 @@ static void
FreeRegexpInternalRep(
Tcl_Obj *objPtr) /* Regexp object with internal rep to free. */
{
- TclRegexp *regexpRepPtr = objPtr->internalRep.otherValuePtr;
+ TclRegexp *regexpRepPtr = objPtr->internalRep.twoPtrValue.ptr1;
/*
* If this is the last reference to the regexp, free it.
@@ -783,10 +783,10 @@ DupRegexpInternalRep(
Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
Tcl_Obj *copyPtr) /* Object with internal rep to set. */
{
- TclRegexp *regexpPtr = srcPtr->internalRep.otherValuePtr;
+ TclRegexp *regexpPtr = srcPtr->internalRep.twoPtrValue.ptr1;
regexpPtr->refCount++;
- copyPtr->internalRep.otherValuePtr = srcPtr->internalRep.otherValuePtr;
+ copyPtr->internalRep.twoPtrValue.ptr1 = srcPtr->internalRep.twoPtrValue.ptr1;
copyPtr->typePtr = &tclRegexpType;
}
diff --git a/generic/tclResult.c b/generic/tclResult.c
index 9707f20..07f6819 100644
--- a/generic/tclResult.c
+++ b/generic/tclResult.c
@@ -1587,7 +1587,7 @@ Tcl_GetReturnOptions(
}
if (result == TCL_ERROR) {
- Tcl_AddObjErrorInfo(interp, "", -1);
+ Tcl_AddErrorInfo(interp, "");
Tcl_DictObjPut(NULL, options, keys[KEY_ERRORSTACK], iPtr->errorStack);
}
if (iPtr->errorCode) {
diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c
index 04cf4ee..e495c2e 100644
--- a/generic/tclStringObj.c
+++ b/generic/tclStringObj.c
@@ -140,9 +140,9 @@ typedef struct String {
#define stringAttemptRealloc(ptr, numChars) \
(String *) attemptckrealloc((ptr), (unsigned) STRING_SIZE(numChars) )
#define GET_STRING(objPtr) \
- ((String *) (objPtr)->internalRep.otherValuePtr)
+ ((String *) (objPtr)->internalRep.twoPtrValue.ptr1)
#define SET_STRING(objPtr, stringPtr) \
- ((objPtr)->internalRep.otherValuePtr = (void *) (stringPtr))
+ ((objPtr)->internalRep.twoPtrValue.ptr1 = (void *) (stringPtr))
/*
* TCL STRING GROWTH ALGORITHM
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index fc3f5fb..ce34c2f 100644
--- a/generic/tclStubInit.c
+++ b/generic/tclStubInit.c
@@ -54,6 +54,31 @@ static int TclSockMinimumBuffersOld(int sock, int size)
}
#endif
+#define TclSetStartupScriptPath setStartupScriptPath
+static void TclSetStartupScriptPath(Tcl_Obj *path)
+{
+ Tcl_SetStartupScript(path, NULL);
+}
+#define TclGetStartupScriptPath getStartupScriptPath
+static Tcl_Obj *TclGetStartupScriptPath(void)
+{
+ return Tcl_GetStartupScript(NULL);
+}
+#define TclSetStartupScriptFileName setStartupScriptFileName
+static void TclSetStartupScriptFileName(
+ const char *fileName)
+{
+ Tcl_SetStartupScript(Tcl_NewStringObj(fileName,-1), NULL);
+}
+#define TclGetStartupScriptFileName getStartupScriptFileName
+static const char *TclGetStartupScriptFileName(void)
+{
+ Tcl_Obj *path = Tcl_GetStartupScript(NULL);
+ if (path == NULL) {
+ return NULL;
+ }
+ return Tcl_GetStringFromObj(path, NULL);
+}
#if defined(_WIN32) || defined(__CYGWIN__)
#undef TclWinNToHS
@@ -348,8 +373,8 @@ static const TclIntStubs tclIntStubs = {
0, /* 155 */
TclRegError, /* 156 */
TclVarTraceExists, /* 157 */
- 0, /* 158 */
- 0, /* 159 */
+ TclSetStartupScriptFileName, /* 158 */
+ TclGetStartupScriptFileName, /* 159 */
0, /* 160 */
TclChannelTransform, /* 161 */
TclChannelEventScriptInvoker, /* 162 */
@@ -357,8 +382,8 @@ static const TclIntStubs tclIntStubs = {
TclExpandCodeArray, /* 164 */
TclpSetInitialEncodings, /* 165 */
TclListObjSetElement, /* 166 */
- 0, /* 167 */
- 0, /* 168 */
+ TclSetStartupScriptPath, /* 167 */
+ TclGetStartupScriptPath, /* 168 */
TclpUtfNcmp2, /* 169 */
TclCheckInterpTraces, /* 170 */
TclCheckExecutionTraces, /* 171 */
@@ -368,8 +393,8 @@ static const TclIntStubs tclIntStubs = {
TclCallVarTraces, /* 175 */
TclCleanupVar, /* 176 */
TclVarErrMsg, /* 177 */
- 0, /* 178 */
- 0, /* 179 */
+ Tcl_SetStartupScript, /* 178 */
+ Tcl_GetStartupScript, /* 179 */
0, /* 180 */
0, /* 181 */
TclpLocaltime, /* 182 */
diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c
index 4bddc42..f36b07f 100644
--- a/generic/tclTestObj.c
+++ b/generic/tclTestObj.c
@@ -555,7 +555,7 @@ TestindexobjCmd(
}
Tcl_GetIndexFromObj(NULL, objv[1], tablePtr, "token", 0, &index);
- indexRep = objv[1]->internalRep.otherValuePtr;
+ indexRep = objv[1]->internalRep.twoPtrValue.ptr1;
indexRep->index = index2;
result = Tcl_GetIndexFromObj(NULL, objv[1],
tablePtr, "token", 0, &index);
@@ -592,7 +592,7 @@ TestindexobjCmd(
if (objv[3]->typePtr != NULL
&& !strcmp("index", objv[3]->typePtr->name)) {
- indexRep = objv[3]->internalRep.otherValuePtr;
+ indexRep = objv[3]->internalRep.twoPtrValue.ptr1;
if (indexRep->tablePtr == (void *) argv) {
TclFreeIntRep(objv[3]);
}
@@ -1250,7 +1250,7 @@ TeststringobjCmd(
if (varPtr[varIndex] != NULL) {
Tcl_ConvertToType(NULL, varPtr[varIndex],
Tcl_GetObjType("string"));
- strPtr = varPtr[varIndex]->internalRep.otherValuePtr;
+ strPtr = varPtr[varIndex]->internalRep.twoPtrValue.ptr1;
length = (int) strPtr->allocated;
} else {
length = -1;
@@ -1304,7 +1304,7 @@ TeststringobjCmd(
if (varPtr[varIndex] != NULL) {
Tcl_ConvertToType(NULL, varPtr[varIndex],
Tcl_GetObjType("string"));
- strPtr = varPtr[varIndex]->internalRep.otherValuePtr;
+ strPtr = varPtr[varIndex]->internalRep.twoPtrValue.ptr1;
length = strPtr->maxChars;
} else {
length = -1;
diff --git a/generic/tclThreadTest.c b/generic/tclThreadTest.c
index b90e33d..8708f9a 100644
--- a/generic/tclThreadTest.c
+++ b/generic/tclThreadTest.c
@@ -926,10 +926,11 @@ ThreadSend(
ckfree(resultPtr->errorInfo);
}
}
- Tcl_SetResult(interp, resultPtr->result, TCL_DYNAMIC);
+ Tcl_AppendResult(interp, resultPtr->result, NULL);
Tcl_ConditionFinalize(&resultPtr->done);
code = resultPtr->code;
+ ckfree(resultPtr->result);
ckfree(resultPtr);
return code;
diff --git a/generic/tclTrace.c b/generic/tclTrace.c
index 61bac9b..a8bb92d 100644
--- a/generic/tclTrace.c
+++ b/generic/tclTrace.c
@@ -1322,7 +1322,7 @@ TraceCommandProc(
Tcl_DStringLength(&cmd), 0);
if (code != TCL_OK) {
/* We ignore errors in these traced commands */
- /*** QUESTION: Use Tcl_BackgroundError(interp); instead? ***/
+ /*** QUESTION: Use Tcl_BackgroundException(interp, code); instead? ***/
}
Tcl_DStringFree(&cmd);
}
diff --git a/generic/tclVar.c b/generic/tclVar.c
index 9b8527c..befcc26 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -475,6 +475,9 @@ TclObjLookupVar(
if (part2) {
part2Ptr = Tcl_NewStringObj(part2, -1);
+ if (createPart2) {
+ Tcl_IncrRefCount(part2Ptr);
+ }
}
resPtr = TclObjLookupVarEx(interp, part1Ptr, part2Ptr,
@@ -487,6 +490,12 @@ TclObjLookupVar(
return resPtr;
}
+/*
+ * When createPart1 is 1, callers must IncrRefCount part1Ptr if they
+ * plan to DecrRefCount it.
+ * When createPart2 is 1, callers must IncrRefCount part2Ptr if they
+ * plan to DecrRefCount it.
+ */
Var *
TclObjLookupVarEx(
Tcl_Interp *interp, /* Interpreter to use for lookup. */
@@ -627,7 +636,9 @@ TclObjLookupVarEx(
part2 = newPart2 = part1Ptr->internalRep.twoPtrValue.ptr2;
if (newPart2) {
part2Ptr = Tcl_NewStringObj(newPart2, -1);
- Tcl_IncrRefCount(part2Ptr);
+ if (createPart2) {
+ Tcl_IncrRefCount(part2Ptr);
+ }
}
part1Ptr = part1Ptr->internalRep.twoPtrValue.ptr1;
typePtr = part1Ptr->typePtr;
@@ -673,7 +684,9 @@ TclObjLookupVarEx(
*(newPart2+len2) = '\0';
part2 = newPart2;
part2Ptr = Tcl_NewStringObj(newPart2, -1);
- Tcl_IncrRefCount(part2Ptr);
+ if (createPart2) {
+ Tcl_IncrRefCount(part2Ptr);
+ }
/*
* Free the internal rep of the original part1Ptr, now renamed
@@ -1083,6 +1096,8 @@ TclLookupSimpleVar(
* The variable at arrayPtr may be converted to be an array if
* createPart1 is 1. A new hashtable entry may be created if createPart2
* is 1.
+ * When createElem is 1, callers must incr elNamePtr if they plan
+ * to decr it.
*
*----------------------------------------------------------------------
*/
@@ -1217,11 +1232,9 @@ Tcl_GetVar(
* TCL_NAMESPACE_ONLY or TCL_LEAVE_ERR_MSG
* bits. */
{
- Tcl_Obj *varNamePtr, *resultPtr;
+ Tcl_Obj *varNamePtr = Tcl_NewStringObj(varName, -1);
+ Tcl_Obj *resultPtr = Tcl_ObjGetVar2(interp, varNamePtr, NULL, flags);
- varNamePtr = Tcl_NewStringObj(varName, -1);
- Tcl_IncrRefCount(varNamePtr);
- resultPtr = Tcl_ObjGetVar2(interp, varNamePtr, NULL, flags);
TclDecrRefCount(varNamePtr);
if (resultPtr == NULL) {
@@ -1265,15 +1278,12 @@ Tcl_GetVar2(
* TCL_NAMESPACE_ONLY and TCL_LEAVE_ERR_MSG *
* bits. */
{
- Tcl_Obj *resultPtr, *part1Ptr, *part2Ptr;
+ Tcl_Obj *resultPtr;
+ Tcl_Obj *part2Ptr = NULL, *part1Ptr = Tcl_NewStringObj(part1, -1);
- part1Ptr = Tcl_NewStringObj(part1, -1);
- Tcl_IncrRefCount(part1Ptr);
if (part2) {
part2Ptr = Tcl_NewStringObj(part2, -1);
Tcl_IncrRefCount(part2Ptr);
- } else {
- part2Ptr = NULL;
}
resultPtr = Tcl_ObjGetVar2(interp, part1Ptr, part2Ptr, flags);
@@ -1326,6 +1336,7 @@ Tcl_GetVar2Ex(
if (part2) {
part2Ptr = Tcl_NewStringObj(part2, -1);
+ Tcl_IncrRefCount(part2Ptr);
}
resPtr = Tcl_ObjGetVar2(interp, part1Ptr, part2Ptr, flags);
@@ -1358,6 +1369,8 @@ Tcl_GetVar2Ex(
* the returned reference; if you want to keep a reference to the object
* you must increment its ref count yourself.
*
+ * Callers must incr part2Ptr if they plan to decr it.
+ *
*----------------------------------------------------------------------
*/
@@ -1563,17 +1576,13 @@ Tcl_SetVar(
* TCL_APPEND_VALUE, TCL_LIST_ELEMENT,
* TCL_LEAVE_ERR_MSG. */
{
- Tcl_Obj *valuePtr, *varNamePtr, *varValuePtr;
+ Tcl_Obj *varValuePtr, *varNamePtr = Tcl_NewStringObj(varName, -1);
- varNamePtr = Tcl_NewStringObj(varName, -1);
Tcl_IncrRefCount(varNamePtr);
- valuePtr = Tcl_NewStringObj(newValue, -1);
- Tcl_IncrRefCount(valuePtr);
-
- varValuePtr = Tcl_ObjSetVar2(interp, varNamePtr, NULL, valuePtr, flags);
-
+ varValuePtr = Tcl_ObjSetVar2(interp, varNamePtr, NULL,
+ Tcl_NewStringObj(newValue, -1), flags);
Tcl_DecrRefCount(varNamePtr);
- Tcl_DecrRefCount(valuePtr);
+
if (varValuePtr == NULL) {
return NULL;
}
@@ -1721,6 +1730,7 @@ Tcl_SetVar2Ex(
* The value of the given variable is set. If either the array or the
* entry didn't exist then a new variable is created.
* Callers must Incr part1Ptr if they plan to Decr it.
+ * Callers must Incr part2Ptr if they plan to Decr it.
*
*----------------------------------------------------------------------
*/
@@ -2011,6 +2021,7 @@ TclPtrSetVar(
* incremented to reflect the returned reference; if you want to keep a
* reference to the object you must increment its ref count yourself.
* Callers must Incr part1Ptr if they plan to Decr it.
+ * Callers must Incr part2Ptr if they plan to Decr it.
*
*----------------------------------------------------------------------
*/
@@ -2036,8 +2047,8 @@ TclIncrObjVar2(
varPtr = TclObjLookupVarEx(interp, part1Ptr, part2Ptr, flags, "read",
1, 1, &arrayPtr);
if (varPtr == NULL) {
- Tcl_AddObjErrorInfo(interp,
- "\n (reading value of variable to increment)", -1);
+ Tcl_AddErrorInfo(interp,
+ "\n (reading value of variable to increment)");
return NULL;
}
return TclPtrIncrObjVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr,
@@ -5108,7 +5119,8 @@ ParseSearchId(
* Parse the id.
*/
- if (Tcl_ConvertToType(interp, handleObj, &tclArraySearchType) != TCL_OK) {
+ if ((handleObj->typePtr != &tclArraySearchType)
+ && (SetArraySearchObj(interp, handleObj) != TCL_OK)) {
return NULL;
}
diff --git a/generic/tclZlib.c b/generic/tclZlib.c
index 9c1176e..ff887c8 100644
--- a/generic/tclZlib.c
+++ b/generic/tclZlib.c
@@ -3111,7 +3111,7 @@ ZlibTransformOutput(
e = deflate(&cd->outStream, Z_NO_FLUSH);
produced = cd->outAllocated - cd->outStream.avail_out;
- if (e == Z_OK && cd->outStream.avail_out > 0) {
+ if (e == Z_OK && produced > 0) {
if (Tcl_WriteRaw(cd->parent, cd->outBuffer, produced) < 0) {
*errorCodePtr = Tcl_GetErrno();
return -1;
@@ -3865,7 +3865,7 @@ TclZlibInit(
cfg[0].key = "zlibVersion";
cfg[0].value = zlibVersion();
cfg[1].key = NULL;
- Tcl_RegisterConfig(interp, "zlib", cfg, "ascii");
+ Tcl_RegisterConfig(interp, "zlib", cfg, "iso8859-1");
/*
* Formally provide the package as a Tcl built-in.
diff --git a/library/auto.tcl b/library/auto.tcl
index 4bd860d..e86257e 100644
--- a/library/auto.tcl
+++ b/library/auto.tcl
@@ -20,8 +20,9 @@
# None.
proc auto_reset {} {
- if {[array exists ::auto_index]} {
- foreach cmdName [array names ::auto_index] {
+ global auto_execs auto_index auto_path
+ if {[array exists auto_index]} {
+ foreach cmdName [array names auto_index] {
set fqcn [namespace which $cmdName]
if {$fqcn eq ""} {
continue
@@ -29,11 +30,11 @@ proc auto_reset {} {
rename $fqcn {}
}
}
- unset -nocomplain ::auto_execs ::auto_index ::tcl::auto_oldpath
- if {[catch {llength $::auto_path}]} {
- set ::auto_path [list [info library]]
- } elseif {[info library] ni $::auto_path} {
- lappend ::auto_path [info library]
+ unset -nocomplain auto_execs auto_index ::tcl::auto_oldpath
+ if {[catch {llength $auto_path}]} {
+ set auto_path [list [info library]]
+ } elseif {[info library] ni $auto_path} {
+ lappend auto_path [info library]
}
}
@@ -53,7 +54,7 @@ proc auto_reset {} {
proc tcl_findLibrary {basename version patch initScript enVarName varName} {
upvar #0 $varName the_library
- global env
+ global auto_path env tcl_platform
set dirs {}
set errors {}
@@ -83,12 +84,10 @@ proc tcl_findLibrary {basename version patch initScript enVarName varName} {
# 3. Relative to auto_path directories. This checks relative to the
# Tcl library as well as allowing loading of libraries added to the
# auto_path that is not relative to the core library or binary paths.
- foreach d $::auto_path {
+ foreach d $auto_path {
lappend dirs [file join $d $basename$version]
- if {
- $::tcl_platform(platform) eq "unix"
- && $::tcl_platform(os) eq "Darwin"
- } then {
+ if {$tcl_platform(platform) eq "unix"
+ && $tcl_platform(os) eq "Darwin"} {
# 4. On MacOSX, check the Resources/Scripts subdir too
lappend dirs [file join $d $basename$version Resources Scripts]
}
diff --git a/library/http/http.tcl b/library/http/http.tcl
index 01bf772..ddf066e 100644
--- a/library/http/http.tcl
+++ b/library/http/http.tcl
@@ -537,11 +537,10 @@ proc http::geturl {url args} {
# If a timeout is specified we set up the after event and arrange for an
# asynchronous socket connection.
- set sockopts [list]
+ set sockopts [list -async]
if {$state(-timeout) > 0} {
set state(after) [after $state(-timeout) \
[list http::reset $token timeout]]
- lappend sockopts -async
}
# If we are using the proxy, we must pass in the full URL that includes
@@ -597,10 +596,15 @@ proc http::geturl {url args} {
set socketmap($state(socketinfo)) $sock
}
- # Wait for the connection to complete.
+ if {![info exists phost]} {
+ set phost ""
+ }
+ fileevent $sock writable [list http::Connect $token $proto $phost $srvurl]
- if {$state(-timeout) > 0} {
- fileevent $sock writable [list http::Connect $token]
+ # Wait for the connection to complete.
+ if {![info exists state(-command)]} {
+ # geturl does EVERYTHING asynchronously, so if the user
+ # calls it synchronously, we just do a wait here.
http::wait $token
if {![info exists state]} {
@@ -616,13 +620,29 @@ proc http::geturl {url args} {
set err [lindex $state(error) 0]
cleanup $token
return -code error $err
- } elseif {$state(status) ne "connect"} {
- # Likely to be connection timeout
- return $token
}
- set state(status) ""
}
+ return $token
+}
+
+
+proc http::Connected { token proto phost srvurl} {
+ variable http
+ variable urlTypes
+
+ variable $token
+ upvar 0 $token state
+
+ # Set back the variables needed here
+ set sock $state(sock)
+ set isQueryChannel [info exists state(-querychannel)]
+ set isQuery [info exists state(-query)]
+ set host [lindex [split $state(socketinfo) :] 0]
+ set port [lindex [split $state(socketinfo) :] 1]
+
+ set defport [lindex $urlTypes($proto) 0]
+
# Send data in cr-lf format, but accept any line terminators
fconfigure $sock -translation {auto crlf} -buffersize $state(-blocksize)
@@ -753,35 +773,17 @@ proc http::geturl {url args} {
fileevent $sock readable [list http::Event $sock $token]
}
- if {![info exists state(-command)]} {
- # geturl does EVERYTHING asynchronously, so if the user calls it
- # synchronously, we just do a wait here.
-
- wait $token
- if {$state(status) eq "error"} {
- # Something went wrong, so throw the exception, and the
- # enclosing catch will do cleanup.
- return -code error [lindex $state(error) 0]
- }
- }
} err]} {
# The socket probably was never connected, or the connection dropped
# later.
- # Clean up after events and such, but DON'T call the command callback
- # (if available) because we're going to throw an exception from here
- # instead.
-
# if state(status) is error, it means someone's already called Finish
# to do the above-described clean up.
if {$state(status) ne "error"} {
- Finish $token $err 1
+ Finish $token $err
}
- cleanup $token
- return -code error $err
}
- return $token
}
# Data access functions:
@@ -865,7 +867,7 @@ proc http::cleanup {token} {
# Sets the status of the connection, which unblocks
# the waiting geturl call
-proc http::Connect {token} {
+proc http::Connect {token proto phost srvurl} {
variable $token
upvar 0 $token state
set err "due to unexpected EOF"
@@ -873,10 +875,10 @@ proc http::Connect {token} {
[eof $state(sock)] ||
[set err [fconfigure $state(sock) -error]] ne ""
} {
- Finish $token "connect failed $err" 1
+ Finish $token "connect failed $err"
} else {
- set state(status) connect
fileevent $state(sock) writable {}
+ ::http::Connected $token $proto $phost $srvurl
}
return
}
diff --git a/library/init.tcl b/library/init.tcl
index e836df9..bedc06e 100644
--- a/library/init.tcl
+++ b/library/init.tcl
@@ -12,6 +12,7 @@
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
+# This test intentionally written in pre-7.5 Tcl
if {[info commands package] == ""} {
error "version mismatch: library\nscripts expect Tcl version 7.5b1 or later but the loaded version is\nonly [info patchlevel]"
}
@@ -116,9 +117,10 @@ namespace eval tcl {
if {(![interp issafe]) && ($tcl_platform(platform) eq "windows")} {
namespace eval tcl {
proc EnvTraceProc {lo n1 n2 op} {
- set x $::env($n2)
- set ::env($lo) $x
- set ::env([string toupper $lo]) $x
+ global env
+ set x $env($n2)
+ set env($lo) $x
+ set env([string toupper $lo]) $x
}
proc InitWinEnv {} {
global env tcl_platform
@@ -159,8 +161,8 @@ if {[interp issafe]} {
} else {
# Set up search for Tcl Modules (TIP #189).
# and setup platform specific unknown package handlers
- if {$::tcl_platform(os) eq "Darwin"
- && $::tcl_platform(platform) eq "unix"} {
+ if {$tcl_platform(os) eq "Darwin"
+ && $tcl_platform(platform) eq "unix"} {
package unknown {::tcl::tm::UnknownHandler \
{::tcl::MacOSXPkgUnknown ::tclPkgUnknown}}
} else {
@@ -233,14 +235,13 @@ if {[namespace which -command tclLog] eq ""} {
proc unknown args {
variable ::tcl::UnknownPending
- global auto_noexec auto_noload env tcl_interactive
+ global auto_noexec auto_noload env tcl_interactive errorInfo errorCode
-
- if {[info exists ::errorInfo]} {
- set savedErrorInfo $::errorInfo
+ if {[info exists errorInfo]} {
+ set savedErrorInfo $errorInfo
}
- if {[info exists ::errorCode]} {
- set savedErrorCode $::errorCode
+ if {[info exists errorCode]} {
+ set savedErrorCode $errorCode
}
set name [lindex $args 0]
@@ -271,9 +272,9 @@ proc unknown args {
unset -nocomplain ::errorCode
}
if {[info exists savedErrorInfo]} {
- set ::errorInfo $savedErrorInfo
+ set errorInfo $savedErrorInfo
} else {
- unset -nocomplain ::errorInfo
+ unset -nocomplain errorInfo
}
set code [catch {uplevel 1 $args} msg opts]
if {$code == 1} {
@@ -282,8 +283,8 @@ proc unknown args {
# Note the dependence on how Tcl_AddErrorInfo, etc.
# construct the stack trace.
#
- set errorInfo [dict get $opts -errorinfo]
- set errorCode [dict get $opts -errorcode]
+ set errInfo [dict get $opts -errorinfo]
+ set errCode [dict get $opts -errorcode]
set cinfo $args
if {[string bytelength $cinfo] > 150} {
set cinfo [string range $cinfo 0 150]
@@ -300,7 +301,7 @@ proc unknown args {
# and trim the extra contribution from the matching case
#
set expect "$msg\n while executing\n\"$cinfo"
- if {$errorInfo eq $expect} {
+ if {$errInfo eq $expect} {
#
# The stack has only the eval from the expanded command
# Do not generate any stack trace here.
@@ -315,18 +316,18 @@ proc unknown args {
#
set expect "\n invoked from within\n\"$cinfo"
set exlen [string length $expect]
- set eilen [string length $errorInfo]
+ set eilen [string length $errInfo]
set i [expr {$eilen - $exlen - 1}]
- set einfo [string range $errorInfo 0 $i]
+ set einfo [string range $errInfo 0 $i]
#
- # For now verify that $errorInfo consists of what we are about
+ # For now verify that $errInfo consists of what we are about
# to return plus what we expected to trim off.
#
- if {$errorInfo ne "$einfo$expect"} {
+ if {$errInfo ne "$einfo$expect"} {
error "Tcl bug: unexpected stack trace in \"unknown\"" {} \
- [list CORE UNKNOWN BADTRACE $einfo $expect $errorInfo]
+ [list CORE UNKNOWN BADTRACE $einfo $expect $errInfo]
}
- return -code error -errorcode $errorCode \
+ return -code error -errorcode $errCode \
-errorinfo $einfo $msg
} else {
dict incr opts -level
@@ -335,7 +336,7 @@ proc unknown args {
}
}
- if {([info level] == 1) && ([info script] eq "") \
+ if {([info level] == 1) && ([info script] eq "")
&& [info exists tcl_interactive] && $tcl_interactive} {
if {![info exists auto_noexec]} {
set new [auto_execok $name]
@@ -788,7 +789,7 @@ proc tcl::CopyDirectory {action src dest} {
lappend existing {*}[glob -nocomplain -directory $dest \
-type hidden * .*]
foreach s $existing {
- if {([file tail $s] ne ".") && ([file tail $s] ne "..")} {
+ if {[file tail $s] ni {. ..}} {
return -code error "error $action \"$src\" to\
\"$dest\": file already exists"
}
@@ -796,7 +797,7 @@ proc tcl::CopyDirectory {action src dest} {
}
} else {
if {[string first $nsrc $ndest] != -1} {
- set srclen [expr {[llength [file split $nsrc]] -1}]
+ set srclen [expr {[llength [file split $nsrc]] - 1}]
set ndest [lindex [file split $ndest] $srclen]
if {$ndest eq [file tail $nsrc]} {
return -code error "error $action \"$src\" to\
@@ -816,37 +817,9 @@ proc tcl::CopyDirectory {action src dest} {
[glob -nocomplain -directory $src -types hidden *]]
foreach s [lsort -unique $filelist] {
- if {([file tail $s] ne ".") && ([file tail $s] ne "..")} {
- file copy -force $s [file join $dest [file tail $s]]
+ if {[file tail $s] ni {. ..}} {
+ file copy -force -- $s [file join $dest [file tail $s]]
}
}
return
}
-
-# TIP 131
-if 0 {
-proc tcl::rmmadwiw {} {
- set magic {
- 42 83 fe f6 ff f8 f1 e5 c6 f9 eb fd ff fb f1 e5 cc f5 ec f5 e3 fd fe
- ff f5 fa f3 e1 c7 f9 f2 fd ff f9 fe f9 ed f4 fa f6 e6 f9 f2 e6 fd f9
- ff f9 f6 e6 fa fd ff fc fb fc f9 f1 ed
- }
- foreach mystic [lassign $magic tragic] {
- set comic [expr (0x$mystic ^ 0x$tragic) - 255 + 0x$tragic]
- append logic [format %x $comic]
- set tragic $mystic
- }
- binary format H* $logic
-}
-
-proc tcl::mathfunc::rmmadwiw {} {
- set age [expr {9*6}]
- set mind ""
- while {$age} {
- lappend mind [expr {$age%13}]
- set age [expr {$age/13}]
- }
- set matter [lreverse $mind]
- return [join $matter ""]
-}
-}
diff --git a/library/package.tcl b/library/package.tcl
index c30431c..52daa0e 100644
--- a/library/package.tcl
+++ b/library/package.tcl
@@ -395,9 +395,7 @@ proc pkg_mkIndex {args} {
foreach pkg [lsort [array names files]] {
set cmd {}
- foreach {name version} $pkg {
- break
- }
+ lassign $pkg name version
lappend cmd ::tcl::Pkg::Create -name $name -version $version
foreach spec [lsort -index 0 $files($pkg)] {
foreach {file type procs} $spec {
@@ -544,8 +542,7 @@ proc tclPkgUnknown {name args} {
# Don't add directories we've already seen, or ones already on the
# $use_path.
foreach dir [lrange $auto_path $index end] {
- if {![info exists tclSeenPath($dir)]
- && ([lsearch -exact $use_path $dir] == -1) } {
+ if {![info exists tclSeenPath($dir)] && ($dir ni $use_path)} {
lappend use_path $dir
}
}
@@ -628,8 +625,7 @@ proc tcl::MacOSXPkgUnknown {original name args} {
# Don't add directories we've already seen, or ones already on the
# $use_path.
foreach dir [lrange $auto_path $index end] {
- if {![info exists tclSeenPath($dir)]
- && ([lsearch -exact $use_path $dir] == -1) } {
+ if {![info exists tclSeenPath($dir)] && ($dir ni $use_path)} {
lappend use_path $dir
}
}
@@ -681,10 +677,7 @@ proc ::tcl::Pkg::Create {args} {
}
# Initialize parameters
- set opts(-name) {}
- set opts(-version) {}
- set opts(-source) {}
- set opts(-load) {}
+ array set opts {-name {} -version {} -source {} -load {}}
# process parameters
for {set i 0} {$i < $len} {incr i} {
@@ -732,14 +725,9 @@ proc ::tcl::Pkg::Create {args} {
# Handle -load and -source specs
foreach key {load source} {
foreach filespec $opts(-$key) {
- foreach {filename proclist} {{} {}} {
- break
- }
- foreach {filename proclist} $filespec {
- break
- }
-
- if {![llength $proclist]} {
+ lassign $filespec filename proclist
+
+ if { [llength $proclist] == 0 } {
set cmd "\[list $key \[file join \$dir [list $filename]\]\]"
lappend cmdList $cmd
} else {
diff --git a/library/platform/pkgIndex.tcl b/library/platform/pkgIndex.tcl
index 220a67b..b882e4f 100644
--- a/library/platform/pkgIndex.tcl
+++ b/library/platform/pkgIndex.tcl
@@ -1,3 +1,3 @@
-package ifneeded platform 1.0.10 [list source [file join $dir platform.tcl]]
+package ifneeded platform 1.0.11 [list source [file join $dir platform.tcl]]
package ifneeded platform::shell 1.1.4 [list source [file join $dir shell.tcl]]
diff --git a/library/platform/platform.tcl b/library/platform/platform.tcl
index dd2e66b..a1a728b 100644
--- a/library/platform/platform.tcl
+++ b/library/platform/platform.tcl
@@ -256,7 +256,7 @@ proc ::platform::LibcVersion {base _->_ vv} {
if {![catch {
set vdata [lindex [split [exec $libc] \n] 0]
}]} {
- regexp {([0-9]+(\.[0-9]+)*)} $vdata -> v
+ regexp {version ([0-9]+(\.[0-9]+)*), by} $vdata -> v
foreach {major minor} [split $v .] break
set v glibc${major}.${minor}
return 1
@@ -368,7 +368,7 @@ proc ::platform::patterns {id} {
# ### ### ### ######### ######### #########
## Ready
-package provide platform 1.0.10
+package provide platform 1.0.11
# ### ### ### ######### ######### #########
## Demo application
diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl
index 83ec9d3..d6e6487 100644
--- a/library/tcltest/tcltest.tcl
+++ b/library/tcltest/tcltest.tcl
@@ -84,7 +84,7 @@ namespace eval tcltest {
# None.
#
proc normalizePath {pathVar} {
- upvar $pathVar path
+ upvar 1 $pathVar path
set oldpwd [pwd]
catch {cd $path}
set path [pwd]
@@ -247,15 +247,15 @@ namespace eval tcltest {
# Kept only for compatibility
Default constraintsSpecified {} AcceptList
- trace variable constraintsSpecified r {set ::tcltest::constraintsSpecified \
- [array names ::tcltest::testConstraints] ;# }
+ trace add variable constraintsSpecified read [namespace code {
+ set constraintsSpecified [array names testConstraints] ;#}]
# tests that use threads need to know which is the main thread
Default mainThread 1
variable mainThread
- if {[info commands thread::id] != {}} {
+ if {[info commands thread::id] ne {}} {
set mainThread [thread::id]
- } elseif {[info commands testthread] != {}} {
+ } elseif {[info commands testthread] ne {}} {
set mainThread [testthread id]
}
@@ -263,7 +263,7 @@ namespace eval tcltest {
# Tcl tests is the working directory. Whenever this value changes
# change to that directory.
variable workingDirectory
- trace variable workingDirectory w \
+ trace add variable workingDirectory write \
[namespace code {cd $workingDirectory ;#}]
Default workingDirectory [pwd] AcceptAbsolutePath
@@ -277,7 +277,7 @@ namespace eval tcltest {
# Set the location of the execuatble
Default tcltest [info nameofexecutable]
- trace variable tcltest w [namespace code {testConstraint stdio \
+ trace add variable tcltest write [namespace code {testConstraint stdio \
[eval [ConstraintInitializer stdio]] ;#}]
# save the platform information so it can be restored later
@@ -404,11 +404,11 @@ namespace eval tcltest {
# already there.
set outdir [normalizePath [file dirname \
[file join [pwd] $filename]]]
- if {[string equal $outdir [temporaryDirectory]]} {
+ if {$outdir eq [temporaryDirectory]} {
variable filesExisted
FillFilesExisted
set filename [file tail $filename]
- if {[lsearch -exact $filesExisted $filename] == -1} {
+ if {$filename ni $filesExisted} {
lappend filesExisted $filename
}
}
@@ -448,11 +448,11 @@ namespace eval tcltest {
# already there.
set outdir [normalizePath [file dirname \
[file join [pwd] $filename]]]
- if {[string equal $outdir [temporaryDirectory]]} {
+ if {$outdir eq [temporaryDirectory]} {
variable filesExisted
FillFilesExisted
set filename [file tail $filename]
- if {[lsearch -exact $filesExisted $filename] == -1} {
+ if {$filename ni $filesExisted} {
lappend filesExisted $filename
}
}
@@ -534,7 +534,7 @@ namespace eval tcltest {
}
default {
# Exact match trumps ambiguity
- if {[lsearch -exact $match $option] >= 0} {
+ if {$option in $match} {
return $option
}
set values [join [lrange $match 0 end-1] ", "]
@@ -549,7 +549,8 @@ namespace eval tcltest {
variable OptionControlledVariables
foreach varName [concat $OptionControlledVariables Option] {
variable $varName
- trace variable $varName r [namespace code {ProcessCmdLineArgs ;#}]
+ trace add variable $varName read [namespace code {
+ ProcessCmdLineArgs ;#}]
}
}
@@ -557,11 +558,11 @@ namespace eval tcltest {
variable OptionControlledVariables
foreach varName [concat $OptionControlledVariables Option] {
variable $varName
- foreach pair [trace vinfo $varName] {
- foreach {op cmd} $pair break
- if {[string equal r $op]
- && [string match *ProcessCmdLineArgs* $cmd]} {
- trace vdelete $varName $op $cmd
+ foreach pair [trace info variable $varName] {
+ lassign $pair op cmd
+ if {($op eq "read") &&
+ [string match *ProcessCmdLineArgs* $cmd]} {
+ trace remove variable $varName $op $cmd
}
}
}
@@ -698,7 +699,7 @@ namespace eval tcltest {
Option -constraints {} {
Do not skip the listed constraints listed in -constraints.
} AcceptList
- trace variable Option(-constraints) w \
+ trace add variable Option(-constraints) write \
[namespace code {SetSelectedConstraints ;#}]
# Don't run only the "-constraint" specified tests by default
@@ -707,7 +708,7 @@ namespace eval tcltest {
variable testConstraints
if {!$Option(-limitconstraints)} {return}
foreach c [array names testConstraints] {
- if {[lsearch -exact $Option(-constraints) $c] == -1} {
+ if {$c ni $Option(-constraints)} {
testConstraint $c 0
}
}
@@ -715,7 +716,7 @@ namespace eval tcltest {
Option -limitconstraints 0 {
whether to run only tests with the constraints
} AcceptBoolean limitConstraints
- trace variable Option(-limitconstraints) w \
+ trace add variable Option(-limitconstraints) write \
[namespace code {ClearUnselectedConstraints ;#}]
# A test application has to know how to load the tested commands
@@ -736,7 +737,7 @@ namespace eval tcltest {
}
set directory [AcceptDirectory $directory]
if {![file writable $directory]} {
- if {[string equal [workingDirectory] $directory]} {
+ if {[workingDirectory] eq $directory} {
# Special exception: accept the default value
# even if the directory is not writable
return $directory
@@ -750,7 +751,7 @@ namespace eval tcltest {
Option -tmpdir [workingDirectory] {
Save temporary files in the specified directory.
} AcceptTemporaryDirectory temporaryDirectory
- trace variable Option(-tmpdir) w \
+ trace add variable Option(-tmpdir) write \
[namespace code {normalizePath Option(-tmpdir) ;#}]
# Tests should not rely on the current working directory.
@@ -759,17 +760,17 @@ namespace eval tcltest {
Option -testdir [workingDirectory] {
Search tests in the specified directory.
} AcceptDirectory testsDirectory
- trace variable Option(-testdir) w \
+ trace add variable Option(-testdir) write \
[namespace code {normalizePath Option(-testdir) ;#}]
proc AcceptLoadFile { file } {
- if {[string equal "" $file]} {return $file}
+ if {$file eq {}} {return $file}
set file [file join [temporaryDirectory] $file]
return [AcceptReadable $file]
}
proc ReadLoadScript {args} {
variable Option
- if {[string equal "" $Option(-loadfile)]} {return}
+ if {$Option(-loadfile) eq {}} {return}
set tmp [open $Option(-loadfile) r]
loadScript [read $tmp]
close $tmp
@@ -777,7 +778,7 @@ namespace eval tcltest {
Option -loadfile {} {
Read the script to load the tested commands from the specified file.
} AcceptLoadFile loadFile
- trace variable Option(-loadfile) w [namespace code ReadLoadScript]
+ trace add variable Option(-loadfile) write [namespace code ReadLoadScript]
proc AcceptOutFile { file } {
if {[string equal stderr $file]} {return $file}
@@ -789,14 +790,14 @@ namespace eval tcltest {
Option -outfile stdout {
Send output from test runs to the specified file.
} AcceptOutFile outputFile
- trace variable Option(-outfile) w \
+ trace add variable Option(-outfile) write \
[namespace code {outputChannel $Option(-outfile) ;#}]
# errors go to stderr by default
Option -errfile stderr {
Send errors from test runs to the specified file.
} AcceptOutFile errorFile
- trace variable Option(-errfile) w \
+ trace add variable Option(-errfile) write \
[namespace code {errorChannel $Option(-errfile) ;#}]
proc loadIntoSlaveInterpreter {slave args} {
@@ -877,7 +878,7 @@ proc tcltest::DebugPArray {level arrayvar} {
variable debug
if {$debug >= $level} {
- catch {upvar $arrayvar $arrayvar}
+ catch {upvar 1 $arrayvar $arrayvar}
parray $arrayvar
}
return
@@ -961,8 +962,7 @@ proc tcltest::testConstraint {constraint {value ""}} {
if {[catch {expr {$value && $value}} msg]} {
return -code error $msg
}
- if {[limitConstraints]
- && [lsearch -exact $Option(-constraints) $constraint] == -1} {
+ if {[limitConstraints] && ($constraint ni $Option(-constraints))} {
set value 0
}
set testConstraints($constraint) $value
@@ -986,11 +986,7 @@ proc tcltest::interpreter { {interp ""} } {
if {[llength [info level 0]] == 1} {
return $tcltest
}
- if {[string equal {} $interp]} {
- set tcltest {}
- } else {
- set tcltest $interp
- }
+ set tcltest $interp
}
#####################################################################
@@ -1055,7 +1051,7 @@ proc tcltest::PrintError {errorMsg} {
[expr {80 - $InitialMsgLen}]]]
puts [errorChannel] [string range $errorMsg 0 $beginningIndex]
- while {![string equal end $beginningIndex]} {
+ while {$beginningIndex ne "end"} {
puts -nonewline [errorChannel] \
[string repeat " " $InitialMsgLen]
if {($endingIndex - $beginningIndex)
@@ -1108,7 +1104,7 @@ proc tcltest::PrintError {errorMsg} {
proc tcltest::SafeFetch {n1 n2 op} {
variable testConstraints
DebugPuts 3 "entering SafeFetch $n1 $n2 $op"
- if {[string equal {} $n2]} {return}
+ if {$n2 eq {}} {return}
if {![info exists testConstraints($n2)]} {
if {[catch {testConstraint $n2 [eval [ConstraintInitializer $n2]]}]} {
testConstraint $n2 0
@@ -1253,9 +1249,8 @@ proc tcltest::DefineConstraintInitializers {} {
# are running as root on Unix.
ConstraintInitializer root {expr \
- {[string equal unix $::tcl_platform(platform)]
- && ([string equal root $::tcl_platform(user)]
- || [string equal "" $::tcl_platform(user)])}}
+ {($::tcl_platform(platform) eq "unix") &&
+ ($::tcl_platform(user) in {root {}})}}
ConstraintInitializer notRoot {expr {![testConstraint root]}}
# Set nonBlockFiles constraint: 1 means this platform supports
@@ -1263,7 +1258,7 @@ proc tcltest::DefineConstraintInitializers {} {
ConstraintInitializer nonBlockFiles {
set code [expr {[catch {set f [open defs r]}]
- || [catch {fconfigure $f -blocking off}]}]
+ || [catch {chan configure $f -blocking off}]}]
catch {close $f}
set code
}
@@ -1289,10 +1284,10 @@ proc tcltest::DefineConstraintInitializers {} {
ConstraintInitializer unixExecs {
set code 1
- if {[string equal macintosh $::tcl_platform(platform)]} {
+ if {$::tcl_platform(platform) eq "macintosh"} {
set code 0
}
- if {[string equal windows $::tcl_platform(platform)]} {
+ if {$::tcl_platform(platform) eq "windows"} {
if {[catch {
set file _tcl_test_remove_me.txt
makeFile {hello} $file
@@ -1386,7 +1381,7 @@ proc tcltest::Usage { {option ""} } {
set allOpts [concat -help [Configure]]
foreach opt $allOpts {
set foo [Usage $opt]
- foreach [list x type($opt) usage($opt)] $foo break
+ lassign $foo x type($opt) usage($opt)
set line($opt) " $opt $type($opt) "
set length($opt) [string length $line($opt)]
if {$length($opt) > $max} {set max $length($opt)}
@@ -1410,7 +1405,7 @@ proc tcltest::Usage { {option ""} } {
append msg $u
}
return $msg\n
- } elseif {[string equal -help $option]} {
+ } elseif {$option eq "-help"} {
return [list -help "" "Display this usage information."]
} else {
set type [lindex [info args $Verify($option)] 0]
@@ -1436,7 +1431,7 @@ proc tcltest::Usage { {option ""} } {
proc tcltest::ProcessFlags {flagArray} {
# Process -help first
- if {[lsearch -exact $flagArray {-help}] != -1} {
+ if {"-help" in $flagArray} {
PrintUsageInfo
exit 1
}
@@ -1445,14 +1440,14 @@ proc tcltest::ProcessFlags {flagArray} {
RemoveAutoConfigureTraces
} else {
set args $flagArray
- while {[llength $args]>1 && [catch {configure {*}$args} msg]} {
+ while {[llength $args] > 1 && [catch {configure {*}$args} msg]} {
# Something went wrong parsing $args for tcltest options
# Check whether the problem is "unknown option"
if {[regexp {^unknown option (\S+):} $msg -> option]} {
# Could be this is an option the Hook knows about
set moreOptions [processCmdLineArgsAddFlagsHook]
- if {[lsearch -exact $moreOptions $option] == -1} {
+ if {$option ni $moreOptions} {
# Nope. Report the error, including additional options,
# but keep going
if {[llength $moreOptions]} {
@@ -1471,7 +1466,7 @@ proc tcltest::ProcessFlags {flagArray} {
# To recover, find that unknown option and remove up to it.
# then retry
- while {![string equal [lindex $args 0] $option]} {
+ while {[lindex $args 0] ne $option} {
set args [lrange $args 2 end]
}
set args [lrange $args 2 end]
@@ -1577,7 +1572,7 @@ proc tcltest::Replace::puts {args} {
}
2 {
# Either -nonewline or channelId has been specified
- if {[string equal -nonewline [lindex $args 0]]} {
+ if {[lindex $args 0] eq "-nonewline"} {
append outData [lindex $args end]
return
# return [Puts -nonewline [lindex $args end]]
@@ -1587,7 +1582,7 @@ proc tcltest::Replace::puts {args} {
}
}
3 {
- if {[string equal -nonewline [lindex $args 0]]} {
+ if {[lindex $args 0] eq "-nonewline"} {
# Both -nonewline and channelId are specified, unless
# it's an error. -nonewline is supposed to be argv[0].
set channel [lindex $args 1]
@@ -1597,12 +1592,10 @@ proc tcltest::Replace::puts {args} {
}
if {[info exists channel]} {
- if {[string equal $channel [[namespace parent]::outputChannel]]
- || [string equal $channel stdout]} {
+ if {$channel in [list [[namespace parent]::outputChannel] stdout]} {
append outData [lindex $args end]$newline
return
- } elseif {[string equal $channel [[namespace parent]::errorChannel]]
- || [string equal $channel stderr]} {
+ } elseif {$channel in [list [[namespace parent]::errorChannel] stderr]} {
append errData [lindex $args end]$newline
return
}
@@ -1771,7 +1764,7 @@ proc tcltest::SubstArguments {argList} {
set argList {}
}
- if {$token != {}} {
+ if {$token ne {}} {
# If we saw a word with quote before, then there is a
# multi-word token starting with that word. In this case,
# add the text and the current word to this token.
@@ -1878,10 +1871,7 @@ proc tcltest::test {name description args} {
# Pre-define everything to null except output and errorOutput. We
# determine whether or not to trap output based on whether or not
# these variables (output & errorOutput) are defined.
- foreach item {constraints setup cleanup body result returnCodes
- match} {
- set $item {}
- }
+ lassign {} constraints setup cleanup body result returnCodes match
# Set the default match mode
set match exact
@@ -1893,8 +1883,7 @@ proc tcltest::test {name description args} {
# The old test format can't have a 3rd argument (constraints or
# script) that starts with '-'.
- if {[string match -* [lindex $args 0]]
- || ([llength $args] <= 1)} {
+ if {[string match -* [lindex $args 0]] || ([llength $args] <= 1)} {
if {[llength $args] == 1} {
set list [SubstArguments [lindex $args 0]]
foreach {element value} $list {
@@ -1915,7 +1904,7 @@ proc tcltest::test {name description args} {
-match -output -errorOutput -constraints}
foreach flag [array names testAttributes] {
- if {[lsearch -exact $validFlags $flag] == -1} {
+ if {$flag ni $validFlags} {
incr testLevel -1
set sorted [lsort $validFlags]
set options [join [lrange $sorted 0 end-1] ", "]
@@ -1931,7 +1920,7 @@ proc tcltest::test {name description args} {
# Check the values supplied for -match
variable CustomMatch
- if {[lsearch [array names CustomMatch] $match] == -1} {
+ if {$match ni [array names CustomMatch]} {
incr testLevel -1
set sorted [lsort [array names CustomMatch]]
set values [join [lrange $sorted 0 end-1] ", "]
@@ -1995,7 +1984,7 @@ proc tcltest::test {name description args} {
} else {
set testResult [uplevel 1 [list [namespace origin Eval] $command 1]]
}
- foreach {actualAnswer returnCode} $testResult break
+ lassign $testResult actualAnswer returnCode
if {$returnCode == 1} {
set errorInfo(body) $::errorInfo
set errorCode(body) $::errorCode
@@ -2031,11 +2020,11 @@ proc tcltest::test {name description args} {
if {([preserveCore] > 1) && ($coreFailure)} {
append coreMsg "\nMoving file to:\
[file join [temporaryDirectory] core-$name]"
- catch {file rename -force \
+ catch {file rename -force -- \
[file join [workingDirectory] core] \
[file join [temporaryDirectory] core-$name]
} msg
- if {[string length $msg] > 0} {
+ if {$msg ne {}} {
append coreMsg "\nError:\
Problem renaming core file: $msg"
}
@@ -2045,7 +2034,7 @@ proc tcltest::test {name description args} {
# check if the return code matched the expected return code
set codeFailure 0
- if {!$setupFailure && [lsearch -exact $returnCodes $returnCode] == -1} {
+ if {!$setupFailure && ($returnCode ni $returnCodes)} {
set codeFailure 1
}
@@ -2124,7 +2113,7 @@ proc tcltest::test {name description args} {
set testFd [open $testFile r]
set testLine [expr {[lsearch -regexp \
[split [read $testFd] "\n"] \
- "^\[ \t\]*test [string map {. \\.} $name] "]+1}]
+ "^\[ \t\]*test [string map {. \\.} $name] "] + 1}]
close $testFd
}
}
@@ -2169,7 +2158,7 @@ proc tcltest::test {name description args} {
puts [outputChannel] "---- Return code should have been\
one of: $returnCodes"
if {[IsVerbose error]} {
- if {[info exists errorInfo(body)] && ([lsearch $returnCodes 1]<0)} {
+ if {[info exists errorInfo(body)] && (1 ni $returnCodes)} {
puts [outputChannel] "---- errorInfo: $errorInfo(body)"
puts [outputChannel] "---- errorCode: $errorCode(body)"
}
@@ -2250,7 +2239,7 @@ proc tcltest::Skipped {name constraints} {
}
return 1
}
- if {[string equal {} $constraints]} {
+ if {$constraints eq {}} {
# If we're limited to the listed constraints and there aren't
# any listed, then we shouldn't run the test.
if {[limitConstraints]} {
@@ -2401,7 +2390,7 @@ proc tcltest::cleanupTests {{calledFromAllFile 0}} {
foreach file $filesMade {
if {[file exists $file]} {
DebugDo 1 {Warn "cleanupTests deleting $file..."}
- catch {file delete -force $file}
+ catch {file delete -force -- $file}
}
}
set currentFiles {}
@@ -2411,7 +2400,7 @@ proc tcltest::cleanupTests {{calledFromAllFile 0}} {
}
set newFiles {}
foreach file $currentFiles {
- if {[lsearch -exact $filesExisted $file] == -1} {
+ if {$file ni $filesExisted} {
lappend newFiles $file
}
}
@@ -2494,8 +2483,7 @@ proc tcltest::cleanupTests {{calledFromAllFile 0}} {
# then add current file to failFile list if any tests in this
# file failed
- if {$currentFailure \
- && ([lsearch -exact $failFiles $testFileName] == -1)} {
+ if {$currentFailure && ($testFileName ni $failFiles)} {
lappend failFiles $testFileName
}
set currentFailure false
@@ -2555,11 +2543,11 @@ proc tcltest::cleanupTests {{calledFromAllFile 0}} {
puts [outputChannel] "produced core file! \
Moving file to: \
[file join [temporaryDirectory] core-$testFileName]"
- catch {file rename -force \
+ catch {file rename -force -- \
[file join [workingDirectory] core] \
[file join [temporaryDirectory] core-$testFileName]
} msg
- if {[string length $msg] > 0} {
+ if {$msg ne {}} {
PrintError "Problem renaming file: $msg"
}
} else {
@@ -2637,7 +2625,7 @@ proc tcltest::GetMatchingFiles { args } {
# Add to result list all files in match list and not in skip list
foreach file $matchFileList {
- if {[lsearch -exact $skipFileList $file] == -1} {
+ if {$file ni $skipFileList} {
lappend matchingFiles $file
}
}
@@ -2684,7 +2672,7 @@ proc tcltest::GetMatchingDirectories {rootdir} {
foreach pattern [matchDirectories] {
foreach path [glob -directory $rootdir -types d -nocomplain -- \
$pattern] {
- if {[lsearch -exact $skipDirs $path] == -1} {
+ if {$path ni $skipDirs} {
set matchDirs [concat $matchDirs [GetMatchingDirectories $path]]
if {[file exists [file join $path all.tcl]]} {
lappend matchDirs $path
@@ -2737,7 +2725,7 @@ proc tcltest::runAllTests { {shell ""} } {
# [file system] first available in Tcl 8.4
if {![catch {file system [testsDirectory]} result]
- && ![string equal native [lindex $result 0]]} {
+ && ([lindex $result 0] ne "native")} {
# If we aren't running in the native filesystem, then we must
# run the tests in a single process (via 'source'), because
# trying to run then via a pipe will fail since the files don't
@@ -2784,10 +2772,10 @@ proc tcltest::runAllTests { {shell ""} } {
# needs to read and process output of children.
set childargv [list]
foreach opt [Configure] {
- if {[string equal $opt -outfile]} {continue}
+ if {$opt eq "-outfile"} {continue}
set value [Configure $opt]
# Don't bother passing default configuration options
- if {[string equal $value $DefaultValue($opt)]} {
+ if {$value eq $DefaultValue($opt)} {
continue
}
lappend childargv $opt $value
@@ -2880,11 +2868,6 @@ proc tcltest::runAllTests { {shell ""} } {
# none.
proc tcltest::loadTestedCommands {} {
- variable l
- if {[string equal {} [loadScript]]} {
- return
- }
-
return [uplevel 1 [loadScript]]
}
@@ -2927,16 +2910,15 @@ proc tcltest::saveState {} {
proc tcltest::restoreState {} {
variable saveState
foreach p [uplevel 1 {::info procs}] {
- if {([lsearch [lindex $saveState 0] $p] < 0)
- && ![string equal [namespace current]::$p \
- [uplevel 1 [list ::namespace origin $p]]]} {
+ if {($p ni [lindex $saveState 0]) && ("[namespace current]::$p" ne
+ [uplevel 1 [list ::namespace origin $p]])} {
DebugPuts 2 "[lindex [info level 0] 0]: Removing proc $p"
uplevel 1 [list ::catch [list ::rename $p {}]]
}
}
foreach p [uplevel 1 {::info vars}] {
- if {[lsearch [lindex $saveState 1] $p] < 0} {
+ if {$p ni [lindex $saveState 1]} {
DebugPuts 2 "[lindex [info level 0] 0]:\
Removing variable $p"
uplevel 1 [list ::catch [list ::unset $p]]
@@ -2997,15 +2979,15 @@ proc tcltest::makeFile {contents name {directory ""}} {
putting ``$contents'' into $fullName"
set fd [open $fullName w]
- fconfigure $fd -translation lf
- if {[string equal [string index $contents end] \n]} {
+ chan configure $fd -translation lf
+ if {[string index $contents end] eq "\n"} {
puts -nonewline $fd $contents
} else {
puts $fd $contents
}
close $fd
- if {[lsearch -exact $filesMade $fullName] == -1} {
+ if {$fullName ni $filesMade} {
lappend filesMade $fullName
}
return $fullName
@@ -3045,7 +3027,7 @@ proc tcltest::removeFile {name {directory ""}} {
Warn "removeFile removing \"$fullName\":\n not a file"
}
}
- return [file delete $fullName]
+ return [file delete -- $fullName]
}
# tcltest::makeDirectory --
@@ -3075,7 +3057,7 @@ proc tcltest::makeDirectory {name {directory ""}} {
set fullName [file join $directory $name]
DebugPuts 3 "[lindex [info level 0] 0]: creating $fullName"
file mkdir $fullName
- if {[lsearch -exact $filesMade $fullName] == -1} {
+ if {$fullName ni $filesMade} {
lappend filesMade $fullName
}
return $fullName
@@ -3116,7 +3098,7 @@ proc tcltest::removeDirectory {name {directory ""}} {
Warn "removeDirectory removing \"$fullName\":\n not a directory"
}
}
- return [file delete -force $fullName]
+ return [file delete -force -- $fullName]
}
# tcltest::viewFile --
@@ -3213,7 +3195,7 @@ proc tcltest::LeakFiles {old} {
}
set leak {}
foreach p $new {
- if {[lsearch $old $p] < 0} {
+ if {$p ni $old} {
lappend leak $p
}
}
@@ -3284,7 +3266,7 @@ proc tcltest::RestoreLocale {} {
#
proc tcltest::threadReap {} {
- if {[info commands testthread] != {}} {
+ if {[info commands testthread] ne {}} {
# testthread built into tcltest
@@ -3304,7 +3286,7 @@ proc tcltest::threadReap {} {
}
testthread errorproc ThreadError
return [llength [testthread names]]
- } elseif {[info commands thread::id] != {}} {
+ } elseif {[info commands thread::id] ne {}} {
# Thread extension
@@ -3336,15 +3318,15 @@ namespace eval tcltest {
# Set up the constraints in the testConstraints array to be lazily
# initialized by a registered initializer, or by "false" if no
# initializer is registered.
- trace variable testConstraints r [namespace code SafeFetch]
+ trace add variable testConstraints read [namespace code SafeFetch]
# Only initialize constraints at package load time if an
# [initConstraintsHook] has been pre-defined. This is only
# for compatibility support. The modern way to add a custom
# test constraint is to just call the [testConstraint] command
# straight away, without all this "hook" nonsense.
- if {[string equal [namespace current] \
- [namespace qualifiers [namespace which initConstraintsHook]]]} {
+ if {[namespace current] eq
+ [namespace qualifiers [namespace which initConstraintsHook]]} {
InitConstraints
} else {
proc initConstraintsHook {} {}
@@ -3381,15 +3363,15 @@ namespace eval tcltest {
proc LoadTimeCmdLineArgParsingRequired {} {
set required false
- if {[info exists ::argv] && [lsearch -exact $::argv -help] != -1} {
+ if {[info exists ::argv] && ("-help" in $::argv)} {
# The command line asks for -help, so give it (and exit)
# right now. ([configure] does not process -help)
set required true
}
foreach hook { PrintUsageInfoHook processCmdLineArgsHook
processCmdLineArgsAddFlagsHook } {
- if {[string equal [namespace current] [namespace qualifiers \
- [namespace which $hook]]]} {
+ if {[namespace current] eq
+ [namespace qualifiers [namespace which $hook]]} {
set required true
} else {
proc $hook args {}
diff --git a/library/tm.tcl b/library/tm.tcl
index ce8a013..d2af4f5 100644
--- a/library/tm.tcl
+++ b/library/tm.tcl
@@ -54,7 +54,7 @@ namespace eval ::tcl::tm {
# Export the public API
namespace export path
- namespace ensemble create -command path -subcommand {add remove list}
+ namespace ensemble create -command path -subcommands {add remove list}
}
# ::tcl::tm::path implementations --
@@ -260,10 +260,8 @@ proc ::tcl::tm::UnknownHandler {original name args} {
# Otherwise we still have to fallback to the regular
# package search to complete the processing.
- if {
- ($pkgname eq $name) &&
- [package vsatisfies $pkgversion {*}$args]
- } then {
+ if {($pkgname eq $name)
+ && [package vsatisfies $pkgversion {*}$args]} {
set satisfied 1
# We do not abort the loop, and keep adding provide
@@ -347,7 +345,7 @@ proc ::tcl::tm::Defaults {} {
# Calls 'path add' to paths to the list of module search paths.
proc ::tcl::tm::roots {paths} {
- foreach {major minor} [split [info tclversion] .] break
+ lassign [split [package present Tcl] .] major minor
foreach pa $paths {
set p [file join $pa tcl$major]
for {set n $minor} {$n >= 0} {incr n -1} {
diff --git a/library/word.tcl b/library/word.tcl
index 16a4638..b8f34a5 100644
--- a/library/word.tcl
+++ b/library/word.tcl
@@ -67,7 +67,7 @@ namespace eval ::tcl {
proc tcl_wordBreakAfter {str start} {
variable ::tcl::WordBreakRE
set result {-1 -1}
- regexp -indices -start $start $WordBreakRE(after) $str result
+ regexp -indices -start $start -- $WordBreakRE(after) $str result
return [lindex $result 1]
}
@@ -85,7 +85,7 @@ proc tcl_wordBreakAfter {str start} {
proc tcl_wordBreakBefore {str start} {
variable ::tcl::WordBreakRE
set result {-1 -1}
- regexp -indices $WordBreakRE(before) [string range $str 0 $start] result
+ regexp -indices -- $WordBreakRE(before) [string range $str 0 $start] result
return [lindex $result 1]
}
@@ -104,7 +104,7 @@ proc tcl_wordBreakBefore {str start} {
proc tcl_endOfWord {str start} {
variable ::tcl::WordBreakRE
set result {-1 -1}
- regexp -indices -start $start $WordBreakRE(end) $str result
+ regexp -indices -start $start -- $WordBreakRE(end) $str result
return [lindex $result 1]
}
@@ -122,7 +122,7 @@ proc tcl_endOfWord {str start} {
proc tcl_startOfNextWord {str start} {
variable ::tcl::WordBreakRE
set result {-1 -1}
- regexp -indices -start $start $WordBreakRE(next) $str result
+ regexp -indices -start $start -- $WordBreakRE(next) $str result
return [lindex $result 1]
}
@@ -138,7 +138,7 @@ proc tcl_startOfNextWord {str start} {
proc tcl_startOfPreviousWord {str start} {
variable ::tcl::WordBreakRE
set word {-1 -1}
- regexp -indices $WordBreakRE(previous) [string range $str 0 $start-1] \
+ regexp -indices -- $WordBreakRE(previous) [string range $str 0 $start-1] \
result word
return [lindex $word 0]
}
diff --git a/macosx/tclMacOSXFCmd.c b/macosx/tclMacOSXFCmd.c
index f266443..8ecfd0b 100644
--- a/macosx/tclMacOSXFCmd.c
+++ b/macosx/tclMacOSXFCmd.c
@@ -578,7 +578,7 @@ GetOSTypeFromObj(
int result = TCL_OK;
if (objPtr->typePtr != &tclOSTypeType) {
- result = tclOSTypeType.setFromAnyProc(interp, objPtr);
+ result = SetOSTypeFromAny(interp, objPtr);
}
*osTypePtr = (OSType) objPtr->internalRep.longValue;
return result;
@@ -608,7 +608,7 @@ NewOSTypeObj(
Tcl_Obj *objPtr;
TclNewObj(objPtr);
- Tcl_InvalidateStringRep(objPtr);
+ TclInvalidateStringRep(objPtr);
objPtr->internalRep.longValue = (long) osType;
objPtr->typePtr = &tclOSTypeType;
return objPtr;
diff --git a/tests/assocd.test b/tests/assocd.test
index d1489b3..b543c64 100644
--- a/tests/assocd.test
+++ b/tests/assocd.test
@@ -11,10 +11,8 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest
- namespace import -force ::tcltest::*
-}
+package require tcltest 2
+namespace import ::tcltest::*
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
@@ -60,5 +58,5 @@ test assocd-3.3 {testing deleting assoc data} testdelassocdata {
} {0 {}}
# cleanup
-::tcltest::cleanupTests
+cleanupTests
return
diff --git a/tests/basic.test b/tests/basic.test
index 7435571..ccf26cc 100644
--- a/tests/basic.test
+++ b/tests/basic.test
@@ -16,7 +16,7 @@
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
package require tcltest 2
-namespace import -force ::tcltest::*
+namespace import ::tcltest::*
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
@@ -31,7 +31,7 @@ catch {interp delete test_interp}
catch {rename p ""}
catch {rename q ""}
catch {rename cmd ""}
-catch {unset x}
+unset -nocomplain x
test basic-1.1 {Tcl_CreateInterp, creates interp's global namespace} {
catch {interp delete test_interp}
@@ -302,7 +302,7 @@ test basic-20.1 {Tcl_GetCommandInfo, names for commands created inside namespace
catch {namespace delete {*}[namespace children :: test_ns_*]}
catch {rename p ""}
catch {rename q ""}
- catch {unset x}
+ unset -nocomplain x
set x [namespace eval test_ns_basic::test_ns_basic2 {
# the following creates a cmd in the global namespace
testcmdtoken create p
@@ -355,7 +355,7 @@ test basic-23.1 {Tcl_DeleteCommand} {emptyTest} {
test basic-24.1 {Tcl_DeleteCommandFromToken, invalidate all compiled code if cmd has compile proc} {
catch {interp delete test_interp}
- catch {unset x}
+ unset -nocomplain x
interp create test_interp
interp eval test_interp {
proc useSet {} {
@@ -427,7 +427,7 @@ test basic-26.1 {Tcl_EvalObj: preserve object while evaling it} -setup {
# string would have been freed, leaving garbage bytes for the error
# message.
set f [open $fName w]
- fileevent $f writable "fileevent $f writable {}; error foo"
+ chan event $f writable "chan event $f writable {}; error foo"
set x {}
vwait x
close $f
@@ -547,8 +547,8 @@ test basic-46.1 {Tcl_AllowExceptions: exception return not allowed} {stdio} {
catch {close $f}
set res [catch {
set f [open |[list [interpreter]] w+]
- fconfigure $f -buffering line
- puts $f {fconfigure stdout -buffering line}
+ chan configure $f -buffering line
+ puts $f {chan configure stdout -buffering line}
puts $f continue
puts $f {puts $::errorInfo}
puts $f {puts DONE}
@@ -972,6 +972,6 @@ catch {rename p ""}
catch {rename q ""}
catch {rename cmd ""}
catch {rename value:at: ""}
-catch {unset x}
-::tcltest::cleanupTests
+unset -nocomplain x
+cleanupTests
return
diff --git a/tests/cmdInfo.test b/tests/cmdInfo.test
index 69d7171..0a587e8 100644
--- a/tests/cmdInfo.test
+++ b/tests/cmdInfo.test
@@ -13,10 +13,8 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest 2
- namespace import -force ::tcltest::*
-}
+package require tcltest 2
+namespace import ::tcltest::*
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
@@ -101,7 +99,7 @@ test cmdinfo-6.1 {Names for commands created when outside namespaces} \
# cleanup
catch {namespace delete cmdInfoNs1::cmdInfoNs2 cmdInfoNs1}
catch {rename x1 ""}
-::tcltest::cleanupTests
+cleanupTests
return
# Local Variables:
diff --git a/tests/dcall.test b/tests/dcall.test
index 3df0ac8..41dd777 100644
--- a/tests/dcall.test
+++ b/tests/dcall.test
@@ -11,10 +11,8 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest
- namespace import -force ::tcltest::*
-}
+package require tcltest 2
+namespace import ::tcltest::*
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
@@ -41,5 +39,5 @@ test dcall-1.6 {deletion callbacks} testdcall {
} {}
# cleanup
-::tcltest::cleanupTests
+cleanupTests
return
diff --git a/tests/expr-old.test b/tests/expr-old.test
index 4f3cb2e..06a00ba 100644
--- a/tests/expr-old.test
+++ b/tests/expr-old.test
@@ -13,10 +13,8 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest 2.1
- namespace import -force ::tcltest::*
-}
+package require tcltest 2.1
+namespace import ::tcltest::*
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
@@ -145,7 +143,7 @@ test expr-old-1.50 {integer operators} {expr +36} 36
test expr-old-1.51 {integer operators} {expr +--++36} 36
test expr-old-1.52 {integer operators} {expr +36%+5} 1
test expr-old-1.53 {integer operators} {
- catch {unset x}
+ unset -nocomplain x
set x yes
list [expr {1 && $x}] [expr {$x && 1}] \
[expr {0 || $x}] [expr {$x || 0}]
@@ -453,7 +451,7 @@ test expr-old-23.3 {double quotes} {
test expr-old-23.4 {double quotes} {expr {"11\}\}22"}} 11}}22
test expr-old-23.5 {double quotes} {expr {"\*bc"}} {*bc}
test expr-old-23.6 {double quotes} {
- catch {unset bogus__}
+ unset -nocomplain bogus__
list [catch {expr {"$bogus__"}} msg] $msg
} {1 {can't read "bogus__": no such variable}}
test expr-old-23.7 {double quotes} {
@@ -502,7 +500,7 @@ test expr-old-26.2 {error conditions} -body {
test expr-old-26.3 {error conditions} -body {
expr 2+4*(
} -returnCodes error -match glob -result *
-catch {unset _non_existent_}
+unset -nocomplain _non_existent_
test expr-old-26.4 {error conditions} {
list [catch {expr 2+$_non_existent_} msg] $msg
} {1 {can't read "_non_existent_": no such variable}}
@@ -581,7 +579,7 @@ test expr-old-27.4 {cancelled evaluation} {
expr {1?2:[set a 2]}
set a
} 1
-catch {unset x}
+unset -nocomplain x
test expr-old-27.5 {cancelled evaluation} {
list [catch {expr {[info exists x] && $x}} msg] $msg
} {0 0}
diff --git a/tests/http.test b/tests/http.test
index 9861e0e..e2de7d8 100644
--- a/tests/http.test
+++ b/tests/http.test
@@ -547,11 +547,10 @@ test http-4.14 {http::Event} -body {
error "bogus return from http::geturl"
}
http::wait $token
- http::status $token
- # error code varies among platforms.
-} -returnCodes 1 -match regexp -cleanup {
+ lindex [http::error $token] 0
+} -cleanup {
catch {http::cleanup $token}
-} -result {(connect failed|couldn't open socket)}
+} -result {connect failed connection refused}
# Bogus host
test http-4.15 {http::Event} -body {
# This test may fail if you use a proxy server. That is to be
diff --git a/tests/main.test b/tests/main.test
index f1dc7fd..351fd4f 100644
--- a/tests/main.test
+++ b/tests/main.test
@@ -129,7 +129,7 @@ namespace eval ::tcl::test::main {
set script [makeFile {} script]
file delete $script
set f [open $script w]
- fconfigure $f -encoding utf-8
+ chan configure $f -encoding utf-8
puts $f {puts [list $argv0 $argv $tcl_interactive]}
puts -nonewline $f {puts [string equal \u20ac }
puts $f "\u20ac]"
@@ -150,7 +150,7 @@ namespace eval ::tcl::test::main {
set script [makeFile {} script]
file delete $script
set f [open $script w]
- fconfigure $f -encoding utf-8
+ chan configure $f -encoding utf-8
puts $f {puts [list $argv0 $argv $tcl_interactive]}
puts -nonewline $f {puts [string equal \u20ac }
puts $f "\u20ac]"
@@ -171,7 +171,7 @@ namespace eval ::tcl::test::main {
set script [makeFile {} script]
file delete $script
set f [open $script w]
- fconfigure $f -encoding utf-8
+ chan configure $f -encoding utf-8
puts $f {puts [list $argv0 $argv $tcl_interactive]}
puts -nonewline $f {puts [string equal \u20ac }
puts $f "\u20ac]"
@@ -592,7 +592,7 @@ namespace eval ::tcl::test::main {
catch {set f [open "|[list [interpreter]]" w+]}
} -body {
type $f {
- fconfigure stdin -blocking 0
+ chan configure stdin -blocking 0
puts SUCCESS
}
list [catch {gets $f} line] $line
@@ -606,19 +606,19 @@ namespace eval ::tcl::test::main {
exec
} -setup {
catch {set f [open "|[list [interpreter]]" w+]}
- catch {fconfigure $f -blocking 0}
+ catch {chan configure $f -blocking 0}
} -body {
- type $f "fconfigure stdin -eofchar \\032
+ type $f "chan configure stdin -eofchar \\032
if 1 \{\n\032"
variable wait
- fileevent $f readable \
+ chan event $f readable \
[list set [namespace which -variable wait] "child exit"]
set id [after 2000 [list set [namespace which -variable wait] timeout]]
vwait [namespace which -variable wait]
after cancel $id
set wait
} -cleanup {
- if {[string equal timeout $wait] && [testConstraint unix]} {
+ if {$wait eq "timeout" && [testConstraint unix]} {
exec kill [pid $f]
}
close $f
@@ -631,17 +631,17 @@ namespace eval ::tcl::test::main {
} -setup {
set cmd {makeFile "if 1 \{" script}
catch {set f [open "|[list [interpreter]] < [list [eval $cmd]]" r]}
- catch {fconfigure $f -blocking 0}
+ catch {chan configure $f -blocking 0}
} -body {
variable wait
- fileevent $f readable \
+ chan event $f readable \
[list set [namespace which -variable wait] "child exit"]
set id [after 2000 [list set [namespace which -variable wait] timeout]]
vwait [namespace which -variable wait]
after cancel $id
set wait
} -cleanup {
- if {[string equal timeout $wait] && [testConstraint unix]} {
+ if {$wait eq "timeout" && [testConstraint unix]} {
exec kill [pid $f]
}
close $f
@@ -748,7 +748,7 @@ namespace eval ::tcl::test::main {
exec Tcltest
} -setup {
catch {set f [open "|[list [interpreter]]" w+]}
- catch {fconfigure $f -blocking 0}
+ catch {chan configure $f -blocking 0}
} -body {
type $f "testsetmainloop
after 2000 testexitmainloop
@@ -983,7 +983,7 @@ namespace eval ::tcl::test::main {
} -body {
exec [interpreter] << {
testsetmainloop
- fconfigure stdin -blocking 0
+ chan configure stdin -blocking 0
testexitmainloop
} >& result
set f [open result]
diff --git a/tests/msgcat.test b/tests/msgcat.test
index 1522354..70a7af2 100644
--- a/tests/msgcat.test
+++ b/tests/msgcat.test
@@ -12,7 +12,7 @@
# Note that after running these tests, entries will be left behind in the
# message catalogs for locales foo, foo_BAR, and foo_BAR_baz.
-package require Tcl 8.2
+package require Tcl 8.5
if {[catch {package require tcltest 2}]} {
puts stderr "Skipping tests in [info script]. tcltest 2 required."
return
@@ -56,7 +56,7 @@ namespace eval ::msgcat::test {
set result [string tolower \
[msgcat::ConvertLocale $::tcl::mac::locale]]
} else {
- if {([info sharedlibextension] == ".dll")
+ if {([info sharedlibextension] eq ".dll")
&& ![catch {package require registry}]} {
# Windows and Cygwin have other ways to determine the
# locale when the environment variables are missing
@@ -72,7 +72,7 @@ namespace eval ::msgcat::test {
variable var
foreach var $envVars {
catch {variable $var $::env($var)}
- catch {unset ::env($var)}
+ unset -nocomplain ::env($var)
}
foreach var $setVars {
set ::env($var) $var
@@ -84,13 +84,13 @@ namespace eval ::msgcat::test {
} -cleanup {
interp delete [namespace current]::i
foreach var $envVars {
- catch {unset ::env($var)}
+ unset -nocomplain ::env($var)
catch {set ::env($var) [set [namespace current]::$var]}
}
} -body {i eval msgcat::mclocale} -result $result
incr count
}
- catch {unset result}
+ unset -nocomplain result
# Could add tests of initialization from Windows registry here.
# Use a fake registry package.
@@ -324,7 +324,7 @@ namespace eval ::msgcat::test {
incr count
}
}
- catch {unset result}
+ unset -nocomplain result
# Tests msgcat-4.*: [mcunknown]
diff --git a/tests/oo.test b/tests/oo.test
index 5d34077..49fe150 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -2204,6 +2204,25 @@ test oo-19.2 {OO: varname method: Bug 2883857} -setup {
} -cleanup {
SpecialClass destroy
} -result ::oo_test::x(y)
+test oo-19.3 {OO: varname method and variable decl: Bug 3603695} -setup {
+ oo::class create testClass {
+ variable foo
+ export varname
+ constructor {} {
+ variable foo x
+ }
+ method bar {obj} {
+ my varname foo
+ $obj varname foo
+ }
+ }
+} -body {
+ testClass create A
+ testClass create B
+ lsearch [list [A varname foo] [B varname foo]] [B bar A]
+} -cleanup {
+ testClass destroy
+} -result 0
test oo-20.1 {OO: variable method} -body {
oo::class create testClass {
diff --git a/tests/parse.test b/tests/parse.test
index bc4107d..b9cfe80 100644
--- a/tests/parse.test
+++ b/tests/parse.test
@@ -439,7 +439,7 @@ test parse-8.12 {Tcl_EvalObjv procedure, TCL_EVAL_INVOKE} {
test parse-9.1 {Tcl_LogCommandInfo, line numbers} testevalex {
- catch {unset x}
+ unset -nocomplain x
list [catch {testevalex {for {} 1 {} {
@@ -480,7 +480,7 @@ test parse-10.3 {Tcl_EvalTokens, nested commands} testevalex {
testevalex {concat [expr 2 + 6]}
} {8}
test parse-10.4 {Tcl_EvalTokens, nested commands} testevalex {
- catch {unset a}
+ unset -nocomplain a
list [catch {testevalex {concat xxx[expr $a]}} msg] $msg
} {1 {can't read "a": no such variable}}
test parse-10.5 {Tcl_EvalTokens, simple variables} testevalex {
@@ -488,21 +488,21 @@ test parse-10.5 {Tcl_EvalTokens, simple variables} testevalex {
testevalex {concat $a}
} {hello}
test parse-10.6 {Tcl_EvalTokens, array variables} testevalex {
- catch {unset a}
+ unset -nocomplain a
set a(12) 46
testevalex {concat $a(12)}
} {46}
test parse-10.7 {Tcl_EvalTokens, array variables} testevalex {
- catch {unset a}
+ unset -nocomplain a
set a(12) 46
testevalex {concat $a(1[expr 3 - 1])}
} {46}
test parse-10.8 {Tcl_EvalTokens, array variables} testevalex {
- catch {unset a}
+ unset -nocomplain a
list [catch {testevalex {concat $x($a)}} msg] $msg
} {1 {can't read "a": no such variable}}
test parse-10.9 {Tcl_EvalTokens, array variables} testevalex {
- catch {unset a}
+ unset -nocomplain a
list [catch {testevalex {concat xyz$a(1)}} msg] $msg
} {1 {can't read "a(1)": no such variable}}
test parse-10.10 {Tcl_EvalTokens, object values} testevalex {
@@ -542,11 +542,11 @@ test parse-11.2 {Tcl_EvalEx, error while parsing} testevalex {
list [catch {testevalex {concat "abc}} msg] $msg
} {1 {missing "}}
test parse-11.3 {Tcl_EvalEx, error while collecting words} testevalex {
- catch {unset a}
+ unset -nocomplain a
list [catch {testevalex {concat xyz $a}} msg] $msg
} {1 {can't read "a": no such variable}}
test parse-11.4 {Tcl_EvalEx, error in Tcl_EvalObjv call} testevalex {
- catch {unset a}
+ unset -nocomplain a
list [catch {testevalex {_bogus_ a b c d}} msg] $msg
} {1 {invalid command name "_bogus_"}}
test parse-11.5 {Tcl_EvalEx, exceptional return} testevalex {
@@ -565,7 +565,7 @@ test parse-11.8 {Tcl_EvalEx, multiple commands in script} testevalex {
}] $a $c
} {d b d}
test parse-11.9 {Tcl_EvalEx, freeing memory after error} testevalex {
- catch {unset a}
+ unset -nocomplain a
list [catch {testevalex {concat a b c d e f g h i j k l m n o p q r s t u v w x y z $a}} msg] $msg
} {1 {can't read "a": no such variable}}
test parse-11.10 {Tcl_EvalTokens, empty commands} testevalex {
@@ -671,11 +671,11 @@ test parse-13.3 {Tcl_ParseVar procedure, no variable name} testparsevar {
testparsevar {$.123}
} {{$} .123}
test parse-13.4 {Tcl_ParseVar procedure, error looking up variable} testparsevar {
- catch {unset abc}
+ unset -nocomplain abc
list [catch {testparsevar {$abc}} msg] $msg
} {1 {can't read "abc": no such variable}}
test parse-13.5 {Tcl_ParseVar procedure, error looking up variable} testparsevar {
- catch {unset abc}
+ unset -nocomplain abc
list [catch {testparsevar {$abc([bogus x y z])}} msg] $msg
} {1 {invalid command name "bogus"}}
@@ -1092,13 +1092,12 @@ test parse-20.12 {TclParseBackslash: truncated escape} testparser {
} {- {\x12X} 1 word {\x12X} 2 backslash {\x12} 0 text X 0 {}}
test parse-21.0 {Bug 1884496} testevent {
- set ::script {set a [p]; return -level 0 $a}
+ set ::script {testevent delete a; set a [p]; set ::done $a}
proc ::p {} {string first s $::script}
testevent queue a head $::script
- update
+ vwait done
} {}
-
cleanupTests
}
diff --git a/tests/parseExpr.test b/tests/parseExpr.test
index 7910974..714c45b 100644
--- a/tests/parseExpr.test
+++ b/tests/parseExpr.test
@@ -8,10 +8,8 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest 2
- namespace import -force ::tcltest::*
-}
+package require tcltest 2
+namespace import ::tcltest::*
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
@@ -1067,5 +1065,5 @@ test parseExpr-22.18 {Bug 3401704} -constraints testexprparser -body {
# cleanup
-::tcltest::cleanupTests
+cleanupTests
return
diff --git a/tests/parseOld.test b/tests/parseOld.test
index 0edcbf0..f3b1591 100644
--- a/tests/parseOld.test
+++ b/tests/parseOld.test
@@ -13,10 +13,8 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest
- namespace import -force ::tcltest::*
-}
+package require tcltest
+namespace import ::tcltest::*
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
@@ -166,25 +164,25 @@ test parseOld-5.6 {variable substitution} {
set msg
} {can't read "_non_existent_": no such variable}
test parseOld-5.7 {array variable substitution} {
- catch {unset a}
+ unset -nocomplain a
set a(xyz) 123
set b $a(xyz)foo
set b
} 123foo
test parseOld-5.8 {array variable substitution} {
- catch {unset a}
+ unset -nocomplain a
set "a(x y z)" 123
set b $a(x y z)foo
set b
} 123foo
test parseOld-5.9 {array variable substitution} {
- catch {unset a}; catch {unset qqq}
+ unset -nocomplain a qqq
set "a(x y z)" qqq
set $a([format x]\ y [format z]) foo
set qqq
} foo
test parseOld-5.10 {array variable substitution} {
- catch {unset a}
+ unset -nocomplain a
list [catch {set b $a(22)} msg] $msg
} {1 {can't read "a(22)": no such variable}}
test parseOld-5.11 {array variable substitution} {
@@ -194,9 +192,9 @@ test parseOld-5.11 {array variable substitution} {
test parseOld-5.12 {empty array name support} {
list [catch {set b a$()} msg] $msg
} {1 {can't read "()": no such variable}}
-catch {unset a}
+unset -nocomplain a
test parseOld-5.13 {array variable substitution} {
- catch {unset a}
+ unset -nocomplain a
set long {This is a very long variable, long enough to cause storage \
allocation to occur in Tcl_ParseVar. If that storage isn't getting \
freed up correctly, then a core leak will occur when this test is \
@@ -211,13 +209,13 @@ test parseOld-5.13 {array variable substitution} {
run. This text is probably beginning to sound like drivel, but I've \
run out of things to say and I need more characters still.}}}
test parseOld-5.14 {array variable substitution} {
- catch {unset a}; catch {unset b}; catch {unset a1}
+ unset -nocomplain a b a1
set a1(22) foo
set a(foo) bar
set b $a($a1(22))
set b
} bar
-catch {unset a}; catch {unset a1}
+unset -nocomplain a a1
test parseOld-7.1 {backslash substitution} {
set a "\a\c\n\]\}"
diff --git a/tests/pkgMkIndex.test b/tests/pkgMkIndex.test
index 0fe394e..84c82ce 100644
--- a/tests/pkgMkIndex.test
+++ b/tests/pkgMkIndex.test
@@ -8,10 +8,8 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
-if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest 2
- namespace import -force ::tcltest::*
-}
+package require tcltest 2
+namespace import ::tcltest::*
set fullPkgPath [makeDirectory pkg]
@@ -45,7 +43,7 @@ proc pkgtest::parseArgs { args } {
set a [lindex $args $iarg]
if {[regexp {^-} $a]} {
lappend options $a
- if {[string compare -load $a] == 0} {
+ if {$a eq "-load"} {
incr iarg
lappend options [lindex $args $iarg]
}
@@ -81,7 +79,7 @@ proc pkgtest::parseIndex { filePath } {
$slave eval {
rename package package_original
proc package { args } {
- if {[string compare [lindex $args 0] ifneeded] == 0} {
+ if {[lindex $args 0] eq "ifneeded"} {
set pkg [lindex $args 1]
set ver [lindex $args 2]
set ::PKGS($pkg:$ver) [lindex $args 3]
@@ -111,9 +109,9 @@ proc pkgtest::parseIndex { filePath } {
foreach k [lsort [array names P]] {
lappend PKGS $k $P($k)
}
- } err]} {
- set ei $::errorInfo
- set ec $::errorCode
+ } err opts]} {
+ set ei [dict get $opts -errorinfo]
+ set ec [dict get $opts -errorcode]
catch {interp delete $slave}
diff --git a/tests/platform.test b/tests/platform.test
index aab7c78..6596975 100644
--- a/tests/platform.test
+++ b/tests/platform.test
@@ -9,10 +9,14 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest
- namespace import -force ::tcltest::*
-}
+package require tcltest 2
+
+namespace eval ::tcl::test::platform {
+ namespace import ::tcltest::testConstraint
+ namespace import ::tcltest::test
+ namespace import ::tcltest::cleanupTests
+
+ variable ::tcl_platform
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
@@ -54,7 +58,10 @@ test platform-3.1 {CPU ID on Windows/UNIX} \
-result {^(?:AuthenticAMD|CentaurHauls|CyrixInstead|GenuineIntel)$}
# cleanup
-::tcltest::cleanupTests
+cleanupTests
+
+}
+namespace delete ::tcl::test::platform
return
# Local Variables:
diff --git a/tests/reg.test b/tests/reg.test
index a0ea850..559f549 100644
--- a/tests/reg.test
+++ b/tests/reg.test
@@ -1080,6 +1080,81 @@ test reg-33.13 {Bug 1810264 - infinite loop} {
test reg-33.14 {Bug 1810264 - super-expensive expression} nonPortable {
regexp {(x{200}){200}$y} {x}
} 0
+test reg-33.15 {Bug 3603557 - an "in the wild" RE} {
+ lindex [regexp -expanded -about {
+ ^TETRA_MODE_CMD # Message Type
+ ([[:blank:]]+) # Pad
+ (ETS_1_1|ETS_1_2|ETS_2_2) # SystemCode
+ ([[:blank:]]+) # Pad
+ (CONTINUOUS|CARRIER|MCCH|TRAFFIC) # SharingMode
+ ([[:blank:]]+) # Pad
+ ([[:digit:]]{1,2}) # ColourCode
+ ([[:blank:]]+) # Pad
+ (1|2|3|4|6|9|12|18) # TSReservedFrames
+ ([[:blank:]]+) # Pad
+ (PASS|TRUE|FAIL|FALSE) # UPlaneDTX
+ ([[:blank:]]+) # Pad
+ (PASS|TRUE|FAIL|FALSE) # Frame18Extension
+ ([[:blank:]]+) # Pad
+ ([[:digit:]]{1,4}) # MCC
+ ([[:blank:]]+) # Pad
+ ([[:digit:]]{1,5}) # MNC
+ ([[:blank:]]+) # Pad
+ (BOTH|BCAST|ENQRY|NONE) # NbrCellBcast
+ ([[:blank:]]+) # Pad
+ (UNKNOWN|LOW|MEDIUM|HIGH) # CellServiceLevel
+ ([[:blank:]]+) # Pad
+ (PASS|TRUE|FAIL|FALSE) # LateEntryInfo
+ ([[:blank:]]+) # Pad
+ (300|400) # FrequencyBand
+ ([[:blank:]]+) # Pad
+ (NORMAL|REVERSE) # ReverseOperation
+ ([[:blank:]]+) # Pad
+ (NONE|\+6\.25|\-6\.25|\+12\.5) # Offset
+ ([[:blank:]]+) # Pad
+ (10) # DuplexSpacing
+ ([[:blank:]]+) # Pad
+ ([[:digit:]]{1,4}) # MainCarrierNr
+ ([[:blank:]]+) # Pad
+ (0|1|2|3) # NrCSCCH
+ ([[:blank:]]+) # Pad
+ (15|20|25|30|35|40|45) # MSTxPwrMax
+ ([[:blank:]]+) # Pad
+ (\-125|\-120|\-115|\-110|\-105|\-100|\-95|\-90|\-85|\-80|\-75|\-70|\-65|\-60|\-55|\-50)
+ # RxLevAccessMin
+ ([[:blank:]]+) # Pad
+ (\-53|\-51|\-49|\-47|\-45|\-43|\-41|\-39|\-37|\-35|\-33|\-31|\-29|\-27|\-25|\-23)
+ # AccessParameter
+ ([[:blank:]]+) # Pad
+ (DISABLE|[[:digit:]]{3,4}) # RadioDLTimeout
+ ([[:blank:]]+) # Pad
+ (\-[[:digit:]]{2,3}) # RSSIThreshold
+ ([[:blank:]]+) # Pad
+ ([[:digit:]]{1,5}) # CCKIdSCKVerNr
+ ([[:blank:]]+) # Pad
+ ([[:digit:]]{1,5}) # LocationArea
+ ([[:blank:]]+) # Pad
+ ([(1|0)]{16}) # SubscriberClass
+ ([[:blank:]]+) # Pad
+ ([(1|0)]{12}) # BSServiceDetails
+ ([[:blank:]]+) # Pad
+ (RANDOMIZE|IMMEDIATE|[[:digit:]]{1,2}) # IMM
+ ([[:blank:]]+) # Pad
+ ([[:digit:]]{1,2}) # WT
+ ([[:blank:]]+) # Pad
+ ([[:digit:]]{1,2}) # Nu
+ ([[:blank:]]+) # Pad
+ ([0-1]) # FrameLngFctr
+ ([[:blank:]]+) # Pad
+ ([[:digit:]]{1,2}) # TSPtr
+ ([[:blank:]]+) # Pad
+ ([0-7]) # MinPriority
+ ([[:blank:]]+) # Pad
+ (PASS|TRUE|FAIL|FALSE) # ExtdSrvcsEnabled
+ ([[:blank:]]+) # Pad
+ (.*) # ConditionalFields
+ }] 0
+} 68
# cleanup
::tcltest::cleanupTests
diff --git a/tests/result.test b/tests/result.test
index 3391ce1..9e8a66b 100644
--- a/tests/result.test
+++ b/tests/result.test
@@ -10,10 +10,8 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest 2
- namespace import -force ::tcltest::*
-}
+package require tcltest 2
+namespace import ::tcltest::*
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
diff --git a/tests/set.test b/tests/set.test
index 1d88553..18119f5 100644
--- a/tests/set.test
+++ b/tests/set.test
@@ -524,6 +524,11 @@ test set-5.1 {error on malformed array name} testset2 {
list $msg $msg1
} {{can't read "z(a)(b)": variable isn't array} {can't read "z(b)(a)": variable isn't array}}
+# In a mem-debug build, this test will crash unless Bug 3602706 is fixed.
+test set-5.2 {Bug 3602706} -body {
+ testset2 ::tcl_platform not-in-there
+} -returnCodes error -result * -match glob
+
# cleanup
catch {unset a}
catch {unset b}
diff --git a/tests/stack.test b/tests/stack.test
index 873cb08..13bc524 100644
--- a/tests/stack.test
+++ b/tests/stack.test
@@ -9,10 +9,8 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest 2
- namespace import -force ::tcltest::*
-}
+package require tcltest 2
+namespace import ::tcltest::*
# Note that a failure in this test may result in a crash of the executable.
diff --git a/tests/tcltest.test b/tests/tcltest.test
index 86aca6f..ce8d617 100755
--- a/tests/tcltest.test
+++ b/tests/tcltest.test
@@ -80,10 +80,7 @@ proc slave {msgVar args} {
# Need to capture output in msg
- set code [catch {i eval {source $argv0}} foo]
-if $code {
-#puts "$code: $foo\n$::errorInfo"
-}
+ set code [catch {i eval {source $argv0}}]
i eval {close $tcltest::outputChannel}
interp delete [namespace current]::i
set f [open $of]
@@ -99,8 +96,6 @@ if $code {
append msg \n$err
}
return $code
-
-# return [catch {uplevel 1 [linsert $args 0 exec [interpreter]]} msg]
}
test tcltest-2.0 {tcltest (verbose default - 'b')} {unixOrPc} {
set result [slave msg test.tcl]
@@ -549,7 +544,7 @@ set notWriteableDir [file join [temporaryDirectory] notwriteable]
makeDirectory notreadable
makeDirectory notwriteable
switch -- $::tcl_platform(platform) {
- "unix" {
+ unix {
file attributes $notReadableDir -permissions 00333
file attributes $notWriteableDir -permissions 00555
}
@@ -716,8 +711,8 @@ test tcltest-8.60 {::workingDirectory} {
# clean up from directory testing
-switch $::tcl_platform(platform) {
- "unix" {
+switch -- $::tcl_platform(platform) {
+ unix {
file attributes $notReadableDir -permissions 777
file attributes $notWriteableDir -permissions 777
}
@@ -727,7 +722,7 @@ switch $::tcl_platform(platform) {
}
}
-file delete -force $notReadableDir $notWriteableDir
+file delete -force -- $notReadableDir $notWriteableDir
removeFile a.tcl
removeFile thisdirectoryisafile
removeDirectory normaldirectory
@@ -1150,7 +1145,7 @@ test tcltest-19.1 {TCLTEST_OPTIONS default} -setup {
} -cleanup {
interp delete slave2
interp delete slave1
- if {$oldoptions == "none"} {
+ if {$oldoptions eq "none"} {
unset ::env(TCLTEST_OPTIONS)
} else {
set ::env(TCLTEST_OPTIONS) $oldoptions
diff --git a/tests/thread.test b/tests/thread.test
index d79f693..f32ef61 100644
--- a/tests/thread.test
+++ b/tests/thread.test
@@ -84,28 +84,6 @@ if {[testConstraint testthread]} {
}
testthread errorproc ThreadError
-
- set mainThread [testthread id]
-
- proc ThreadNullError {id info} {
- # ignore
- }
-
- proc threadReap {} {
- testthread errorproc ThreadNullError
- while {[llength [testthread names]] > 1} {
- foreach tid [testthread names] {
- if {$tid != [testthread id]} {
- catch {
- testthread send -async $tid {testthread exit}
- }
- }
- }
- after 1
- }
- testthread errorproc ThreadError
- return [llength [testthread names]]
- }
}
# Some tests require manual draining of the event queue
diff --git a/tests/tm.test b/tests/tm.test
index 149a65d..1b22f8c 100644
--- a/tests/tm.test
+++ b/tests/tm.test
@@ -200,7 +200,7 @@ test tm-3.11 {tm: module path management, remove ignores unknown path} -setup {
proc genpaths {base} {
# Normalizing picks up drive letters on windows [Bug 1053568]
set base [file normalize $base]
- foreach {major minor} [split [info tclversion] .] break
+ lassign [split [package present Tcl] .] major minor
set results {}
set base [file join $base tcl$major]
lappend results [file join $base site-tcl]
diff --git a/tests/trace.test b/tests/trace.test
index 0f48dcf..b4957c0 100644
--- a/tests/trace.test
+++ b/tests/trace.test
@@ -11,10 +11,8 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest
- namespace import -force ::tcltest::*
-}
+package require tcltest
+namespace import ::tcltest::*
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
@@ -32,15 +30,15 @@ proc getbytes {} {
proc traceScalar {name1 name2 op} {
global info
- set info [list $name1 $name2 $op [catch {uplevel set $name1} msg] $msg]
+ set info [list $name1 $name2 $op [catch {uplevel 1 set $name1} msg] $msg]
}
proc traceScalarAppend {name1 name2 op} {
global info
- lappend info $name1 $name2 $op [catch {uplevel set $name1} msg] $msg
+ lappend info $name1 $name2 $op [catch {uplevel 1 set $name1} msg] $msg
}
proc traceArray {name1 name2 op} {
global info
- set info [list $name1 $name2 $op [catch {uplevel set [set name1]($name2)} msg] $msg]
+ set info [list $name1 $name2 $op [catch {uplevel 1 set [set name1]($name2)} msg] $msg]
}
proc traceArray2 {name1 name2 op} {
global info
@@ -62,7 +60,7 @@ proc traceCheck {cmd args} {
set info [list [catch $cmd msg] $msg]
}
proc traceCrtElement {value name1 name2 op} {
- uplevel set ${name1}($name2) $value
+ uplevel 1 set ${name1}($name2) $value
}
proc traceCommand {oldName newName op} {
global info
@@ -72,10 +70,10 @@ proc traceCommand {oldName newName op} {
test trace-0.0 {memory corruption in trace (Tcl Bug 484339)} {
# You may need Purify or Electric Fence to reliably
# see this one fail.
- catch {unset z}
+ unset -nocomplain z
trace add variable z array {set z(foo) 1 ;#}
set res "names: [array names z]"
- catch {unset ::z}
+ unset -nocomplain ::z
trace variable ::z w {unset ::z; error "memory corruption";#}
list [catch {set ::z 1} msg] $msg
} {1 {can't set "::z": memory corruption}}
@@ -83,40 +81,40 @@ test trace-0.0 {memory corruption in trace (Tcl Bug 484339)} {
# Read-tracing on variables
test trace-1.1 {trace variable reads} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x read traceScalar
list [catch {set x} msg] $msg $info
} {1 {can't read "x": no such variable} {x {} read 1 {can't read "x": no such variable}}}
test trace-1.2 {trace variable reads} {
- catch {unset x}
+ unset -nocomplain x
set x 123
set info {}
trace add variable x read traceScalar
list [catch {set x} msg] $msg $info
} {0 123 {x {} read 0 123}}
test trace-1.3 {trace variable reads} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x read traceScalar
set x 123
set info
} {}
test trace-1.4 {trace array element reads} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x(2) read traceArray
list [catch {set x(2)} msg] $msg $info
} {1 {can't read "x(2)": no such element in array} {x 2 read 1 {can't read "x(2)": no such element in array}}}
test trace-1.5 {trace array element reads} {
- catch {unset x}
+ unset -nocomplain x
set x(2) zzz
set info {}
trace add variable x(2) read traceArray
list [catch {set x(2)} msg] $msg $info
} {0 zzz {x 2 read 0 zzz}}
test trace-1.6 {trace array element reads} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x read traceArray2
proc p {} {
@@ -127,7 +125,7 @@ test trace-1.6 {trace array element reads} {
list [catch {p} msg] $msg $info
} {0 willi {x 2 read}}
test trace-1.7 {trace array element reads, create element undefined if nonexistant} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x read q
proc q {name1 name2 op} {
@@ -144,20 +142,20 @@ test trace-1.7 {trace array element reads, create element undefined if nonexista
list [catch {p} msg] $msg $info
} {0 wolf {x Y read}}
test trace-1.8 {trace reads on whole arrays} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x read traceArray
list [catch {set x(2)} msg] $msg $info
} {1 {can't read "x(2)": no such variable} {}}
test trace-1.9 {trace reads on whole arrays} {
- catch {unset x}
+ unset -nocomplain x
set x(2) zzz
set info {}
trace add variable x read traceArray
list [catch {set x(2)} msg] $msg $info
} {0 zzz {x 2 read 0 zzz}}
test trace-1.10 {trace variable reads} {
- catch {unset x}
+ unset -nocomplain x
set x 444
set info {}
trace add variable x read traceScalar
@@ -165,28 +163,28 @@ test trace-1.10 {trace variable reads} {
set info
} {}
test trace-1.11 {read traces that modify the array structure} {
- catch {unset x}
+ unset -nocomplain x
set x(bar) 0
trace variable x r {set x(foo) 1 ;#}
trace variable x r {unset -nocomplain x(bar) ;#}
array get x
} {}
test trace-1.12 {read traces that modify the array structure} {
- catch {unset x}
+ unset -nocomplain x
set x(bar) 0
trace variable x r {unset -nocomplain x(bar) ;#}
trace variable x r {set x(foo) 1 ;#}
array get x
} {}
test trace-1.13 {read traces that modify the array structure} {
- catch {unset x}
+ unset -nocomplain x
set x(bar) 0
trace variable x r {set x(foo) 1 ;#}
trace variable x r {unset -nocomplain x;#}
list [catch {array get x} res] $res
} {1 {can't read "x(bar)": no such variable}}
test trace-1.14 {read traces that modify the array structure} {
- catch {unset x}
+ unset -nocomplain x
set x(bar) 0
trace variable x r {unset -nocomplain x;#}
trace variable x r {set x(foo) 1 ;#}
@@ -196,28 +194,28 @@ test trace-1.14 {read traces that modify the array structure} {
# Basic write-tracing on variables
test trace-2.1 {trace variable writes} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x write traceScalar
set x 123
set info
} {x {} write 0 123}
test trace-2.2 {trace writes to array elements} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x(33) write traceArray
set x(33) 444
set info
} {x 33 write 0 444}
test trace-2.3 {trace writes on whole arrays} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x write traceArray
set x(abc) qq
set info
} {x abc write 0 qq}
test trace-2.4 {trace variable writes} {
- catch {unset x}
+ unset -nocomplain x
set x 1234
set info {}
trace add variable x write traceScalar
@@ -225,7 +223,7 @@ test trace-2.4 {trace variable writes} {
set info
} {}
test trace-2.5 {trace variable writes} {
- catch {unset x}
+ unset -nocomplain x
set x 1234
set info {}
trace add variable x write traceScalar
@@ -238,7 +236,7 @@ test trace-2.6 {trace variable writes on compiled local} {
# arrays [Bug 1770591]. The corresponding function for read traces is
# already indirectly tested in trace-1.7
#
- catch {unset x}
+ unset -nocomplain x
set info {}
proc p {} {
trace add variable x write traceArray
@@ -267,7 +265,7 @@ test trace-2.7 {trace variable writes on errorInfo} -body {
# trace: after appending all arguments to the list.
test trace-3.1 {trace variable read-modify-writes} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x read traceScalarAppend
append x 123
@@ -276,7 +274,7 @@ test trace-3.1 {trace variable read-modify-writes} {
set info
} {x {} read 0 123456}
test trace-3.2 {trace variable read-modify-writes} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x {read write} traceScalarAppend
append x 123
@@ -287,14 +285,14 @@ test trace-3.2 {trace variable read-modify-writes} {
# Basic unset-tracing on variables
test trace-4.1 {trace variable unsets} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x unset traceScalar
- catch {unset x}
+ unset -nocomplain x
set info
} {x {} unset 1 {can't read "x": no such variable}}
test trace-4.2 {variable mustn't exist during unset trace} {
- catch {unset x}
+ unset -nocomplain x
set x 1234
set info {}
trace add variable x unset traceScalar
@@ -302,7 +300,7 @@ test trace-4.2 {variable mustn't exist during unset trace} {
set info
} {x {} unset 1 {can't read "x": no such variable}}
test trace-4.3 {unset traces mustn't be called during reads and writes} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x unset traceScalar
set x 44
@@ -310,15 +308,15 @@ test trace-4.3 {unset traces mustn't be called during reads and writes} {
set info
} {}
test trace-4.4 {trace unsets on array elements} {
- catch {unset x}
+ unset -nocomplain x
set x(0) 18
set info {}
trace add variable x(1) unset traceArray
- catch {unset x(1)}
+ unset -nocomplain x(1)
set info
} {x 1 unset 1 {can't read "x(1)": no such element in array}}
test trace-4.5 {trace unsets on array elements} {
- catch {unset x}
+ unset -nocomplain x
set x(1) 18
set info {}
trace add variable x(1) unset traceArray
@@ -326,7 +324,7 @@ test trace-4.5 {trace unsets on array elements} {
set info
} {x 1 unset 1 {can't read "x(1)": no such element in array}}
test trace-4.6 {trace unsets on array elements} {
- catch {unset x}
+ unset -nocomplain x
set x(1) 18
set info {}
trace add variable x(1) unset traceArray
@@ -334,15 +332,15 @@ test trace-4.6 {trace unsets on array elements} {
set info
} {x 1 unset 1 {can't read "x(1)": no such variable}}
test trace-4.7 {trace unsets on whole arrays} {
- catch {unset x}
+ unset -nocomplain x
set x(1) 18
set info {}
trace add variable x unset traceProc
- catch {unset x(0)}
+ unset -nocomplain x(0)
set info
} {}
test trace-4.8 {trace unsets on whole arrays} {
- catch {unset x}
+ unset -nocomplain x
set x(1) 18
set x(2) 144
set x(3) 14
@@ -352,7 +350,7 @@ test trace-4.8 {trace unsets on whole arrays} {
set info
} {x 1 unset}
test trace-4.9 {trace unsets on whole arrays} {
- catch {unset x}
+ unset -nocomplain x
set x(1) 18
set x(2) 144
set x(3) 14
@@ -364,7 +362,7 @@ test trace-4.9 {trace unsets on whole arrays} {
# Array tracing on variables
test trace-5.1 {array traces fire on accesses via [array]} {
- catch {unset x}
+ unset -nocomplain x
set x(b) 2
trace add variable x array traceArray2
set ::info {}
@@ -372,7 +370,7 @@ test trace-5.1 {array traces fire on accesses via [array]} {
set ::info
} {x {} array}
test trace-5.2 {array traces do not fire on normal accesses} {
- catch {unset x}
+ unset -nocomplain x
set x(b) 2
trace add variable x array traceArray2
set ::info {}
@@ -381,7 +379,7 @@ test trace-5.2 {array traces do not fire on normal accesses} {
set ::info
} {}
test trace-5.3 {array traces do not outlive variable} {
- catch {unset x}
+ unset -nocomplain x
trace add variable x array traceArray2
set ::info {}
set x(a) 1
@@ -390,19 +388,19 @@ test trace-5.3 {array traces do not outlive variable} {
set ::info
} {}
test trace-5.4 {array traces properly listed in trace information} {
- catch {unset x}
+ unset -nocomplain x
trace add variable x array traceArray2
set result [trace info variable x]
set result
} [list [list array traceArray2]]
test trace-5.5 {array traces properly listed in trace information} {
- catch {unset x}
+ unset -nocomplain x
trace variable x a traceArray2
set result [trace vinfo x]
set result
} [list [list a traceArray2]]
test trace-5.6 {array traces don't fire on scalar variables} {
- catch {unset x}
+ unset -nocomplain x
set x foo
trace add variable x array traceArray2
set ::info {}
@@ -410,14 +408,14 @@ test trace-5.6 {array traces don't fire on scalar variables} {
set ::info
} {}
test trace-5.7 {array traces fire for undefined variables} {
- catch {unset x}
+ unset -nocomplain x
trace add variable x array traceArray2
set ::info {}
array set x {a 1}
set ::info
} {x {} array}
test trace-5.8 {array traces fire for undefined variables} {
- catch {unset x}
+ unset -nocomplain x
trace add variable x array {set x(foo) 1 ;#}
set res "names: [array names x]"
} {names: foo}
@@ -425,7 +423,7 @@ test trace-5.8 {array traces fire for undefined variables} {
# Trace multiple trace types at once.
test trace-6.1 {multiple ops traced at once} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x {read write unset} traceProc
catch {set x}
@@ -436,7 +434,7 @@ test trace-6.1 {multiple ops traced at once} {
set info
} {x {} read x {} write x {} read x {} write x {} unset}
test trace-6.2 {multiple ops traced on array element} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x(0) {read write unset} traceProc
catch {set x(0)}
@@ -448,7 +446,7 @@ test trace-6.2 {multiple ops traced on array element} {
set info
} {x 0 read x 0 write x 0 read x 0 write x 0 unset}
test trace-6.3 {multiple ops traced on whole array} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x {read write unset} traceProc
catch {set x(0)}
@@ -463,7 +461,7 @@ test trace-6.3 {multiple ops traced on whole array} {
# Check order of invocation of traces
test trace-7.1 {order of invocation of traces} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x read "traceTag 1"
trace add variable x read "traceTag 2"
@@ -474,7 +472,7 @@ test trace-7.1 {order of invocation of traces} {
set info
} {3 2 1 3 2 1}
test trace-7.2 {order of invocation of traces} {
- catch {unset x}
+ unset -nocomplain x
set x(0) 44
set info {}
trace add variable x(0) read "traceTag 1"
@@ -484,7 +482,7 @@ test trace-7.2 {order of invocation of traces} {
set info
} {3 2 1}
test trace-7.3 {order of invocation of traces} {
- catch {unset x}
+ unset -nocomplain x
set x(0) 44
set info {}
trace add variable x(0) read "traceTag 1"
@@ -500,7 +498,7 @@ test trace-7.3 {order of invocation of traces} {
# Check effects of errors in trace procedures
test trace-8.1 {error returns from traces} {
- catch {unset x}
+ unset -nocomplain x
set x 123
set info {}
trace add variable x read "traceTag 1"
@@ -508,7 +506,7 @@ test trace-8.1 {error returns from traces} {
list [catch {set x} msg] $msg $info
} {1 {can't read "x": trace returned error} {}}
test trace-8.2 {error returns from traces} {
- catch {unset x}
+ unset -nocomplain x
set x 123
set info {}
trace add variable x write "traceTag 1"
@@ -516,14 +514,14 @@ test trace-8.2 {error returns from traces} {
list [catch {set x 44} msg] $msg $info
} {1 {can't set "x": trace returned error} {}}
test trace-8.3 {error returns from traces} {
- catch {unset x}
+ unset -nocomplain x
set x 123
set info {}
trace add variable x write traceError
list [catch {append x 44} msg] $msg $info
} {1 {can't set "x": trace returned error} {}}
test trace-8.4 {error returns from traces} {
- catch {unset x}
+ unset -nocomplain x
set x 123
set info {}
trace add variable x unset "traceTag 1"
@@ -531,7 +529,7 @@ test trace-8.4 {error returns from traces} {
list [catch {unset x} msg] $msg $info
} {0 {} 1}
test trace-8.5 {error returns from traces} {
- catch {unset x}
+ unset -nocomplain x
set x(0) 123
set info {}
trace add variable x(0) read "traceTag 1"
@@ -541,7 +539,7 @@ test trace-8.5 {error returns from traces} {
list [catch {set x(0)} msg] $msg $info
} {1 {can't read "x(0)": trace returned error} 3}
test trace-8.6 {error returns from traces} {
- catch {unset x}
+ unset -nocomplain x
set x 123
trace add variable x unset traceError
list [catch {unset x} msg] $msg
@@ -550,7 +548,7 @@ test trace-8.7 {error returns from traces} {
# This test just makes sure that the memory for the error message
# gets deallocated correctly when the trace is invoked again or
# when the trace is deleted.
- catch {unset x}
+ unset -nocomplain x
set x 123
trace add variable x read traceError
catch {set x}
@@ -571,7 +569,7 @@ test trace-8.8 {error returns from traces} {
trace add variable ::x write [list foo $::x]
error "foo"
}
- catch {unset ::x ::y}
+ unset -nocomplain ::x ::y
set x junk
trace add variable ::x write [list foo $x]
for {set y 0} {$y<100} {incr y} {
@@ -585,31 +583,31 @@ test trace-8.8 {error returns from traces} {
# a new copy of the variables.
test trace-9.1 {be sure variable is unset before trace is called} {
- catch {unset x}
+ unset -nocomplain x
set x 33
set info {}
- trace add variable x unset {traceCheck {uplevel set x}}
+ trace add variable x unset {traceCheck {uplevel 1 set x}}
unset x
set info
} {1 {can't read "x": no such variable}}
test trace-9.2 {be sure variable is unset before trace is called} {
- catch {unset x}
+ unset -nocomplain x
set x 33
set info {}
- trace add variable x unset {traceCheck {uplevel set x 22}}
+ trace add variable x unset {traceCheck {uplevel 1 set x 22}}
unset x
concat $info [list [catch {set x} msg] $msg]
} {0 22 0 22}
test trace-9.3 {be sure traces are cleared before unset trace called} {
- catch {unset x}
+ unset -nocomplain x
set x 33
set info {}
- trace add variable x unset {traceCheck {uplevel trace info variable x}}
+ trace add variable x unset {traceCheck {uplevel 1 trace info variable x}}
unset x
set info
} {0 {}}
test trace-9.4 {set new trace during unset trace} {
- catch {unset x}
+ unset -nocomplain x
set x 33
set info {}
trace add variable x unset {traceCheck {global x; trace add variable x unset traceProc}}
@@ -618,23 +616,23 @@ test trace-9.4 {set new trace during unset trace} {
} {0 {} {unset traceProc}}
test trace-10.1 {make sure array elements are unset before traces are called} {
- catch {unset x}
+ unset -nocomplain x
set x(0) 33
set info {}
- trace add variable x(0) unset {traceCheck {uplevel set x(0)}}
+ trace add variable x(0) unset {traceCheck {uplevel 1 set x(0)}}
unset x(0)
set info
} {1 {can't read "x(0)": no such element in array}}
test trace-10.2 {make sure array elements are unset before traces are called} {
- catch {unset x}
+ unset -nocomplain x
set x(0) 33
set info {}
- trace add variable x(0) unset {traceCheck {uplevel set x(0) zzz}}
+ trace add variable x(0) unset {traceCheck {uplevel 1 set x(0) zzz}}
unset x(0)
concat $info [list [catch {set x(0)} msg] $msg]
} {0 zzz 0 zzz}
test trace-10.3 {array elements are unset before traces are called} {
- catch {unset x}
+ unset -nocomplain x
set x(0) 33
set info {}
trace add variable x(0) unset {traceCheck {global x; trace info variable x(0)}}
@@ -642,49 +640,49 @@ test trace-10.3 {array elements are unset before traces are called} {
set info
} {0 {}}
test trace-10.4 {set new array element trace during unset trace} {
- catch {unset x}
+ unset -nocomplain x
set x(0) 33
set info {}
- trace add variable x(0) unset {traceCheck {uplevel {trace add variable x(0) read {}}}}
- catch {unset x(0)}
+ trace add variable x(0) unset {traceCheck {uplevel 1 {trace add variable x(0) read {}}}}
+ unset -nocomplain x(0)
concat $info [trace info variable x(0)]
} {0 {} {read {}}}
test trace-11.1 {make sure arrays are unset before traces are called} {
- catch {unset x}
+ unset -nocomplain x
set x(0) 33
set info {}
- trace add variable x unset {traceCheck {uplevel set x(0)}}
+ trace add variable x unset {traceCheck {uplevel 1 set x(0)}}
unset x
set info
} {1 {can't read "x(0)": no such variable}}
test trace-11.2 {make sure arrays are unset before traces are called} {
- catch {unset x}
+ unset -nocomplain x
set x(y) 33
set info {}
- trace add variable x unset {traceCheck {uplevel set x(y) 22}}
+ trace add variable x unset {traceCheck {uplevel 1 set x(y) 22}}
unset x
concat $info [list [catch {set x(y)} msg] $msg]
} {0 22 0 22}
test trace-11.3 {make sure arrays are unset before traces are called} {
- catch {unset x}
+ unset -nocomplain x
set x(y) 33
set info {}
- trace add variable x unset {traceCheck {uplevel array exists x}}
+ trace add variable x unset {traceCheck {uplevel 1 array exists x}}
unset x
set info
} {0 0}
test trace-11.4 {make sure arrays are unset before traces are called} {
- catch {unset x}
+ unset -nocomplain x
set x(y) 33
set info {}
- set cmd {traceCheck {uplevel {trace info variable x}}}
+ set cmd {traceCheck {uplevel 1 {trace info variable x}}}
trace add variable x unset $cmd
unset x
set info
} {0 {}}
test trace-11.5 {set new array trace during unset trace} {
- catch {unset x}
+ unset -nocomplain x
set x(y) 33
set info {}
trace add variable x unset {traceCheck {global x; trace add variable x read {}}}
@@ -692,7 +690,7 @@ test trace-11.5 {set new array trace during unset trace} {
concat $info [trace info variable x]
} {0 {} {read {}}}
test trace-11.6 {create scalar during array unset trace} {
- catch {unset x}
+ unset -nocomplain x
set x(y) 33
set info {}
trace add variable x unset {traceCheck {global x; set x 44}}
@@ -703,52 +701,52 @@ test trace-11.6 {create scalar during array unset trace} {
# Check special conditions (e.g. errors) in Tcl_TraceVar2.
test trace-12.1 {creating array when setting variable traces} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x(0) write traceProc
list [catch {set x 22} msg] $msg
} {1 {can't set "x": variable is array}}
test trace-12.2 {creating array when setting variable traces} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x(0) write traceProc
list [catch {set x(0)} msg] $msg
} {1 {can't read "x(0)": no such element in array}}
test trace-12.3 {creating array when setting variable traces} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x(0) write traceProc
set x(0) 22
set info
} {x 0 write}
test trace-12.4 {creating variable when setting variable traces} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x write traceProc
list [catch {set x} msg] $msg
} {1 {can't read "x": no such variable}}
test trace-12.5 {creating variable when setting variable traces} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x write traceProc
set x 22
set info
} {x {} write}
test trace-12.6 {creating variable when setting variable traces} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x write traceProc
set x(0) 22
set info
} {x 0 write}
test trace-12.7 {create array element during read trace} {
- catch {unset x}
+ unset -nocomplain x
set x(2) zzz
trace add variable x read {traceCrtElement xyzzy}
list [catch {set x(3)} msg] $msg
} {0 xyzzy}
test trace-12.8 {errors when setting variable traces} {
- catch {unset x}
+ unset -nocomplain x
set x 44
list [catch {trace add variable x(0) write traceProc} msg] $msg
} {1 {can't trace "x(0)": variable isn't array}}
@@ -762,7 +760,7 @@ test trace-13.1 {delete one trace from another} {
trace remove variable x read {traceTag 3}
trace remove variable x read {traceTag 4}
}
- catch {unset x}
+ unset -nocomplain x
set x 44
set info {}
trace add variable x read {traceTag 1}
@@ -916,13 +914,13 @@ test trace-14.11 {trace command, "trace variable" errors} {
test trace-14.12 {trace command ("remove variable" option)} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x write traceProc
trace remove variable x write traceProc
} {}
test trace-14.13 {trace command ("remove variable" option)} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x write traceProc
trace remove variable x write traceProc
@@ -930,7 +928,7 @@ test trace-14.13 {trace command ("remove variable" option)} {
set info
} {}
test trace-14.14 {trace command ("remove variable" option)} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x write {traceTag 1}
trace add variable x write traceProc
@@ -945,7 +943,7 @@ test trace-14.14 {trace command ("remove variable" option)} {
set info
} {2 x {} write 1 2 1 2}
test trace-14.15 {trace command ("remove variable" option)} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x write {traceTag 1}
trace remove variable x write non_existent
@@ -953,27 +951,27 @@ test trace-14.15 {trace command ("remove variable" option)} {
set info
} {1}
test trace-14.16 {trace command ("info variable" option)} {
- catch {unset x}
+ unset -nocomplain x
trace add variable x write {traceTag 1}
trace add variable x write traceProc
trace add variable x write {traceTag 2}
trace info variable x
} {{write {traceTag 2}} {write traceProc} {write {traceTag 1}}}
test trace-14.17 {trace command ("info variable" option)} {
- catch {unset x}
+ unset -nocomplain x
trace info variable x
} {}
test trace-14.18 {trace command ("info variable" option)} {
- catch {unset x}
+ unset -nocomplain x
trace info variable x(0)
} {}
test trace-14.19 {trace command ("info variable" option)} {
- catch {unset x}
+ unset -nocomplain x
set x 44
trace info variable x(0)
} {}
test trace-14.20 {trace command ("info variable" option)} {
- catch {unset x}
+ unset -nocomplain x
set x 44
trace add variable x write {traceTag 1}
proc check {} {global x; trace info variable x}
@@ -983,7 +981,7 @@ test trace-14.20 {trace command ("info variable" option)} {
# Check fancy trace commands (long ones, weird arguments, etc.)
test trace-15.1 {long trace command} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x write {traceTag {This is a very very long argument. It's \
designed to test out the facilities of TraceVarProc for dealing \
@@ -1001,14 +999,14 @@ test trace-15.2 {long trace command result to ignore} {
proc longResult {args} {return "quite a bit of text, designed to
generate a core leak if this command file is invoked over and over again
and memory isn't being recycled correctly"}
- catch {unset x}
+ unset -nocomplain x
trace add variable x write longResult
set x 44
set x 5
set x abcde
} abcde
test trace-15.3 {special list-handling in trace commands} {
- catch {unset "x y z"}
+ unset -nocomplain "x y z"
set "x y z(a\n\{)" 44
set info {}
trace add variable "x y z(a\n\{)" write traceProc
@@ -1020,18 +1018,18 @@ test trace-15.3 {special list-handling in trace commands} {
proc traceUnset {unsetName args} {
global info
- upvar $unsetName x
+ upvar 1 $unsetName x
lappend info [catch {unset x} msg] $msg [catch {set x} msg] $msg
}
proc traceReset {unsetName resetName args} {
global info
- upvar $unsetName x $resetName y
+ upvar 1 $unsetName x $resetName y
lappend info [catch {unset x} msg] $msg [catch {set y xyzzy} msg] $msg
}
proc traceReset2 {unsetName resetName args} {
global info
- lappend info [catch {uplevel unset $unsetName} msg] $msg \
- [catch {uplevel set $resetName xyzzy} msg] $msg
+ lappend info [catch {uplevel 1 unset $unsetName} msg] $msg \
+ [catch {uplevel 1 set $resetName xyzzy} msg] $msg
}
proc traceAppend {string name1 name2 op} {
global info
@@ -1039,7 +1037,7 @@ proc traceAppend {string name1 name2 op} {
}
test trace-16.1 {unsets during read traces} {
- catch {unset y}
+ unset -nocomplain y
set y 1234
set info {}
trace add variable y read {traceUnset y}
@@ -1047,49 +1045,49 @@ test trace-16.1 {unsets during read traces} {
lappend info [catch {set y} msg] $msg
} {unset 0 {} 1 {can't read "x": no such variable} 1 {can't read "y": no such variable}}
test trace-16.2 {unsets during read traces} {
- catch {unset y}
+ unset -nocomplain y
set y(0) 1234
set info {}
trace add variable y(0) read {traceUnset y(0)}
lappend info [catch {set y(0)} msg] $msg
} {0 {} 1 {can't read "x": no such variable} 1 {can't read "y(0)": no such element in array}}
test trace-16.3 {unsets during read traces} {
- catch {unset y}
+ unset -nocomplain y
set y(0) 1234
set info {}
trace add variable y(0) read {traceUnset y}
lappend info [catch {set y(0)} msg] $msg
} {0 {} 1 {can't read "x": no such variable} 1 {can't read "y(0)": no such variable}}
test trace-16.4 {unsets during read traces} {
- catch {unset y}
+ unset -nocomplain y
set y 1234
set info {}
trace add variable y read {traceReset y y}
lappend info [catch {set y} msg] $msg
} {0 {} 0 xyzzy 0 xyzzy}
test trace-16.5 {unsets during read traces} {
- catch {unset y}
+ unset -nocomplain y
set y(0) 1234
set info {}
trace add variable y(0) read {traceReset y(0) y(0)}
lappend info [catch {set y(0)} msg] $msg
} {0 {} 0 xyzzy 0 xyzzy}
test trace-16.6 {unsets during read traces} {
- catch {unset y}
+ unset -nocomplain y
set y(0) 1234
set info {}
trace add variable y(0) read {traceReset y y(0)}
lappend info [catch {set y(0)} msg] $msg [catch {set y(0)} msg] $msg
} {0 {} 1 {can't set "y": upvar refers to element in deleted array} 1 {can't read "y(0)": no such variable} 1 {can't read "y(0)": no such variable}}
test trace-16.7 {unsets during read traces} {
- catch {unset y}
+ unset -nocomplain y
set y(0) 1234
set info {}
trace add variable y(0) read {traceReset2 y y(0)}
lappend info [catch {set y(0)} msg] $msg [catch {set y(0)} msg] $msg
} {0 {} 0 xyzzy 1 {can't read "y(0)": no such element in array} 0 xyzzy}
test trace-16.8 {unsets during write traces} {
- catch {unset y}
+ unset -nocomplain y
set y 1234
set info {}
trace add variable y write {traceUnset y}
@@ -1097,91 +1095,91 @@ test trace-16.8 {unsets during write traces} {
lappend info [catch {set y xxx} msg] $msg
} {unset 0 {} 1 {can't read "x": no such variable} 0 {}}
test trace-16.9 {unsets during write traces} {
- catch {unset y}
+ unset -nocomplain y
set y(0) 1234
set info {}
trace add variable y(0) write {traceUnset y(0)}
lappend info [catch {set y(0) xxx} msg] $msg
} {0 {} 1 {can't read "x": no such variable} 0 {}}
test trace-16.10 {unsets during write traces} {
- catch {unset y}
+ unset -nocomplain y
set y(0) 1234
set info {}
trace add variable y(0) write {traceUnset y}
lappend info [catch {set y(0) xxx} msg] $msg
} {0 {} 1 {can't read "x": no such variable} 0 {}}
test trace-16.11 {unsets during write traces} {
- catch {unset y}
+ unset -nocomplain y
set y 1234
set info {}
trace add variable y write {traceReset y y}
lappend info [catch {set y xxx} msg] $msg
} {0 {} 0 xyzzy 0 xyzzy}
test trace-16.12 {unsets during write traces} {
- catch {unset y}
+ unset -nocomplain y
set y(0) 1234
set info {}
trace add variable y(0) write {traceReset y(0) y(0)}
lappend info [catch {set y(0) xxx} msg] $msg
} {0 {} 0 xyzzy 0 xyzzy}
test trace-16.13 {unsets during write traces} {
- catch {unset y}
+ unset -nocomplain y
set y(0) 1234
set info {}
trace add variable y(0) write {traceReset y y(0)}
lappend info [catch {set y(0) xxx} msg] $msg [catch {set y(0)} msg] $msg
} {0 {} 1 {can't set "y": upvar refers to element in deleted array} 0 {} 1 {can't read "y(0)": no such variable}}
test trace-16.14 {unsets during write traces} {
- catch {unset y}
+ unset -nocomplain y
set y(0) 1234
set info {}
trace add variable y(0) write {traceReset2 y y(0)}
lappend info [catch {set y(0) xxx} msg] $msg [catch {set y(0)} msg] $msg
} {0 {} 0 xyzzy 0 {} 0 xyzzy}
test trace-16.15 {unsets during unset traces} {
- catch {unset y}
+ unset -nocomplain y
set y 1234
set info {}
trace add variable y unset {traceUnset y}
lappend info [catch {unset y} msg] $msg [catch {set y} msg] $msg
} {1 {can't unset "x": no such variable} 1 {can't read "x": no such variable} 0 {} 1 {can't read "y": no such variable}}
test trace-16.16 {unsets during unset traces} {
- catch {unset y}
+ unset -nocomplain y
set y(0) 1234
set info {}
trace add variable y(0) unset {traceUnset y(0)}
lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg
} {1 {can't unset "x": no such variable} 1 {can't read "x": no such variable} 0 {} 1 {can't read "y(0)": no such element in array}}
test trace-16.17 {unsets during unset traces} {
- catch {unset y}
+ unset -nocomplain y
set y(0) 1234
set info {}
trace add variable y(0) unset {traceUnset y}
lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg
} {0 {} 1 {can't read "x": no such variable} 0 {} 1 {can't read "y(0)": no such variable}}
test trace-16.18 {unsets during unset traces} {
- catch {unset y}
+ unset -nocomplain y
set y 1234
set info {}
trace add variable y unset {traceReset2 y y}
lappend info [catch {unset y} msg] $msg [catch {set y} msg] $msg
} {1 {can't unset "y": no such variable} 0 xyzzy 0 {} 0 xyzzy}
test trace-16.19 {unsets during unset traces} {
- catch {unset y}
+ unset -nocomplain y
set y(0) 1234
set info {}
trace add variable y(0) unset {traceReset2 y(0) y(0)}
lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg
} {1 {can't unset "y(0)": no such element in array} 0 xyzzy 0 {} 0 xyzzy}
test trace-16.20 {unsets during unset traces} {
- catch {unset y}
+ unset -nocomplain y
set y(0) 1234
set info {}
trace add variable y(0) unset {traceReset2 y y(0)}
lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg
} {0 {} 0 xyzzy 0 {} 0 xyzzy}
test trace-16.21 {unsets cancelling traces} {
- catch {unset y}
+ unset -nocomplain y
set y 1234
set info {}
trace add variable y read {traceAppend first}
@@ -1191,7 +1189,7 @@ test trace-16.21 {unsets cancelling traces} {
lappend info [catch {set y} msg] $msg
} {third unset 0 {} 1 {can't read "x": no such variable} 1 {can't read "y": no such variable}}
test trace-16.22 {unsets cancelling traces} {
- catch {unset y}
+ unset -nocomplain y
set y(0) 1234
set info {}
trace add variable y(0) read {traceAppend first}
@@ -1204,19 +1202,19 @@ test trace-16.22 {unsets cancelling traces} {
# Check various non-interference between traces and other things.
test trace-17.1 {trace doesn't prevent unset errors} {
- catch {unset x}
+ unset -nocomplain x
set info {}
trace add variable x unset {traceProc}
list [catch {unset x} msg] $msg $info
} {1 {can't unset "x": no such variable} {x {} unset}}
test trace-17.2 {traced variables must survive procedure exits} {
- catch {unset x}
+ unset -nocomplain x
proc p1 {} {global x; trace add variable x write traceProc}
p1
trace info variable x
} {{write traceProc}}
test trace-17.3 {traced variables must survive procedure exits} {
- catch {unset x}
+ unset -nocomplain x
set info {}
proc p1 {} {global x; trace add variable x write traceProc}
p1
@@ -1229,7 +1227,7 @@ test trace-17.3 {traced variables must survive procedure exits} {
test trace-18.1 {unset traces on procedure returns} {
proc p1 {x y} {set a 44; p2 14}
- proc p2 {z} {trace add variable z unset {traceCheck {lsort [uplevel {info vars}]}}}
+ proc p2 {z} {trace add variable z unset {traceCheck {lsort [uplevel 1 {info vars}]}}}
set info {}
p1 foo bar
set info
@@ -1269,8 +1267,7 @@ test trace-18.4 {namespace delete / trace vdelete combo, Bug \#1338280} {
# Delete arrays when done, so they can be re-used as scalars
# elsewhere.
-catch {unset x}
-catch {unset y}
+unset -nocomplain x y
test trace-19.0.1 {trace add command (command existence)} {
# Just in case!
@@ -1542,8 +1539,7 @@ proc foo {b} { set a $b }
# Delete arrays when done, so they can be re-used as scalars
# elsewhere.
-catch {unset x}
-catch {unset y}
+unset -nocomplain x y
# Delete procedures when done, so we don't clash with other tests
# (e.g. foobar will clash with 'unknown' tests).
@@ -2050,7 +2046,7 @@ test trace-28.1 {enterstep and leavestep traces with update idletasks (615043)}
trace remove execution foo {enter enterstep leavestep leave} \
[list traceExecute foo]
rename foo {}
- catch {unset a}
+ unset -nocomplain a
join $info "\n"
} {foo foo enter
foo {set a 1} enterstep
@@ -2634,9 +2630,8 @@ catch {rename traceproc {}}
catch {rename runbase {}}
# Unset the variable when done
-catch {unset info}
-catch {unset base}
+unset -nocomplain info base
# cleanup
-::tcltest::cleanupTests
+cleanupTests
return
diff --git a/tests/unixInit.test b/tests/unixInit.test
index 9ba9c11..05338ed 100644
--- a/tests/unixInit.test
+++ b/tests/unixInit.test
@@ -11,7 +11,7 @@
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
package require tcltest 2.2
-namespace import -force ::tcltest::*
+namespace import ::tcltest::*
unset -nocomplain path
catch {set oldlang $env(LANG)}
set env(LANG) C
@@ -44,11 +44,11 @@ test unixInit-1.2 {initialisation: standard channel type deduction} {unix stdio}
set pipe1 [open "|[list [interpreter]]" r+]
puts $pipe1 {
proc accept {channel host port} {
- puts $channel {puts [fconfigure stdin -peername]; exit}
+ puts $channel {puts [chan configure stdin -peername]; exit}
close $channel
exit
}
- puts [fconfigure [socket -server accept -myaddr 127.0.0.1 0] -sockname]
+ puts [chan configure [socket -server accept -myaddr 127.0.0.1 0] -sockname]
vwait forever \
}
# Note the backslash above; this is important to make sure that the whole
@@ -64,8 +64,8 @@ test unixInit-1.2 {initialisation: standard channel type deduction} {unix stdio}
set pipe2 [open "|[list [interpreter] <@$sock]" r]
set result [gets $pipe2]
# Clear any pending data; stops certain kinds of (non-important) errors
- fconfigure $pipe1 -blocking 0; gets $pipe1
- fconfigure $pipe2 -blocking 0; gets $pipe2
+ chan configure $pipe1 -blocking 0; gets $pipe1
+ chan configure $pipe2 -blocking 0; gets $pipe2
# Close the pipes and the socket.
close $pipe2
close $pipe1
@@ -329,7 +329,7 @@ test unixInit-3.1 {TclpSetInitialEncodings} -constraints {
} -body {
set env(LANG) C
set f [open "|[list [interpreter]]" w+]
- fconfigure $f -buffering none
+ chan configure $f -buffering none
puts $f {puts [encoding system]; exit}
set enc [gets $f]
close $f
@@ -344,7 +344,7 @@ test unixInit-3.2 {TclpSetInitialEncodings} -setup {
set env(LANG) japanese
set env(LC_ALL) japanese
set f [open "|[list [interpreter]]" w+]
- fconfigure $f -buffering none
+ chan configure $f -buffering none
puts $f {puts [encoding system]; exit}
set enc [gets $f]
close $f
@@ -390,7 +390,7 @@ test unixInit-7.1 {closed standard channel: Bug 772288} -constraints {
} -returnCodes 0
# cleanup
-catch {unset env(LANG)}
+unset -nocomplain env(LANG)
catch {set env(LANG) $oldlang}
unset -nocomplain path
::tcltest::cleanupTests
diff --git a/tests/unknown.test b/tests/unknown.test
index 40be6602..e80d3a6 100644
--- a/tests/unknown.test
+++ b/tests/unknown.test
@@ -11,12 +11,10 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest
- namespace import -force ::tcltest::*
-}
+package require tcltest 2
+namespace import ::tcltest::*
-catch {unset x}
+unset -nocomplain x
catch {rename unknown unknown.old}
test unknown-1.1 {non-existent "unknown" command} {
@@ -59,7 +57,7 @@ test unknown-4.1 {errors in "unknown" procedure} {
# cleanup
catch {rename unknown {}}
catch {rename unknown.old unknown}
-::tcltest::cleanupTests
+cleanupTests
return
# Local Variables:
diff --git a/tests/var.test b/tests/var.test
index ed7e930..5939100 100644
--- a/tests/var.test
+++ b/tests/var.test
@@ -793,6 +793,75 @@ test var-19.1 {crash when freeing locals hashtable: Bug 3037525} {
foo ; # This crashes without the fix for the bug
rename foo {}
} {}
+
+test var-20.1 {array set compilation correctness: Bug 3603163} -setup {
+ unset -nocomplain x
+} -body {
+ apply {{} {
+ global x
+ array set x {a 1}
+ }}
+ array size x
+} -result 1
+test var-20.2 {array set compilation correctness: Bug 3603163} -setup {
+ unset -nocomplain x
+} -body {
+ apply {{} {
+ global x
+ array set x {}
+ }}
+ array size x
+} -result 0
+test var-20.3 {array set compilation correctness: Bug 3603163} -setup {
+ unset -nocomplain x
+} -body {
+ apply {{} {
+ array set ::x {a 1}
+ }}
+ array size x
+} -result 1
+test var-20.4 {array set compilation correctness: Bug 3603163} -setup {
+ unset -nocomplain x
+} -body {
+ apply {{} {
+ array set ::x {}
+ }}
+ array size x
+} -result 0
+test var-20.5 {array set compilation correctness: Bug 3603163} -setup {
+ unset -nocomplain x
+} -body {
+ apply {{} {
+ global x
+ eval {array set x {a 1}}
+ }}
+ array size x
+} -result 1
+test var-20.6 {array set compilation correctness: Bug 3603163} -setup {
+ unset -nocomplain x
+} -body {
+ apply {{} {
+ global x
+ eval {array set x {}}
+ }}
+ array size x
+} -result 0
+test var-20.7 {array set compilation correctness: Bug 3603163} -setup {
+ unset -nocomplain x
+} -body {
+ apply {{} {
+ eval {array set ::x {a 1}}
+ }}
+ array size x
+} -result 1
+test var-20.8 {array set compilation correctness: Bug 3603163} -setup {
+ unset -nocomplain x
+} -body {
+ apply {{} {
+ eval {array set ::x {}}
+ }}
+ array size x
+} -result 0
catch {namespace delete ns}
catch {unset arr}
diff --git a/tests/zlib.test b/tests/zlib.test
index 891dba0..c469eea 100644
--- a/tests/zlib.test
+++ b/tests/zlib.test
@@ -366,6 +366,25 @@ test zlib-8.15 {transformtion and fconfigure} -setup {
catch {close $inSide}
catch {$strm close}
} -result {358 358}
+test zlib-8.16 {Bug 3603553: buffer transfer with large writes} -setup {
+ # Actual data isn't very important; needs to be substantially larger than
+ # the internal buffer (32kB) and incompressible.
+ set largeData {}
+ for {set i 0;expr srand(1)} {$i < 100000} {incr i} {
+ append largeData [lindex "a b c d e f g h i j k l m n o p" \
+ [expr {int(16*rand())}]]
+ }
+ set file [makeFile {} test.gz]
+} -constraints zlib -body {
+ set f [open $file wb]
+ fconfigure $f -buffering none
+ zlib push gzip $f
+ puts -nonewline $f $largeData
+ close $f
+ file size $file
+} -cleanup {
+ removeFile $file
+} -result 57647
test zlib-9.1 "check fcopy with push" -constraints zlib -setup {
set sfile [makeFile {} testsrc.gz]
diff --git a/unix/Makefile.in b/unix/Makefile.in
index 287f065..d45b139 100644
--- a/unix/Makefile.in
+++ b/unix/Makefile.in
@@ -887,8 +887,8 @@ install-libraries: libraries
@echo "Installing package tcltest 2.3.5 as a Tcl Module";
@$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/tcltest-2.3.5.tm;
- @echo "Installing package platform 1.0.10 as a Tcl Module";
- @$(INSTALL_DATA) $(TOP_DIR)/library/platform/platform.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/platform-1.0.10.tm;
+ @echo "Installing package platform 1.0.11 as a Tcl Module";
+ @$(INSTALL_DATA) $(TOP_DIR)/library/platform/platform.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/platform-1.0.11.tm;
@echo "Installing package platform::shell 1.1.4 as a Tcl Module";
@$(INSTALL_DATA) $(TOP_DIR)/library/platform/shell.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/platform/shell-1.1.4.tm;
@@ -902,10 +902,39 @@ install-libraries: libraries
"$(SCRIPT_INSTALL_DIR)"/tm.tcl; \
fi
-install-tzdata: ${NATIVE_TCLSH}
+install-tzdata:
+ @for i in tzdata; \
+ do \
+ if [ ! -d "$(SCRIPT_INSTALL_DIR)"/$$i ] ; then \
+ echo "Making directory $(SCRIPT_INSTALL_DIR)/$$i"; \
+ $(INSTALL_DATA_DIR) "$(SCRIPT_INSTALL_DIR)"/$$i; \
+ else true; \
+ fi; \
+ done;
@echo "Installing time zone files to $(SCRIPT_INSTALL_DIR)/tzdata/"
- @${NATIVE_TCLSH} $(TOOL_DIR)/installData.tcl \
- $(TOP_DIR)/library/tzdata "$(SCRIPT_INSTALL_DIR)"/tzdata
+ @for i in $(TOP_DIR)/library/tzdata/* ; do \
+ if [ -d $$i ] ; then \
+ ii=`basename $$i`; \
+ if [ ! -d "$(SCRIPT_INSTALL_DIR)"/tzdata/$$ii ] ; then \
+ $(INSTALL_DATA_DIR) "$(SCRIPT_INSTALL_DIR)"/tzdata/$$ii; \
+ fi; \
+ for j in $$i/* ; do \
+ if [ -d $$j ] ; then \
+ jj=`basename $$j`; \
+ if [ ! -d "$(SCRIPT_INSTALL_DIR)"/tzdata/$$ii/$$jj ] ; then \
+ $(INSTALL_DATA_DIR) "$(SCRIPT_INSTALL_DIR)"/tzdata/$$ii/$$jj; \
+ fi; \
+ for k in $$j/* ; do \
+ $(INSTALL_DATA) $$k "$(SCRIPT_INSTALL_DIR)"/tzdata/$$ii/$$jj; \
+ done; \
+ else \
+ $(INSTALL_DATA) $$j "$(SCRIPT_INSTALL_DIR)"/tzdata/$$ii; \
+ fi; \
+ done; \
+ else \
+ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/tzdata; \
+ fi; \
+ done;
install-msgs:
@for i in msgs; \
@@ -1757,7 +1786,7 @@ install-packages: packages
fi; \
done
-test-packages: tcltest packages
+test-packages: ${TCLTEST_EXE} packages
@for i in $(PKGS_DIR)/*; do \
if [ -d $$i ]; then \
pkg=`basename $$i`; \
diff --git a/unix/tclUnixCompat.c b/unix/tclUnixCompat.c
index e201018..2a68f7f 100644
--- a/unix/tclUnixCompat.c
+++ b/unix/tclUnixCompat.c
@@ -995,12 +995,19 @@ TclWinCPUID(
/* See: <http://en.wikipedia.org/wiki/CPUID> */
#if defined(HAVE_CPUID)
- __asm__ __volatile__("mov %%ebx, %%edi \n\t" /* save %ebx */
+#if defined(__x86_64__) || defined(_M_AMD64) || defined (_M_X64)
+ __asm__ __volatile__("movq %%rbx, %%rsi \n\t" /* save %rbx */
"cpuid \n\t"
- "mov %%ebx, %%esi \n\t" /* save what cpuid just put in %ebx */
- "mov %%edi, %%ebx \n\t" /* restore the old %ebx */
+ "xchgq %%rsi, %%rbx \n\t" /* restore the old %rbx */
: "=a"(regsPtr[0]), "=S"(regsPtr[1]), "=c"(regsPtr[2]), "=d"(regsPtr[3])
- : "a"(index) : "edi");
+ : "a"(index));
+#else
+ __asm__ __volatile__("mov %%ebx, %%esi \n\t" /* save %ebx */
+ "cpuid \n\t"
+ "xchg %%esi, %%ebx \n\t" /* restore the old %ebx */
+ : "=a"(regsPtr[0]), "=S"(regsPtr[1]), "=c"(regsPtr[2]), "=d"(regsPtr[3])
+ : "a"(index));
+#endif
status = TCL_OK;
#endif
return status;
diff --git a/unix/tclUnixFCmd.c b/unix/tclUnixFCmd.c
index 559992f..6f443a9 100644
--- a/unix/tclUnixFCmd.c
+++ b/unix/tclUnixFCmd.c
@@ -244,7 +244,7 @@ MODULE_SCOPE long tclMacOSXDarwinRelease;
#endif /* NO_REALPATH */
#ifdef HAVE_FTS
-#ifdef HAVE_STRUCT_STAT64
+#if defined(HAVE_STRUCT_STAT64) && !defined(__APPLE__)
/* fts doesn't do stat64 */
# define noFtsStat 1
#elif defined(__APPLE__) && defined(__LP64__) && \
diff --git a/unix/tclUnixFile.c b/unix/tclUnixFile.c
index 38504d9..5bfe5d9 100644
--- a/unix/tclUnixFile.c
+++ b/unix/tclUnixFile.c
@@ -1181,9 +1181,10 @@ TclpUtime(
int
TclOSstat(
const char *name,
- Tcl_StatBuf *statBuf)
+ void *cygstat)
{
struct stat buf;
+ Tcl_StatBuf *statBuf = cygstat;
int result = stat(name, &buf);
statBuf->st_mode = buf.st_mode;
@@ -1203,9 +1204,10 @@ TclOSstat(
int
TclOSlstat(
const char *name,
- Tcl_StatBuf *statBuf)
+ void *cygstat)
{
struct stat buf;
+ Tcl_StatBuf *statBuf = cygstat;
int result = lstat(name, &buf);
statBuf->st_mode = buf.st_mode;
diff --git a/unix/tclUnixPort.h b/unix/tclUnixPort.h
index 63c500d..59a35ba 100644
--- a/unix/tclUnixPort.h
+++ b/unix/tclUnixPort.h
@@ -21,10 +21,6 @@
#ifndef _TCLUNIXPORT
#define _TCLUNIXPORT
-
-#ifndef MODULE_SCOPE
-#define MODULE_SCOPE extern
-#endif
/*
*---------------------------------------------------------------------------
@@ -89,26 +85,26 @@ typedef off_t Tcl_SeekOffset;
# define SOCKET unsigned int
# define WSAEWOULDBLOCK 10035
typedef unsigned short WCHAR;
- DLLIMPORT extern __stdcall int GetModuleHandleExW(unsigned int, const char *, void *);
- DLLIMPORT extern __stdcall int GetModuleFileNameW(void *, const char *, int);
- DLLIMPORT extern __stdcall int WideCharToMultiByte(int, int, const char *, int,
+ __declspec(dllimport) extern __stdcall int GetModuleHandleExW(unsigned int, const char *, void *);
+ __declspec(dllimport) extern __stdcall int GetModuleFileNameW(void *, const char *, int);
+ __declspec(dllimport) extern __stdcall int WideCharToMultiByte(int, int, const char *, int,
const char *, int, const char *, const char *);
- DLLIMPORT extern __stdcall int MultiByteToWideChar(int, int, const char *, int,
+ __declspec(dllimport) extern __stdcall int MultiByteToWideChar(int, int, const char *, int,
WCHAR *, int);
- DLLIMPORT extern __stdcall void OutputDebugStringW(const WCHAR *);
- DLLIMPORT extern __stdcall int IsDebuggerPresent();
+ __declspec(dllimport) extern __stdcall void OutputDebugStringW(const WCHAR *);
+ __declspec(dllimport) extern __stdcall int IsDebuggerPresent();
- DLLIMPORT extern int cygwin_conv_path(int, const void *, void *, int);
- DLLIMPORT extern int cygwin_conv_path_list(int, const void *, void *, int);
+ __declspec(dllimport) extern int cygwin_conv_path(int, const void *, void *, int);
+ __declspec(dllimport) extern int cygwin_conv_path_list(int, const void *, void *, int);
# define USE_PUTENV 1
# define USE_PUTENV_FOR_UNSET 1
/* On Cygwin, the environment is imported from the Cygwin DLL. */
# define environ __cygwin_environ
# define timezone _timezone
- DLLIMPORT extern char **__cygwin_environ;
- MODULE_SCOPE int TclOSstat(const char *name, Tcl_StatBuf *statBuf);
- MODULE_SCOPE int TclOSlstat(const char *name, Tcl_StatBuf *statBuf);
-#elif defined(HAVE_STRUCT_STAT64)
+ extern char **__cygwin_environ;
+ extern int TclOSstat(const char *name, void *statBuf);
+ extern int TclOSlstat(const char *name, void *statBuf);
+#elif defined(HAVE_STRUCT_STAT64) && !defined(__APPLE__)
# define TclOSstat stat64
# define TclOSlstat lstat64
#else
@@ -126,9 +122,7 @@ typedef off_t Tcl_SeekOffset;
#ifdef HAVE_SYS_SELECT_H
# include <sys/select.h>
#endif
-#ifdef HAVE_SYS_STAT_H
-# include <sys/stat.h>
-#endif
+#include <sys/stat.h>
#if TIME_WITH_SYS_TIME
# include <sys/time.h>
# include <time.h>
@@ -159,7 +153,7 @@ typedef off_t Tcl_SeekOffset;
# include "../compat/unistd.h"
#endif
-MODULE_SCOPE int TclUnixSetBlockingMode(int fd, int mode);
+extern int TclUnixSetBlockingMode(int fd, int mode);
#include <utime.h>
@@ -319,7 +313,7 @@ MODULE_SCOPE int TclUnixSetBlockingMode(int fd, int mode);
#endif
#ifdef GETTOD_NOT_DECLARED
-MODULE_SCOPE int gettimeofday(struct timeval *tp,
+extern int gettimeofday(struct timeval *tp,
struct timezone *tzp);
#endif
@@ -737,15 +731,15 @@ typedef int socklen_t;
#include <pwd.h>
#include <grp.h>
-MODULE_SCOPE struct passwd * TclpGetPwNam(const char *name);
-MODULE_SCOPE struct group * TclpGetGrNam(const char *name);
-MODULE_SCOPE struct passwd * TclpGetPwUid(uid_t uid);
-MODULE_SCOPE struct group * TclpGetGrGid(gid_t gid);
-MODULE_SCOPE struct hostent * TclpGetHostByName(const char *name);
-MODULE_SCOPE struct hostent * TclpGetHostByAddr(const char *addr,
+extern struct passwd * TclpGetPwNam(const char *name);
+extern struct group * TclpGetGrNam(const char *name);
+extern struct passwd * TclpGetPwUid(uid_t uid);
+extern struct group * TclpGetGrGid(gid_t gid);
+extern struct hostent * TclpGetHostByName(const char *name);
+extern struct hostent * TclpGetHostByAddr(const char *addr,
int length, int type);
-MODULE_SCOPE Tcl_Channel TclpMakeTcpClientChannelMode(
- ClientData tcpSocket, int mode);
+extern void *TclpMakeTcpClientChannelMode(
+ void *tcpSocket, int mode);
#endif /* _TCLUNIXPORT */
diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c
index 31daa62..528f009 100644
--- a/unix/tclUnixSock.c
+++ b/unix/tclUnixSock.c
@@ -1202,7 +1202,7 @@ Tcl_Channel
Tcl_MakeTcpClientChannel(
ClientData sock) /* The socket to wrap up into a channel. */
{
- return TclpMakeTcpClientChannelMode(sock, (TCL_READABLE | TCL_WRITABLE));
+ return (Tcl_Channel) TclpMakeTcpClientChannelMode(sock, (TCL_READABLE | TCL_WRITABLE));
}
/*
@@ -1222,9 +1222,9 @@ Tcl_MakeTcpClientChannel(
*----------------------------------------------------------------------
*/
-Tcl_Channel
+void *
TclpMakeTcpClientChannelMode(
- ClientData sock, /* The socket to wrap up into a channel. */
+ void *sock, /* The socket to wrap up into a channel. */
int mode) /* ORed combination of TCL_READABLE and
* TCL_WRITABLE to indicate file mode. */
{
diff --git a/unix/tclUnixTest.c b/unix/tclUnixTest.c
index 46fc972..c10225d 100644
--- a/unix/tclUnixTest.c
+++ b/unix/tclUnixTest.c
@@ -200,7 +200,7 @@ TestfilehandlerCmd(
return TCL_ERROR;
}
sprintf(buf, "%d %d", pipePtr->readCount, pipePtr->writeCount);
- Tcl_SetResult(interp, buf, TCL_VOLATILE);
+ Tcl_AppendResult(interp, buf, NULL);
} else if (strcmp(argv[1], "create") == 0) {
if (argc != 5) {
Tcl_AppendResult(interp, "wrong # arguments: should be \"",
@@ -217,8 +217,8 @@ TestfilehandlerCmd(
fcntl(GetFd(pipePtr->readFile), F_SETFL, O_NONBLOCK);
fcntl(GetFd(pipePtr->writeFile), F_SETFL, O_NONBLOCK);
#else
- Tcl_SetResult(interp, "can't make pipes non-blocking",
- TCL_STATIC);
+ Tcl_AppendResult(interp, "can't make pipes non-blocking",
+ NULL);
return TCL_ERROR;
#endif
}
@@ -281,7 +281,7 @@ TestfilehandlerCmd(
memset(buffer, 'b', 10);
TclFormatInt(buf, write(GetFd(pipePtr->writeFile), buffer, 10));
- Tcl_SetResult(interp, buf, TCL_VOLATILE);
+ Tcl_AppendResult(interp, buf, NULL);
} else if (strcmp(argv[1], "oneevent") == 0) {
Tcl_DoOneEvent(TCL_FILE_EVENTS|TCL_DONT_WAIT);
} else if (strcmp(argv[1], "wait") == 0) {
@@ -390,7 +390,7 @@ TestfilewaitCmd(
if (Tcl_GetChannelHandle(channel,
(mask & TCL_READABLE) ? TCL_READABLE : TCL_WRITABLE,
(ClientData*) &data) != TCL_OK) {
- Tcl_SetResult(interp, "couldn't get channel file", TCL_STATIC);
+ Tcl_AppendResult(interp, "couldn't get channel file", NULL);
return TCL_ERROR;
}
fd = PTR2INT(data);
diff --git a/unix/tclUnixTime.c b/unix/tclUnixTime.c
index c7921fe..926e8f4 100644
--- a/unix/tclUnixTime.c
+++ b/unix/tclUnixTime.c
@@ -503,7 +503,7 @@ SetTZIfNecessary(void)
if (lastTZ == NULL) {
Tcl_CreateExitHandler(CleanupMemory, NULL);
} else {
- Tcl_Free(lastTZ);
+ ckfree(lastTZ);
}
lastTZ = ckalloc(strlen(newTZ) + 1);
strcpy(lastTZ, newTZ);
diff --git a/win/Makefile.in b/win/Makefile.in
index d0e14c6..2764813 100644
--- a/win/Makefile.in
+++ b/win/Makefile.in
@@ -82,6 +82,11 @@ CFLAGS_OPTIMIZE = @CFLAGS_OPTIMIZE@
#CFLAGS = $(CFLAGS_DEBUG) $(CFLAGS_OPTIMIZE)
CFLAGS = @CFLAGS@ @CFLAGS_DEFAULT@ -DUNICODE -D_UNICODE
+# To compile without backward compatibility and deprecated code uncomment the
+# following
+NO_DEPRECATED_FLAGS =
+#NO_DEPRECATED_FLAGS = -DTCL_NO_DEPRECATED
+
# To enable compilation debugging reverse the comment characters on one of the
# following lines.
COMPILE_DEBUG_FLAGS =
@@ -187,7 +192,7 @@ COPY = cp
CC_SWITCHES = ${CFLAGS} ${CFLAGS_WARNING} ${TCL_SHLIB_CFLAGS} -I"${ZLIB_DIR}" \
-I"${GENERIC_DIR_NATIVE}" -DTCL_TOMMATH -DMP_PREC=4 -I"${TOMMATH_DIR_NATIVE}" \
-I"${WIN_DIR_NATIVE}" ${AC_FLAGS} \
-${COMPILE_DEBUG_FLAGS}
+${COMPILE_DEBUG_FLAGS} ${NO_DEPRECATED_FLAGS}
CC_OBJNAME = @CC_OBJNAME@
CC_EXENAME = @CC_EXENAME@
@@ -645,8 +650,8 @@ install-libraries: libraries install-tzdata install-msgs
@$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/msgcat-1.5.0.tm;
@echo "Installing package tcltest 2.3.5 as a Tcl Module";
@$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/tcltest-2.3.5.tm;
- @echo "Installing package platform 1.0.10 as a Tcl Module";
- @$(COPY) $(ROOT_DIR)/library/platform/platform.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.4/platform-1.0.10.tm;
+ @echo "Installing package platform 1.0.11 as a Tcl Module";
+ @$(COPY) $(ROOT_DIR)/library/platform/platform.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.4/platform-1.0.11.tm;
@echo "Installing package platform::shell 1.1.4 as a Tcl Module";
@$(COPY) $(ROOT_DIR)/library/platform/shell.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.4/platform/shell-1.1.4.tm;
@echo "Installing encodings";
diff --git a/win/tcl.m4 b/win/tcl.m4
index 5e8e135..8689cea 100644
--- a/win/tcl.m4
+++ b/win/tcl.m4
@@ -3,50 +3,124 @@
#
# Locate the tclConfig.sh file and perform a sanity check on
# the Tcl compile flags
-# Currently a no-op for Windows
#
# Arguments:
-# PATCH_LEVEL The patch level for Tcl if any.
+# none
#
# Results:
#
# Adds the following arguments to configure:
# --with-tcl=...
#
-# Sets the following vars:
-# TCL_BIN_DIR Full path to the tclConfig.sh file
+# Defines the following vars:
+# TCL_BIN_DIR Full path to the directory containing
+# the tclConfig.sh file
#------------------------------------------------------------------------
AC_DEFUN([SC_PATH_TCLCONFIG], [
- AC_MSG_CHECKING([the location of tclConfig.sh])
+ #
+ # Ok, lets find the tcl configuration
+ # First, look for one uninstalled.
+ # the alternative search directory is invoked by --with-tcl
+ #
- if test -d ../../tcl8.6$1/win; then
- TCL_BIN_DIR_DEFAULT=../../tcl8.6$1/win
- elif test -d ../../tcl8.6/win; then
- TCL_BIN_DIR_DEFAULT=../../tcl8.6/win
- else
- TCL_BIN_DIR_DEFAULT=../../tcl/win
- fi
+ if test x"${no_tcl}" = x ; then
+ # we reset no_tcl in case something fails here
+ no_tcl=true
+ AC_ARG_WITH(tcl,
+ AC_HELP_STRING([--with-tcl],
+ [directory containing tcl configuration (tclConfig.sh)]),
+ with_tclconfig="${withval}")
+ AC_MSG_CHECKING([for Tcl configuration])
+ AC_CACHE_VAL(ac_cv_c_tclconfig,[
+
+ # First check to see if --with-tcl was specified.
+ if test x"${with_tclconfig}" != x ; then
+ case "${with_tclconfig}" in
+ */tclConfig.sh )
+ if test -f "${with_tclconfig}"; then
+ AC_MSG_WARN([--with-tcl argument should refer to directory containing tclConfig.sh, not to tclConfig.sh itself])
+ with_tclconfig="`echo "${with_tclconfig}" | sed 's!/tclConfig\.sh$!!'`"
+ fi ;;
+ esac
+ if test -f "${with_tclconfig}/tclConfig.sh" ; then
+ ac_cv_c_tclconfig="`(cd "${with_tclconfig}"; pwd)`"
+ else
+ AC_MSG_ERROR([${with_tclconfig} directory doesn't contain tclConfig.sh])
+ fi
+ fi
- AC_ARG_WITH(tcl, [ --with-tcl=DIR use Tcl 8.6 binaries from DIR],
- TCL_BIN_DIR=$withval, TCL_BIN_DIR=`cd $TCL_BIN_DIR_DEFAULT; pwd`)
- if test ! -d $TCL_BIN_DIR; then
- AC_MSG_ERROR(Tcl directory $TCL_BIN_DIR does not exist)
- fi
- if test ! -f $TCL_BIN_DIR/tclConfig.sh; then
- if test ! -f $TCL_BIN_DIR/../unix/tclConfig.sh; then
- AC_MSG_ERROR(There is no tclConfig.sh in $TCL_BIN_DIR: perhaps you did not specify the Tcl *build* directory (not the toplevel Tcl directory) or you forgot to configure Tcl?)
+ # then check for a private Tcl installation
+ if test x"${ac_cv_c_tclconfig}" = x ; then
+ for i in \
+ ../tcl \
+ `ls -dr ../tcl[[8-9]].[[0-9]].[[0-9]]* 2>/dev/null` \
+ `ls -dr ../tcl[[8-9]].[[0-9]] 2>/dev/null` \
+ `ls -dr ../tcl[[8-9]].[[0-9]]* 2>/dev/null` \
+ ../../tcl \
+ `ls -dr ../../tcl[[8-9]].[[0-9]].[[0-9]]* 2>/dev/null` \
+ `ls -dr ../../tcl[[8-9]].[[0-9]] 2>/dev/null` \
+ `ls -dr ../../tcl[[8-9]].[[0-9]]* 2>/dev/null` \
+ ../../../tcl \
+ `ls -dr ../../../tcl[[8-9]].[[0-9]].[[0-9]]* 2>/dev/null` \
+ `ls -dr ../../../tcl[[8-9]].[[0-9]] 2>/dev/null` \
+ `ls -dr ../../../tcl[[8-9]].[[0-9]]* 2>/dev/null` ; do
+ if test -f "$i/win/tclConfig.sh" ; then
+ ac_cv_c_tclconfig="`(cd $i/win; pwd)`"
+ break
+ fi
+ done
+ fi
+
+ # check in a few common install locations
+ if test x"${ac_cv_c_tclconfig}" = x ; then
+ for i in `ls -d ${libdir} 2>/dev/null` \
+ `ls -d ${exec_prefix}/lib 2>/dev/null` \
+ `ls -d ${prefix}/lib 2>/dev/null` \
+ `ls -d /cygdrive/c/Tcl/lib 2>/dev/null` \
+ `ls -d /cygdrive/c/Progra~1/Tcl/lib 2>/dev/null` \
+ `ls -d /c/Tcl/lib 2>/dev/null` \
+ `ls -d /c/Progra~1/Tcl/lib 2>/dev/null` \
+ `ls -d C:/Tcl/lib 2>/dev/null` \
+ `ls -d C:/Progra~1/Tcl/lib 2>/dev/null` \
+ ; do
+ if test -f "$i/tclConfig.sh" ; then
+ ac_cv_c_tclconfig="`(cd $i; pwd)`"
+ break
+ fi
+ done
+ fi
+
+ # check in a few other private locations
+ if test x"${ac_cv_c_tclconfig}" = x ; then
+ for i in \
+ ${srcdir}/../tcl \
+ `ls -dr ${srcdir}/../tcl[[8-9]].[[0-9]].[[0-9]]* 2>/dev/null` \
+ `ls -dr ${srcdir}/../tcl[[8-9]].[[0-9]] 2>/dev/null` \
+ `ls -dr ${srcdir}/../tcl[[8-9]].[[0-9]]* 2>/dev/null` ; do
+ if test -f "$i/win/tclConfig.sh" ; then
+ ac_cv_c_tclconfig="`(cd $i/win; pwd)`"
+ break
+ fi
+ done
+ fi
+ ])
+
+ if test x"${ac_cv_c_tclconfig}" = x ; then
+ TCL_BIN_DIR="# no Tcl configs found"
+ AC_MSG_ERROR([Can't find Tcl configuration definitions. Use --with-tcl to specify a directory containing tclConfig.sh])
+ else
+ no_tcl=
+ TCL_BIN_DIR="${ac_cv_c_tclconfig}"
+ AC_MSG_RESULT([found ${TCL_BIN_DIR}/tclConfig.sh])
fi
- TCL_BIN_DIR=`cd ${TCL_BIN_DIR}/../unix; pwd`
fi
- AC_MSG_RESULT($TCL_BIN_DIR/tclConfig.sh)
])
#------------------------------------------------------------------------
# SC_PATH_TKCONFIG --
#
# Locate the tkConfig.sh file
-# Currently a no-op for Windows
#
# Arguments:
# none
@@ -56,31 +130,109 @@ AC_DEFUN([SC_PATH_TCLCONFIG], [
# Adds the following arguments to configure:
# --with-tk=...
#
-# Sets the following vars:
-# TK_BIN_DIR Full path to the tkConfig.sh file
+# Defines the following vars:
+# TK_BIN_DIR Full path to the directory containing
+# the tkConfig.sh file
#------------------------------------------------------------------------
AC_DEFUN([SC_PATH_TKCONFIG], [
- AC_MSG_CHECKING([the location of tkConfig.sh])
+ #
+ # Ok, lets find the tk configuration
+ # First, look for one uninstalled.
+ # the alternative search directory is invoked by --with-tk
+ #
- if test -d ../../tk8.6$1/win; then
- TK_BIN_DIR_DEFAULT=../../tk8.6$1/win
- elif test -d ../../tk8.6/win; then
- TK_BIN_DIR_DEFAULT=../../tk8.6/win
- else
- TK_BIN_DIR_DEFAULT=../../tk/win
- fi
+ if test x"${no_tk}" = x ; then
+ # we reset no_tk in case something fails here
+ no_tk=true
+ AC_ARG_WITH(tk,
+ AC_HELP_STRING([--with-tk],
+ [directory containing tk configuration (tkConfig.sh)]),
+ with_tkconfig="${withval}")
+ AC_MSG_CHECKING([for Tk configuration])
+ AC_CACHE_VAL(ac_cv_c_tkconfig,[
+
+ # First check to see if --with-tkconfig was specified.
+ if test x"${with_tkconfig}" != x ; then
+ case "${with_tkconfig}" in
+ */tkConfig.sh )
+ if test -f "${with_tkconfig}"; then
+ AC_MSG_WARN([--with-tk argument should refer to directory containing tkConfig.sh, not to tkConfig.sh itself])
+ with_tkconfig="`echo "${with_tkconfig}" | sed 's!/tkConfig\.sh$!!'`"
+ fi ;;
+ esac
+ if test -f "${with_tkconfig}/tkConfig.sh" ; then
+ ac_cv_c_tkconfig="`(cd "${with_tkconfig}"; pwd)`"
+ else
+ AC_MSG_ERROR([${with_tkconfig} directory doesn't contain tkConfig.sh])
+ fi
+ fi
- AC_ARG_WITH(tk, [ --with-tk=DIR use Tk 8.6 binaries from DIR],
- TK_BIN_DIR=$withval, TK_BIN_DIR=`cd $TK_BIN_DIR_DEFAULT; pwd`)
- if test ! -d $TK_BIN_DIR; then
- AC_MSG_ERROR(Tk directory $TK_BIN_DIR does not exist)
- fi
- if test ! -f $TK_BIN_DIR/tkConfig.sh; then
- AC_MSG_ERROR(There is no tkConfig.sh in $TK_BIN_DIR: perhaps you did not specify the Tk *build* directory (not the toplevel Tk directory) or you forgot to configure Tk?)
- fi
+ # then check for a private Tk library
+ if test x"${ac_cv_c_tkconfig}" = x ; then
+ for i in \
+ ../tk \
+ `ls -dr ../tk[[8-9]].[[0-9]].[[0-9]]* 2>/dev/null` \
+ `ls -dr ../tk[[8-9]].[[0-9]] 2>/dev/null` \
+ `ls -dr ../tk[[8-9]].[[0-9]]* 2>/dev/null` \
+ ../../tk \
+ `ls -dr ../../tk[[8-9]].[[0-9]].[[0-9]]* 2>/dev/null` \
+ `ls -dr ../../tk[[8-9]].[[0-9]] 2>/dev/null` \
+ `ls -dr ../../tk[[8-9]].[[0-9]]* 2>/dev/null` \
+ ../../../tk \
+ `ls -dr ../../../tk[[8-9]].[[0-9]].[[0-9]]* 2>/dev/null` \
+ `ls -dr ../../../tk[[8-9]].[[0-9]] 2>/dev/null` \
+ `ls -dr ../../../tk[[8-9]].[[0-9]]* 2>/dev/null` ; do
+ if test -f "$i/win/tkConfig.sh" ; then
+ ac_cv_c_tkconfig="`(cd $i/win; pwd)`"
+ break
+ fi
+ done
+ fi
- AC_MSG_RESULT([$TK_BIN_DIR/tkConfig.sh])
+ # check in a few common install locations
+ if test x"${ac_cv_c_tkconfig}" = x ; then
+ for i in `ls -d ${libdir} 2>/dev/null` \
+ `ls -d ${exec_prefix}/lib 2>/dev/null` \
+ `ls -d ${prefix}/lib 2>/dev/null` \
+ `ls -d /cygdrive/c/Tcl/lib 2>/dev/null` \
+ `ls -d /cygdrive/c/Progra~1/Tcl/lib 2>/dev/null` \
+ `ls -d /c/Tcl/lib 2>/dev/null` \
+ `ls -d /c/Progra~1/Tcl/lib 2>/dev/null` \
+ `ls -d C:/Tcl/lib 2>/dev/null` \
+ `ls -d C:/Progra~1/Tcl/lib 2>/dev/null` \
+ ; do
+ if test -f "$i/tkConfig.sh" ; then
+ ac_cv_c_tkconfig="`(cd $i; pwd)`"
+ break
+ fi
+ done
+ fi
+
+ # check in a few other private locations
+ if test x"${ac_cv_c_tkconfig}" = x ; then
+ for i in \
+ ${srcdir}/../tk \
+ `ls -dr ${srcdir}/../tk[[8-9]].[[0-9]].[[0-9]]* 2>/dev/null` \
+ `ls -dr ${srcdir}/../tk[[8-9]].[[0-9]] 2>/dev/null` \
+ `ls -dr ${srcdir}/../tk[[8-9]].[[0-9]]* 2>/dev/null` ; do
+ if test -f "$i/win/tkConfig.sh" ; then
+ ac_cv_c_tkconfig="`(cd $i/win; pwd)`"
+ break
+ fi
+ done
+ fi
+ ])
+
+ if test x"${ac_cv_c_tkconfig}" = x ; then
+ TK_BIN_DIR="# no Tk configs found"
+ AC_MSG_ERROR([Can't find Tk configuration definitions. Use --with-tk to specify a directory containing tkConfig.sh])
+ else
+ no_tk=
+ TK_BIN_DIR="${ac_cv_c_tkconfig}"
+ AC_MSG_RESULT([found ${TK_BIN_DIR}/tkConfig.sh])
+ fi
+ fi
])
#------------------------------------------------------------------------
diff --git a/win/tclWinConsole.c b/win/tclWinConsole.c
index 5aab255..65e4aed 100644
--- a/win/tclWinConsole.c
+++ b/win/tclWinConsole.c
@@ -11,7 +11,6 @@
*/
#include "tclWinInt.h"
-#include <sys/stat.h>
/*
* The following variable is used to tell whether this module has been
diff --git a/win/tclWinFile.c b/win/tclWinFile.c
index a4512ec..18b05d6 100644
--- a/win/tclWinFile.c
+++ b/win/tclWinFile.c
@@ -15,7 +15,6 @@
#include "tclWinInt.h"
#include "tclFileSystem.h"
#include <winioctl.h>
-#include <sys/stat.h>
#include <shlobj.h>
#include <lm.h> /* For TclpGetUserHome(). */
@@ -2476,6 +2475,12 @@ TclpObjNormalizePath(
}
Tcl_DStringAppend(&dsNorm, nativePath, len);
lastValidPathEnd = currentPathEndPosition;
+ } else if (nextCheckpoint == 0) {
+ /* Path starts with a drive designation
+ * that's not actually on the system.
+ * We still must normalize up past the
+ * first separator. [Bug 3603434] */
+ currentPathEndPosition++;
}
}
Tcl_DStringFree(&ds);
@@ -2616,6 +2621,12 @@ TclpObjNormalizePath(
(const char *)nativePath,
(int)(sizeof(WCHAR) * len));
lastValidPathEnd = currentPathEndPosition;
+ } else if (nextCheckpoint == 0) {
+ /* Path starts with a drive designation
+ * that's not actually on the system.
+ * We still must normalize up past the
+ * first separator. [Bug 3603434] */
+ currentPathEndPosition++;
}
}
Tcl_DStringFree(&ds);
diff --git a/win/tclWinPipe.c b/win/tclWinPipe.c
index 36ae58a..d418a3e 100644
--- a/win/tclWinPipe.c
+++ b/win/tclWinPipe.c
@@ -12,8 +12,6 @@
#include "tclWinInt.h"
-#include <sys/stat.h>
-
/*
* The following variable is used to tell whether this module has been
* initialized.
diff --git a/win/tclWinSerial.c b/win/tclWinSerial.c
index 458b05b..75d5ffc 100644
--- a/win/tclWinSerial.c
+++ b/win/tclWinSerial.c
@@ -14,8 +14,6 @@
#include "tclWinInt.h"
-#include <sys/stat.h>
-
/*
* The following variable is used to tell whether this module has been
* initialized.
diff --git a/win/tclWinTest.c b/win/tclWinTest.c
index 136c4db..b83c0ba 100644
--- a/win/tclWinTest.c
+++ b/win/tclWinTest.c
@@ -211,7 +211,7 @@ TestvolumetypeCmd(
TclWinConvertError(GetLastError());
return TCL_ERROR;
}
- Tcl_SetResult(interp, volType, TCL_VOLATILE);
+ Tcl_AppendResult(interp, volType, NULL);
return TCL_OK;
#undef VOL_BUF_SIZE
}
diff --git a/win/tclWinThrd.c b/win/tclWinThrd.c
index 7b0f6f8..1c9d483 100644
--- a/win/tclWinThrd.c
+++ b/win/tclWinThrd.c
@@ -14,7 +14,6 @@
#include "tclWinInt.h"
#include <float.h>
-#include <sys/stat.h>
/* Workaround for mingw versions which don't provide this in float.h */
#ifndef _MCW_EM