summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordgp <dgp@users.sourceforge.net>2013-01-31 05:17:33 (GMT)
committerdgp <dgp@users.sourceforge.net>2013-01-31 05:17:33 (GMT)
commit15624be5c60333dd6c9ca7a0b651fda1d92e7b7c (patch)
treed6af24523cb86d4a3b20a3e66c16644dadc319b2
parent6d8a36d84d2843681302604a082e2f787c3c3674 (diff)
parentf50bf4d17a2021e535f47e5253e24bd3dc1269b5 (diff)
downloadtcl-contrib_patrick_fradin_code_cleanup.zip
tcl-contrib_patrick_fradin_code_cleanup.tar.gz
tcl-contrib_patrick_fradin_code_cleanup.tar.bz2
-rw-r--r--ChangeLog179
-rw-r--r--compat/dirent2.h2
-rw-r--r--compat/dlfcn.h2
-rw-r--r--compat/string.h2
-rw-r--r--compat/unistd.h1
-rw-r--r--doc/CrtChannel.34
-rw-r--r--doc/InitStubs.36
-rw-r--r--doc/fconfigure.n4
-rw-r--r--doc/fileevent.n17
-rw-r--r--doc/namespace.n2
-rw-r--r--doc/string.n49
-rw-r--r--generic/tcl.h9
-rw-r--r--generic/tclAssembly.c10
-rw-r--r--generic/tclBasic.c166
-rw-r--r--generic/tclBinary.c50
-rw-r--r--generic/tclCkalloc.c4
-rw-r--r--generic/tclCmdAH.c69
-rw-r--r--generic/tclCmdIL.c40
-rw-r--r--generic/tclCmdMZ.c22
-rw-r--r--generic/tclCompCmds.c125
-rw-r--r--generic/tclCompCmdsSZ.c16
-rw-r--r--generic/tclCompile.c5
-rw-r--r--generic/tclCompile.h4
-rw-r--r--generic/tclDecls.h12
-rw-r--r--generic/tclDictObj.c12
-rw-r--r--generic/tclEncoding.c1
-rw-r--r--generic/tclEnsemble.c656
-rw-r--r--generic/tclExecute.c326
-rw-r--r--generic/tclFCmd.c1
-rw-r--r--generic/tclFileName.c1
-rw-r--r--generic/tclIOCmd.c38
-rw-r--r--generic/tclIORTrans.c6
-rw-r--r--generic/tclIOUtil.c4
-rw-r--r--generic/tclIndexObj.c20
-rw-r--r--generic/tclInt.decls52
-rw-r--r--generic/tclInt.h80
-rw-r--r--generic/tclIntDecls.h123
-rw-r--r--generic/tclInterp.c4
-rw-r--r--generic/tclListObj.c17
-rw-r--r--generic/tclNamesp.c24
-rw-r--r--generic/tclOO.c2
-rw-r--r--generic/tclOOInfo.c44
-rw-r--r--generic/tclOOStubLib.c72
-rw-r--r--generic/tclPort.h5
-rw-r--r--generic/tclResult.c2
-rw-r--r--generic/tclStubInit.c40
-rw-r--r--generic/tclStubLib.c24
-rw-r--r--generic/tclTest.c1
-rw-r--r--generic/tclTestObj.c11
-rw-r--r--generic/tclThreadTest.c4
-rw-r--r--generic/tclTomMathInterface.c6
-rw-r--r--generic/tclTomMathStubLib.c32
-rw-r--r--generic/tclTrace.c2
-rw-r--r--generic/tclUtil.c22
-rw-r--r--generic/tclVar.c140
-rw-r--r--generic/tclZlib.c2
-rw-r--r--library/auto.tcl44
-rw-r--r--library/http/http.tcl70
-rw-r--r--library/http/pkgIndex.tcl2
-rw-r--r--library/init.tcl104
-rw-r--r--library/msgcat/msgcat.tcl10
-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.tcl259
-rw-r--r--library/tm.tcl16
-rw-r--r--library/word.tcl12
-rw-r--r--macosx/tclMacOSXFCmd.c1
-rw-r--r--tests/assocd.test14
-rw-r--r--tests/basic.test18
-rw-r--r--tests/cmdInfo.test12
-rw-r--r--tests/dcall.test8
-rw-r--r--tests/env.test2
-rw-r--r--tests/exec.test2
-rw-r--r--tests/expr-old.test20
-rw-r--r--tests/http.test7
-rw-r--r--tests/info.test25
-rw-r--r--tests/listObj.test4
-rw-r--r--tests/main.test4
-rw-r--r--tests/msgcat.test8
-rw-r--r--tests/nre.test25
-rw-r--r--tests/parse.test9
-rw-r--r--tests/parseExpr.test8
-rw-r--r--tests/parseOld.test15
-rw-r--r--tests/pkgMkIndex.test30
-rw-r--r--tests/platform.test17
-rw-r--r--tests/result.test6
-rw-r--r--tests/stack.test6
-rwxr-xr-xtests/tcltest.test21
-rw-r--r--tests/thread.test107
-rw-r--r--tests/tm.test10
-rw-r--r--tests/trace.test512
-rw-r--r--tests/unixInit.test14
-rw-r--r--tests/unknown.test12
-rw-r--r--unix/Makefile.in10
-rw-r--r--unix/dltest/pkgb.c48
-rw-r--r--unix/tclUnixCompat.c15
-rw-r--r--unix/tclUnixFCmd.c3
-rw-r--r--unix/tclUnixFile.c7
-rw-r--r--unix/tclUnixInit.c1
-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.in17
-rw-r--r--win/tcl.m4236
-rw-r--r--win/tclWinFile.c13
-rw-r--r--win/tclWinTest.c2
108 files changed, 2711 insertions, 1751 deletions
diff --git a/ChangeLog b/ChangeLog
index 4995a93..a329282 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,181 @@
+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: [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.
+
+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.
+
+2013-01-09 Jan Nijtmans <nijtmans@users.sf.net>
+
+ * library/http/http.tcl: [Bug 3599395]: http assumes status line is a
+ proper Tcl list.
+
+2013-01-08 Jan Nijtmans <nijtmans@users.sf.net>
+
+ * win/tclWinFile.c: [Bug 3092089]: [file normalize] can remove path
+ components. [Bug 3587096] win vista/7: "can't find init.tcl" when
+ called via junction without folder list access.
+
+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.
+
+2013-01-06 Jan Nijtmans <nijtmans@users.sf.net>
+
+ * library/http/http.tcl: Don't depend on Spencer-specific regexp
+ * tests/env.test: syntax (/u and /U) any more in unrelated places.
+ * tests/exec.test:
+ Bump http package to 2.8.6.
+
+2013-01-04 Donal K. Fellows <dkf@users.sf.net>
+
+ * generic/tclEnsemble.c (CompileBasicNArgCommand): Added very simple
+ compiler (which just compiles to a normal invoke of the implementation
+ command) for many ensemble subcommands where we can prove that there
+ is no way for scripts to detect the difference even through error
+ handling or [info level]/[info frame]. This improves the code produced
+ from some ensembles (e.g., [info], [string]) to the point where the
+ ensemble is now not normally seen at the bytecode level at all.
+
+2013-01-04 Miguel Sofer <msofer@users.sf.net>
+
+ * generic/tclInt.h: Insure that PURIFY builds cannot exploit the
+ * generic/tclExecute.c: Tcl stack to hide mem defects.
+
+2013-01-03 Donal K. Fellows <dkf@users.sf.net>
+
+ * doc/fconfigure.n, doc/CrtChannel.3: Updated to reflect the fact that
+ the minimum buffer size is one byte, not ten. Identified by Schelte
+ Bron on the Tcler's Chat.
+
+ * generic/tclExecute.c (TEBCresume:INST_INVOKE_REPLACE):
+ * generic/tclEnsemble.c (TclCompileEnsemble): Added new mechanism to
+ allow for more efficient dispatch of non-bytecode-compiled subcommands
+ of bytecode-compiled ensembles. This can provide substantial speed
+ benefits in some cases.
+
+2013-01-02 Miguel Sofer <msofer@users.sf.net>
+
+ * generic/tclEnsemble.c: Remove stray calls to Tcl_Alloc and friends:
+ * generic/tclExecute.c: the core should only use ckalloc to allow
+ * generic/tclIORTrans.c: MEM_DEBUG to work properly.
+ * generic/tclTomMathInterface.c:
+
+2012-12-31 Donal K. Fellows <dkf@users.sf.net>
+
+ * doc/string.n: Noted the obsolescence of the 'bytelength',
+ 'wordstart' and 'wordend' subcommands, and moved them to later in the
+ file.
+
+2012-12-27 Jan Nijtmans <nijtmans@users.sf.net>
+
+ * generic/tclListObj.c: [Bug 3598580]: Tcl_ListObjReplace may release
+ deleted elements too early.
+
+2012-12-22 Alexandre Ferrieux <ferrieux@users.sourceforge.net>
+
+ * generic/tclUtil.c: Stop leaking allocated space when objifying a
+ zero-length DString. [Bug 3598150] spotted by afredd.
+
+2012-12-21 Jan Nijtmans <nijtmans@users.sf.net>
+
+ * unix/dltest/pkgb.c: Inline compat Tcl_GetDefaultEncodingDir.
+ * generic/tclStubLib.c: Eliminate unnecessary static HasStubSupport()
+ and isDigit() functions, just do the same inline.
+
2012-12-18 Donal K. Fellows <dkf@users.sf.net>
* generic/tclCompCmdsSZ.c (TclSubstCompile): Improved the sequence of
@@ -4030,6 +4208,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/compat/dirent2.h b/compat/dirent2.h
index 878457f..5be08ba 100644
--- a/compat/dirent2.h
+++ b/compat/dirent2.h
@@ -14,8 +14,6 @@
#ifndef _DIRENT
#define _DIRENT
-#include "tcl.h"
-
/*
* Dirent structure, which holds information about a single
* directory entry.
diff --git a/compat/dlfcn.h b/compat/dlfcn.h
index 6940c2a..fb27ea0 100644
--- a/compat/dlfcn.h
+++ b/compat/dlfcn.h
@@ -26,8 +26,6 @@
#ifndef __dlfcn_h__
#define __dlfcn_h__
-#include "tcl.h"
-
#ifdef __cplusplus
extern "C" {
#endif
diff --git a/compat/string.h b/compat/string.h
index 84ee094..42be10c 100644
--- a/compat/string.h
+++ b/compat/string.h
@@ -13,8 +13,6 @@
#ifndef _STRING
#define _STRING
-#include "tcl.h"
-
/*
* The following #include is needed to define size_t. (This used to include
* sys/stdtypes.h but that doesn't exist on older versions of SunOS, e.g.
diff --git a/compat/unistd.h b/compat/unistd.h
index 6779e74..2de5bd0 100644
--- a/compat/unistd.h
+++ b/compat/unistd.h
@@ -14,7 +14,6 @@
#ifndef _UNISTD
#define _UNISTD
-#include "tcl.h"
#include <sys/types.h>
#ifndef NULL
diff --git a/doc/CrtChannel.3 b/doc/CrtChannel.3
index 55a4024..57bb76e 100644
--- a/doc/CrtChannel.3
+++ b/doc/CrtChannel.3
@@ -250,8 +250,8 @@ the default value of 4096 is returned.
.PP
\fBTcl_SetChannelBufferSize\fR sets the size, in bytes, of buffers that
will be allocated in subsequent operations on the channel to store input or
-output. The \fIsize\fR argument should be between ten and one million,
-allowing buffers of ten bytes to one million bytes. If \fIsize\fR is
+output. The \fIsize\fR argument should be between one and one million,
+allowing buffers of one byte to one million bytes. If \fIsize\fR is
outside this range, \fBTcl_SetChannelBufferSize\fR sets the buffer size to
4096.
.PP
diff --git a/doc/InitStubs.3 b/doc/InitStubs.3
index 5f56278..4dc62c6 100644
--- a/doc/InitStubs.3
+++ b/doc/InitStubs.3
@@ -63,9 +63,9 @@ Define the \fBUSE_TCL_STUBS\fR symbol. Typically, you would include the
\fB\-DUSE_TCL_STUBS\fR flag when compiling the extension.
.IP 3) 5
Link the extension with the Tcl stubs library instead of the standard
-Tcl library. For example, to use the Tcl 8.1 ABI on Unix platforms,
-the library name is \fIlibtclstub8.1.a\fR; on Windows platforms, the
-library name is \fItclstub81.lib\fR.
+Tcl library. For example, to use the Tcl 8.6 ABI on Unix platforms,
+the library name is \fIlibtclstub8.6.a\fR; on Windows platforms, the
+library name is \fItclstub86.lib\fR.
.PP
If the extension also requires the Tk API, it must also call
\fBTk_InitStubs\fR to initialize the Tk stubs interface and link
diff --git a/doc/fconfigure.n b/doc/fconfigure.n
index ac0366c..550d071 100644
--- a/doc/fconfigure.n
+++ b/doc/fconfigure.n
@@ -72,8 +72,8 @@ initially set to \fBline\fR, and \fBstderr\fR is set to \fBnone\fR.
.
\fINewvalue\fR must be an integer; its value is used to set the size of
buffers, in bytes, subsequently allocated for this channel to store input
-or output. \fINewvalue\fR must be between ten and one million, allowing
-buffers of ten to one million bytes in size.
+or output. \fINewvalue\fR must be between one and one million, allowing
+buffers of one to one million bytes in size.
.TP
\fB\-encoding\fR \fIname\fR
.
diff --git a/doc/fileevent.n b/doc/fileevent.n
index df48d2a..e453748 100644
--- a/doc/fileevent.n
+++ b/doc/fileevent.n
@@ -80,13 +80,16 @@ A channel is considered to be writable if at least one byte of data
can be written to the underlying file or device without blocking,
or if an error condition is present on the underlying file or device.
.PP
-Event-driven I/O works best for channels that have been
-placed into nonblocking mode with the \fBfconfigure\fR command.
-In blocking mode, a \fBputs\fR command may block if you give it
-more data than the underlying file or device can accept, and a
-\fBgets\fR or \fBread\fR command will block if you attempt to read
-more data than is ready; no events will be processed while the
-commands block.
+Event-driven I/O works best for channels that have been placed into
+nonblocking mode with the \fBfconfigure\fR command. In blocking mode,
+a \fBputs\fR command may block if you give it more data than the
+underlying file or device can accept, and a \fBgets\fR or \fBread\fR
+command will block if you attempt to read more data than is ready; a
+readable underlying file or device may not even guarantee that a
+blocking [read 1] will succeed (counter-examples being multi-byte
+encodings, compression or encryption transforms ). In all such cases,
+no events will be processed while the commands block.
+.PP
In nonblocking mode \fBputs\fR, \fBread\fR, and \fBgets\fR never block.
See the documentation for the individual commands for information
on how they handle blocking and nonblocking channels.
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 6b3cc59..351c865 100644
--- a/doc/string.n
+++ b/doc/string.n
@@ -19,27 +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 bytelength \fIstring\fR
-.
-Returns a decimal string giving the number of bytes used to represent
-\fIstring\fR in memory. Because UTF\-8 uses one to three bytes to
-represent Unicode characters, the byte length will not be the same as
-the character length in general. The cases where a script cares about
-the byte length are rare.
-.RS
-.PP
-In almost all cases, you should use the
-\fBstring length\fR operation (including determining the length of a
-Tcl byte array value). Refer to the \fBTcl_NumUtfChars\fR manual
-entry for more details on the UTF\-8 representation.
-.PP
-\fICompatibility note:\fR it is likely that this subcommand will be
-withdrawn in a future version of Tcl. It is better to use the
-\fBencoding convertto\fR command to convert a string to a known
-encoding and then apply \fBstring length\fR to that.
-.RE
-.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
@@ -49,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
@@ -354,6 +334,31 @@ Returns a value equal to \fIstring\fR except that any trailing
characters present in the string given by \fIchars\fR are removed. If
\fIchars\fR is not specified then white space is removed (any character
for which \fBstring is space\fR returns 1, and "\0").
+.SS "OBSOLETE SUBCOMMANDS"
+.PP
+These subcommands are currently supported, but are likely to go away in a
+future release as their functionality is either virtually never used or highly
+misleading.
+.TP
+\fBstring bytelength \fIstring\fR
+.
+Returns a decimal string giving the number of bytes used to represent
+\fIstring\fR in memory. Because UTF\-8 uses one to three bytes to
+represent Unicode characters, the byte length will not be the same as
+the character length in general. The cases where a script cares about
+the byte length are rare.
+.RS
+.PP
+In almost all cases, you should use the
+\fBstring length\fR operation (including determining the length of a
+Tcl byte array value). Refer to the \fBTcl_NumUtfChars\fR manual
+entry for more details on the UTF\-8 representation.
+.PP
+\fICompatibility note:\fR it is likely that this subcommand will be
+withdrawn in a future version of Tcl. It is better to use the
+\fBencoding convertto\fR command to convert a string to a known
+encoding and then apply \fBstring length\fR to that.
+.RE
.TP
\fBstring wordend \fIstring charIndex\fR
.
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 7833105..c4eeded 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;
}
@@ -4270,11 +4268,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");
}
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 562cca6..4d5b715 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -160,10 +160,7 @@ static Tcl_NRPostProc TEOV_Exception;
static Tcl_NRPostProc TEOV_NotFoundCallback;
static Tcl_NRPostProc TEOV_RestoreVarFrame;
static Tcl_NRPostProc TEOV_RunLeaveTraces;
-static Tcl_NRPostProc YieldToCallback;
-static void ClearTailcall(Tcl_Interp *interp,
- struct NRE_callback *tailcallPtr);
static Tcl_ObjCmdProc NRCoroInjectObjCmd;
MODULE_SCOPE const TclStubs tclStubs;
@@ -4161,7 +4158,8 @@ TclNREvalObjv(
int result;
Namespace *lookupNsPtr = iPtr->lookupNsPtr;
Command **cmdPtrPtr;
-
+ NRE_callback *callbackPtr;
+
iPtr->lookupNsPtr = NULL;
/*
@@ -4174,15 +4172,14 @@ TclNREvalObjv(
* finishes the source command and not just the target.
*/
- if (iPtr->evalFlags & TCL_EVAL_REDIRECT) {
- TclNRAddCallback(interp, NRCommand, NULL, INT2PTR(1), INT2PTR(objc), objv);
- iPtr->evalFlags &= ~TCL_EVAL_REDIRECT;
+ if (iPtr->deferredCallbacks) {
+ callbackPtr = iPtr->deferredCallbacks;
+ iPtr->deferredCallbacks = NULL;
} else {
- TclNRAddCallback(interp, NRCommand, NULL, NULL, INT2PTR(objc), objv);
+ TclNRAddCallback(interp, NRCommand, NULL, NULL, NULL, NULL);
+ callbackPtr = TOP_CB(interp);
}
- cmdPtrPtr = (Command **) &(TOP_CB(interp)->data[0]);
-
- TclNRSpliceDeferred(interp);
+ cmdPtrPtr = (Command **) &(callbackPtr->data[0]);
iPtr->numLevels++;
result = TclInterpReady(interp);
@@ -4309,14 +4306,6 @@ TclNREvalObjv(
}
}
-void
-TclPushTailcallPoint(
- Tcl_Interp *interp)
-{
- TclNRAddCallback(interp, NRCommand, NULL, NULL, NULL, NULL);
- ((Interp *) interp)->numLevels++;
-}
-
int
TclNRRunCallbacks(
Tcl_Interp *interp,
@@ -4368,6 +4357,14 @@ NRCommand(
}
((Interp *)interp)->numLevels--;
+ /*
+ * If there is a tailcall, schedule it
+ */
+
+ if (data[1] && (data[1] != INT2PTR(1))) {
+ TclNRAddCallback(interp, TclNRTailcallEval, data[1], NULL, NULL, NULL);
+ }
+
/* OPT ??
* Do not interrupt a series of cleanups with async or limit checks:
* just check at the end?
@@ -4625,9 +4622,9 @@ TEOV_NotFound(
savedNsPtr = varFramePtr->nsPtr;
varFramePtr->nsPtr = lookupNsPtr;
}
- TclNRDeferCallback(interp, TEOV_NotFoundCallback, INT2PTR(handlerObjc),
+ TclSkipTailcall(interp);
+ TclNRAddCallback(interp, TEOV_NotFoundCallback, INT2PTR(handlerObjc),
newObjv, savedNsPtr, NULL);
- iPtr->evalFlags |= TCL_EVAL_REDIRECT;
return TclNREvalObjv(interp, newObjc, newObjv, TCL_EVAL_NOERR, NULL);
}
@@ -5849,7 +5846,6 @@ Tcl_Eval(
*----------------------------------------------------------------------
*/
-#undef Tcl_EvalObj
int
Tcl_EvalObj(
Tcl_Interp *interp,
@@ -5857,7 +5853,6 @@ Tcl_EvalObj(
{
return Tcl_EvalObjEx(interp, objPtr, 0);
}
-#undef Tcl_GlobalEvalObj
int
Tcl_GlobalEvalObj(
Tcl_Interp *interp,
@@ -6012,7 +6007,8 @@ TclNREvalObjEx(
iPtr->cmdFramePtr = eoFramePtr;
}
- TclNRDeferCallback(interp, TEOEx_ListCallback, listPtr, eoFramePtr,
+ TclMarkTailcall(interp);
+ TclNRAddCallback(interp, TEOEx_ListCallback, listPtr, eoFramePtr,
NULL, NULL);
ListObjGetElements(listPtr, objc, objv);
@@ -8269,29 +8265,58 @@ Tcl_NRCmdSwap(
*/
void
-TclSpliceTailcall(
+TclMarkTailcall(
+ Tcl_Interp *interp)
+{
+ Interp *iPtr = (Interp *) interp;
+
+ if (iPtr->deferredCallbacks == NULL) {
+ TclNRAddCallback(interp, NRCommand, NULL, NULL,
+ NULL, NULL);
+ iPtr->deferredCallbacks = TOP_CB(interp);
+ }
+}
+
+void
+TclSkipTailcall(
+ Tcl_Interp *interp)
+{
+ Interp *iPtr = (Interp *) interp;
+
+ TclMarkTailcall(interp);
+ iPtr->deferredCallbacks->data[1] = INT2PTR(1);
+}
+
+void
+TclPushTailcallPoint(
+ Tcl_Interp *interp)
+{
+ TclNRAddCallback(interp, NRCommand, NULL, NULL, NULL, NULL);
+ ((Interp *) interp)->numLevels++;
+}
+
+void
+TclSetTailcall(
Tcl_Interp *interp,
- NRE_callback *tailcallPtr)
+ Tcl_Obj *listPtr)
{
/*
* Find the splicing spot: right before the NRCommand of the thing
- * being tailcalled. Note that we skip NRCommands marked in data[1]
+ * being tailcalled. Note that we skip NRCommands marked by a 1 in data[1]
* (used by command redirectors).
*/
NRE_callback *runPtr;
for (runPtr = TOP_CB(interp); runPtr; runPtr = runPtr->nextPtr) {
- if (((runPtr->procPtr) == NRCommand) && !runPtr->data[1]) {
+ if (((runPtr->procPtr) == NRCommand) && !runPtr->data[1]) {
break;
}
}
if (!runPtr) {
Tcl_Panic("tailcall cannot find the right splicing spot: should not happen!");
}
-
- tailcallPtr->nextPtr = runPtr->nextPtr;
- runPtr->nextPtr = tailcallPtr;
+ runPtr->data[1] = listPtr;
}
int
@@ -8321,7 +8346,7 @@ TclNRTailcallObjCmd(
*/
if (iPtr->varFramePtr->tailcallPtr) {
- ClearTailcall(interp, iPtr->varFramePtr->tailcallPtr);
+ Tcl_DecrRefCount(iPtr->varFramePtr->tailcallPtr);
iPtr->varFramePtr->tailcallPtr = NULL;
}
@@ -8336,23 +8361,20 @@ TclNRTailcallObjCmd(
Tcl_Obj *listPtr, *nsObjPtr;
Tcl_Namespace *nsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr;
Tcl_Namespace *ns1Ptr;
- NRE_callback *tailcallPtr;
- listPtr = Tcl_NewListObj(objc-1, objv+1);
- Tcl_IncrRefCount(listPtr);
+ /* The tailcall data is in a Tcl list: the first element is the
+ * namespace, the rest the command to be tailcalled. */
+
+ listPtr = Tcl_NewListObj(objc, objv);
nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, -1);
if ((TCL_OK != TclGetNamespaceFromObj(interp, nsObjPtr, &ns1Ptr))
|| (nsPtr != ns1Ptr)) {
Tcl_Panic("Tailcall failed to find the proper namespace");
}
- Tcl_IncrRefCount(nsObjPtr);
-
- TclNRAddCallback(interp, TclNRTailcallEval, listPtr, nsObjPtr,
- NULL, NULL);
- tailcallPtr = TOP_CB(interp);
- TOP_CB(interp) = tailcallPtr->nextPtr;
- iPtr->varFramePtr->tailcallPtr = tailcallPtr;
+ TclListObjSetElement(interp, listPtr, 0, nsObjPtr);
+
+ iPtr->varFramePtr->tailcallPtr = listPtr;
}
return TCL_RETURN;
}
@@ -8364,12 +8386,14 @@ TclNRTailcallEval(
int result)
{
Interp *iPtr = (Interp *) interp;
- Tcl_Obj *listPtr = data[0];
- Tcl_Obj *nsObjPtr = data[1];
+ Tcl_Obj *listPtr = data[0], *nsObjPtr;
Tcl_Namespace *nsPtr;
int objc;
Tcl_Obj **objv;
+ Tcl_ListObjGetElements(interp, listPtr, &objc, &objv);
+ nsObjPtr = objv[0];
+
if (result == TCL_OK) {
result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr);
}
@@ -8388,10 +8412,10 @@ TclNRTailcallEval(
* Perform the tailcall
*/
- TclNRDeferCallback(interp, TailcallCleanup, listPtr, nsObjPtr, NULL,NULL);
+ TclMarkTailcall(interp);
+ TclNRAddCallback(interp, TailcallCleanup, listPtr, NULL, NULL,NULL);
iPtr->lookupNsPtr = (Namespace *) nsPtr;
- ListObjGetElements(listPtr, objc, objv);
- return TclNREvalObjv(interp, objc, objv, 0, NULL);
+ return TclNREvalObjv(interp, objc-1, objv+1, 0, NULL);
}
static int
@@ -8401,19 +8425,9 @@ TailcallCleanup(
int result)
{
Tcl_DecrRefCount((Tcl_Obj *) data[0]);
- Tcl_DecrRefCount((Tcl_Obj *) data[1]);
return result;
}
-static void
-ClearTailcall(
- Tcl_Interp *interp,
- NRE_callback *tailcallPtr)
-{
- TailcallCleanup(tailcallPtr->data, interp, TCL_OK);
- TCLNR_FREE(interp, tailcallPtr);
-}
-
void
Tcl_NRAddCallback(
@@ -8515,50 +8529,32 @@ TclNRYieldToObjCmd(
* This is essentially code from TclNRTailcallObjCmd
*/
- listPtr = Tcl_NewListObj(objc-1, objv+1);
- Tcl_IncrRefCount(listPtr);
+ /*
+ * Add the tailcall in the caller env, then just yield.
+ *
+ * This is essentially code from TclNRTailcallObjCmd
+ */
+
+ listPtr = Tcl_NewListObj(objc, objv);
nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, -1);
if ((TCL_OK != TclGetNamespaceFromObj(interp, nsObjPtr, &ns1Ptr))
|| (nsPtr != ns1Ptr)) {
Tcl_Panic("yieldto failed to find the proper namespace");
}
- Tcl_IncrRefCount(nsObjPtr);
+ TclListObjSetElement(interp, listPtr, 0, nsObjPtr);
+
/*
* Add the callback in the caller's env, then instruct TEBC to yield.
*/
iPtr->execEnvPtr = corPtr->callerEEPtr;
- TclNRAddCallback(interp, YieldToCallback, corPtr, listPtr, nsObjPtr,
- NULL);
+ TclSetTailcall(interp, listPtr);
iPtr->execEnvPtr = corPtr->eePtr;
return TclNRYieldObjCmd(INT2PTR(CORO_ACTIVATE_YIELDM), interp, 1, objv);
}
-
-static int
-YieldToCallback(
- ClientData data[],
- Tcl_Interp *interp,
- int result)
-{
- /* CoroutineData *corPtr = data[0];*/
- Tcl_Obj *listPtr = data[1];
- ClientData nsPtr = data[2];
- NRE_callback *cbPtr;
-
- /*
- * yieldTo: invoke the command using tailcall tech.
- */
-
- TclNRAddCallback(interp, TclNRTailcallEval, listPtr, nsPtr, NULL, NULL);
- cbPtr = TOP_CB(interp);
- TOP_CB(interp) = cbPtr->nextPtr;
-
- TclSpliceTailcall(interp, cbPtr);
- return TCL_OK;
-}
static int
RewindCoroutineCallback(
diff --git a/generic/tclBinary.c b/generic/tclBinary.c
index 5c33308..455b5a6 100644
--- a/generic/tclBinary.c
+++ b/generic/tclBinary.c
@@ -128,6 +128,30 @@ static const char B64Digits[65] = {
};
/*
+ * How to construct the ensembles.
+ */
+
+static const EnsembleImplMap binaryMap[] = {
+ { "format", BinaryFormatCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0 },
+ { "scan", BinaryScanCmd, TclCompileBasicMin2ArgCmd, NULL, NULL, 0 },
+ { "encode", NULL, NULL, NULL, NULL, 0 },
+ { "decode", NULL, NULL, NULL, NULL, 0 },
+ { NULL, NULL, NULL, NULL, NULL, 0 }
+};
+static const EnsembleImplMap encodeMap[] = {
+ { "hex", BinaryEncodeHex, TclCompileBasic1ArgCmd, NULL, (ClientData)HexDigits, 0 },
+ { "uuencode", BinaryEncode64, NULL, NULL, (ClientData)UueDigits, 0 },
+ { "base64", BinaryEncode64, NULL, NULL, (ClientData)B64Digits, 0 },
+ { NULL, NULL, NULL, NULL, NULL, 0 }
+};
+static const EnsembleImplMap decodeMap[] = {
+ { "hex", BinaryDecodeHex, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0 },
+ { "uuencode", BinaryDecodeUu, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0 },
+ { "base64", BinaryDecode64, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0 },
+ { NULL, NULL, NULL, NULL, NULL, 0 }
+};
+
+/*
* The following object type represents an array of bytes. An array of bytes
* is not equivalent to an internationalized string. Conceptually, a string is
* an array of 16-bit quantities organized as a sequence of properly formed
@@ -688,26 +712,6 @@ TclAppendBytesToByteArray(
*----------------------------------------------------------------------
*/
-static const EnsembleImplMap binaryMap[] = {
-{ "format", BinaryFormatCmd, NULL, NULL, NULL, 0 },
-{ "scan", BinaryScanCmd, NULL, NULL, NULL, 0 },
-{ "encode", NULL, NULL, NULL, NULL, 0 },
-{ "decode", NULL, NULL, NULL, NULL, 0 },
-{ NULL, NULL, NULL, NULL, NULL, 0 }
-};
-static const EnsembleImplMap encodeMap[] = {
-{ "hex", BinaryEncodeHex, NULL, NULL, (ClientData)HexDigits, 0 },
-{ "uuencode", BinaryEncode64, NULL, NULL, (ClientData)UueDigits, 0 },
-{ "base64", BinaryEncode64, NULL, NULL, (ClientData)B64Digits, 0 },
-{ NULL, NULL, NULL, NULL, NULL, 0 }
-};
-static const EnsembleImplMap decodeMap[] = {
-{ "hex", BinaryDecodeHex, NULL, NULL, NULL, 0 },
-{ "uuencode", BinaryDecodeUu, NULL, NULL, NULL, 0 },
-{ "base64", BinaryDecode64, NULL, NULL, NULL, 0 },
-{ NULL, NULL, NULL, NULL, NULL, 0 }
-};
-
Tcl_Command
TclInitBinaryCmd(
Tcl_Interp *interp)
@@ -2357,7 +2361,7 @@ BinaryDecodeHex(
static const char *const optStrings[] = { "-strict", NULL };
if (objc < 2 || objc > 3) {
- Tcl_WrongNumArgs(interp, 1, objv, "data");
+ Tcl_WrongNumArgs(interp, 1, objv, "?options? data");
return TCL_ERROR;
}
for (i = 1; i < objc-1; ++i) {
@@ -2571,7 +2575,7 @@ BinaryDecodeUu(
static const char *const optStrings[] = { "-strict", NULL };
if (objc < 2 || objc > 3) {
- Tcl_WrongNumArgs(interp, 1, objv, "data");
+ Tcl_WrongNumArgs(interp, 1, objv, "?options? data");
return TCL_ERROR;
}
for (i = 1; i < objc-1; ++i) {
@@ -2667,7 +2671,7 @@ BinaryDecode64(
static const char *const optStrings[] = { "-strict", NULL };
if (objc < 2 || objc > 3) {
- Tcl_WrongNumArgs(interp, 1, objv, "data");
+ Tcl_WrongNumArgs(interp, 1, objv, "?options? data");
return TCL_ERROR;
}
for (i = 1; i < objc-1; ++i) {
diff --git a/generic/tclCkalloc.c b/generic/tclCkalloc.c
index ab977cb..70e64f0 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/tclCmdAH.c b/generic/tclCmdAH.c
index 133a61b..820eec5 100644
--- a/generic/tclCmdAH.c
+++ b/generic/tclCmdAH.c
@@ -11,6 +11,7 @@
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
+#include <sys/stat.h>
#include "tclInt.h"
#include <locale.h>
@@ -950,40 +951,40 @@ TclInitFileCmd(
*/
static const EnsembleImplMap initMap[] = {
- {"atime", FileAttrAccessTimeCmd, NULL, NULL, NULL, 0},
- {"attributes", TclFileAttrsCmd, NULL, NULL, NULL, 0},
- {"channels", TclChannelNamesCmd, NULL, NULL, NULL, 0},
- {"copy", TclFileCopyCmd, NULL, NULL, NULL, 0},
- {"delete", TclFileDeleteCmd, NULL, NULL, NULL, 0},
- {"dirname", PathDirNameCmd, NULL, NULL, NULL, 0},
- {"executable", FileAttrIsExecutableCmd, NULL, NULL, NULL, 0},
- {"exists", FileAttrIsExistingCmd, NULL, NULL, NULL, 0},
- {"extension", PathExtensionCmd, NULL, NULL, NULL, 0},
- {"isdirectory", FileAttrIsDirectoryCmd, NULL, NULL, NULL, 0},
- {"isfile", FileAttrIsFileCmd, NULL, NULL, NULL, 0},
- {"join", PathJoinCmd, NULL, NULL, NULL, 0},
- {"link", TclFileLinkCmd, NULL, NULL, NULL, 0},
- {"lstat", FileAttrLinkStatCmd, NULL, NULL, NULL, 0},
- {"mtime", FileAttrModifyTimeCmd, NULL, NULL, NULL, 0},
- {"mkdir", TclFileMakeDirsCmd, NULL, NULL, NULL, 0},
- {"nativename", PathNativeNameCmd, NULL, NULL, NULL, 0},
- {"normalize", PathNormalizeCmd, NULL, NULL, NULL, 0},
- {"owned", FileAttrIsOwnedCmd, NULL, NULL, NULL, 0},
- {"pathtype", PathTypeCmd, NULL, NULL, NULL, 0},
- {"readable", FileAttrIsReadableCmd, NULL, NULL, NULL, 0},
- {"readlink", TclFileReadLinkCmd, NULL, NULL, NULL, 0},
- {"rename", TclFileRenameCmd, NULL, NULL, NULL, 0},
- {"rootname", PathRootNameCmd, NULL, NULL, NULL, 0},
- {"separator", FilesystemSeparatorCmd, NULL, NULL, NULL, 0},
- {"size", FileAttrSizeCmd, NULL, NULL, NULL, 0},
- {"split", PathSplitCmd, NULL, NULL, NULL, 0},
- {"stat", FileAttrStatCmd, NULL, NULL, NULL, 0},
- {"system", PathFilesystemCmd, NULL, NULL, NULL, 0},
- {"tail", PathTailCmd, NULL, NULL, NULL, 0},
- {"tempfile", TclFileTemporaryCmd, NULL, NULL, NULL, 0},
- {"type", FileAttrTypeCmd, NULL, NULL, NULL, 0},
- {"volumes", FilesystemVolumesCmd, NULL, NULL, NULL, 0},
- {"writable", FileAttrIsWritableCmd, NULL, NULL, NULL, 0},
+ {"atime", FileAttrAccessTimeCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
+ {"attributes", TclFileAttrsCmd, NULL, NULL, NULL, 0},
+ {"channels", TclChannelNamesCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
+ {"copy", TclFileCopyCmd, NULL, NULL, NULL, 0},
+ {"delete", TclFileDeleteCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 0},
+ {"dirname", PathDirNameCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"executable", FileAttrIsExecutableCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"exists", FileAttrIsExistingCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"extension", PathExtensionCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"isdirectory", FileAttrIsDirectoryCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"isfile", FileAttrIsFileCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"join", PathJoinCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0},
+ {"link", TclFileLinkCmd, TclCompileBasic1To3ArgCmd, NULL, NULL, 0},
+ {"lstat", FileAttrLinkStatCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
+ {"mtime", FileAttrModifyTimeCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
+ {"mkdir", TclFileMakeDirsCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 0},
+ {"nativename", PathNativeNameCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"normalize", PathNormalizeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"owned", FileAttrIsOwnedCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"pathtype", PathTypeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"readable", FileAttrIsReadableCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"readlink", TclFileReadLinkCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"rename", TclFileRenameCmd, NULL, NULL, NULL, 0},
+ {"rootname", PathRootNameCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"separator", FilesystemSeparatorCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
+ {"size", FileAttrSizeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"split", PathSplitCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"stat", FileAttrStatCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
+ {"system", PathFilesystemCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
+ {"tail", PathTailCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"tempfile", TclFileTemporaryCmd, TclCompileBasic0To2ArgCmd, NULL, NULL, 0},
+ {"type", FileAttrTypeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"volumes", FilesystemVolumesCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0},
+ {"writable", FileAttrIsWritableCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{NULL, NULL, NULL, NULL, NULL, 0}
};
return TclMakeEnsemble(interp, "file", initMap);
diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index 155e8e4..c70ba23 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -161,30 +161,30 @@ static Tcl_Obj * SelectObjFromSublist(Tcl_Obj *firstPtr,
*/
static const EnsembleImplMap defaultInfoMap[] = {
- {"args", InfoArgsCmd, NULL, NULL, NULL, 0},
- {"body", InfoBodyCmd, NULL, NULL, NULL, 0},
- {"cmdcount", InfoCmdCountCmd, NULL, NULL, NULL, 0},
+ {"args", InfoArgsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"body", InfoBodyCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"cmdcount", InfoCmdCountCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0},
{"commands", InfoCommandsCmd, TclCompileInfoCommandsCmd, NULL, NULL, 0},
- {"complete", InfoCompleteCmd, NULL, NULL, NULL, 0},
+ {"complete", InfoCompleteCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"coroutine", TclInfoCoroutineCmd, TclCompileInfoCoroutineCmd, NULL, NULL, 0},
- {"default", InfoDefaultCmd, NULL, NULL, NULL, 0},
- {"errorstack", InfoErrorStackCmd, NULL, NULL, NULL, 0},
+ {"default", InfoDefaultCmd, TclCompileBasic3ArgCmd, NULL, NULL, 0},
+ {"errorstack", InfoErrorStackCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
{"exists", TclInfoExistsCmd, TclCompileInfoExistsCmd, NULL, NULL, 0},
- {"frame", InfoFrameCmd, NULL, NULL, NULL, 0},
- {"functions", InfoFunctionsCmd, NULL, NULL, NULL, 0},
- {"globals", TclInfoGlobalsCmd, NULL, NULL, NULL, 0},
- {"hostname", InfoHostnameCmd, NULL, NULL, NULL, 0},
+ {"frame", InfoFrameCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
+ {"functions", InfoFunctionsCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
+ {"globals", TclInfoGlobalsCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
+ {"hostname", InfoHostnameCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0},
{"level", InfoLevelCmd, TclCompileInfoLevelCmd, NULL, NULL, 0},
- {"library", InfoLibraryCmd, NULL, NULL, NULL, 0},
- {"loaded", InfoLoadedCmd, NULL, NULL, NULL, 0},
- {"locals", TclInfoLocalsCmd, NULL, NULL, NULL, 0},
- {"nameofexecutable", InfoNameOfExecutableCmd, NULL, NULL, NULL, 0},
- {"patchlevel", InfoPatchLevelCmd, NULL, NULL, NULL, 0},
- {"procs", InfoProcsCmd, NULL, NULL, NULL, 0},
- {"script", InfoScriptCmd, NULL, NULL, NULL, 0},
- {"sharedlibextension", InfoSharedlibCmd, NULL, NULL, NULL, 0},
- {"tclversion", InfoTclVersionCmd, NULL, NULL, NULL, 0},
- {"vars", TclInfoVarsCmd, NULL, NULL, NULL, 0},
+ {"library", InfoLibraryCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0},
+ {"loaded", InfoLoadedCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
+ {"locals", TclInfoLocalsCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
+ {"nameofexecutable", InfoNameOfExecutableCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0},
+ {"patchlevel", InfoPatchLevelCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0},
+ {"procs", InfoProcsCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
+ {"script", InfoScriptCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
+ {"sharedlibextension", InfoSharedlibCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0},
+ {"tclversion", InfoTclVersionCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0},
+ {"vars", TclInfoVarsCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
{NULL, NULL, NULL, NULL, NULL, 0}
};
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index fc957c4..95debf8 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -3324,7 +3324,7 @@ TclInitStringCmd(
Tcl_Interp *interp) /* Current interpreter. */
{
static const EnsembleImplMap stringImplMap[] = {
- {"bytelength", StringBytesCmd, NULL, NULL, NULL, 0},
+ {"bytelength", StringBytesCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"compare", StringCmpCmd, TclCompileStringCmpCmd, NULL, NULL, 0},
{"equal", StringEqualCmd, TclCompileStringEqualCmd, NULL, NULL, 0},
{"first", StringFirstCmd, TclCompileStringFirstCmd, NULL, NULL, 0},
@@ -3335,17 +3335,17 @@ TclInitStringCmd(
{"map", StringMapCmd, TclCompileStringMapCmd, NULL, NULL, 0},
{"match", StringMatchCmd, TclCompileStringMatchCmd, NULL, NULL, 0},
{"range", StringRangeCmd, TclCompileStringRangeCmd, NULL, NULL, 0},
- {"repeat", StringReptCmd, NULL, NULL, NULL, 0},
+ {"repeat", StringReptCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
{"replace", StringRplcCmd, NULL, NULL, NULL, 0},
- {"reverse", StringRevCmd, NULL, NULL, NULL, 0},
- {"tolower", StringLowerCmd, NULL, NULL, NULL, 0},
- {"toupper", StringUpperCmd, NULL, NULL, NULL, 0},
- {"totitle", StringTitleCmd, NULL, NULL, NULL, 0},
- {"trim", StringTrimCmd, NULL, NULL, NULL, 0},
- {"trimleft", StringTrimLCmd, NULL, NULL, NULL, 0},
- {"trimright", StringTrimRCmd, NULL, NULL, NULL, 0},
- {"wordend", StringEndCmd, NULL, NULL, NULL, 0},
- {"wordstart", StringStartCmd, NULL, NULL, NULL, 0},
+ {"reverse", StringRevCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"tolower", StringLowerCmd, TclCompileBasic1To3ArgCmd, NULL, NULL, 0},
+ {"toupper", StringUpperCmd, TclCompileBasic1To3ArgCmd, NULL, NULL, 0},
+ {"totitle", StringTitleCmd, TclCompileBasic1To3ArgCmd, NULL, NULL, 0},
+ {"trim", StringTrimCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
+ {"trimleft", StringTrimLCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
+ {"trimright", StringTrimRCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
+ {"wordend", StringEndCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
+ {"wordstart", StringStartCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
{NULL, NULL, NULL, NULL, NULL, 0}
};
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 160fa3c..389c1ee 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;
@@ -294,12 +295,12 @@ TclCompileArraySetCmd(
}
tokenPtr = TokenAfter(parsePtr->tokenPtr);
- PushVarNameWord(interp, tokenPtr, envPtr, 0,
+ PushVarNameWord(interp, tokenPtr, envPtr, TCL_NO_ELEMENT,
&localIndex, &simpleVarName, &isScalar, 1);
+ tokenPtr = TokenAfter(tokenPtr);
if (!isScalar) {
return TCL_ERROR;
}
- tokenPtr = TokenAfter(tokenPtr);
/*
* Special case: literal empty value argument is just an "ensure array"
@@ -325,13 +326,33 @@ TclCompileArraySetCmd(
return TCL_OK;
}
+ if (envPtr->procPtr == NULL) {
+ /*
+ * 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);
+ TclEmitInstInt4(INST_REVERSE, 2, envPtr);
+ CompileWord(envPtr, tokenPtr, interp, 2);
+ TclEmitInstInt1(INST_INVOKE_STK1, 3, envPtr);
+ return TCL_OK;
+ }
+
/*
* 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);
@@ -434,10 +455,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 +949,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 +959,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 +972,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 +1099,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 +1199,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 +1260,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 +1386,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 +1398,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 +1410,7 @@ CompileDictEachCmd(
collectVar = TclFindCompiledLocal(NULL, /*nameChars*/ 0, /*create*/ 1,
envPtr);
if (collectVar < 0) {
- return TCL_ERROR;
+ return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
}
@@ -1403,31 +1424,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 +1460,7 @@ CompileDictEachCmd(
infoIndex = TclFindCompiledLocal(NULL, 0, 1, envPtr);
if (infoIndex < 0) {
- return TCL_ERROR;
+ return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
/*
@@ -1636,16 +1657,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);
}
/*
@@ -1696,7 +1717,7 @@ TclCompileDictUpdateCmd(
failedUpdateInfoAssembly:
ckfree(duiPtr);
TclStackFree(interp, keyTokenPtrs);
- return TCL_ERROR;
+ return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
bodyTokenPtr = tokenPtr;
@@ -1794,17 +1815,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);
}
}
@@ -1855,16 +1876,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);
@@ -1908,7 +1929,7 @@ TclCompileDictWithCmd(
tokenPtr = TokenAfter(tokenPtr);
}
if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
- return TCL_ERROR;
+ return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
/*
@@ -1920,7 +1941,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;
@@ -3082,7 +3104,7 @@ TclCompileFormatCmd(
* after our attempt to spot a literal).
*/
- for (; --i>=0 ;) {
+ for (; i>=0 ; i--) {
Tcl_DecrRefCount(objv[i]);
}
ckfree(objv);
@@ -3747,7 +3769,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);
@@ -3784,7 +3808,7 @@ TclCompileInfoCommandsCmd(
notCompilable:
Tcl_DecrRefCount(objPtr);
- return TCL_ERROR;
+ return TclCompileBasic1ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
int
@@ -5791,7 +5815,7 @@ TclCompileVariableCmd(
*/
valueTokenPtr = parsePtr->tokenPtr;
- for (i=2; i<=numWords; i+=2) {
+ for (i=1; i<numWords; i+=2) {
varTokenPtr = TokenAfter(valueTokenPtr);
valueTokenPtr = TokenAfter(varTokenPtr);
@@ -5801,15 +5825,15 @@ TclCompileVariableCmd(
return TCL_ERROR;
}
- CompileWord(envPtr, varTokenPtr, interp, 1);
+ CompileWord(envPtr, varTokenPtr, interp, i);
TclEmitInstInt4( INST_VARIABLE, localIndex, envPtr);
- if (i != numWords) {
+ if (i+1 < numWords) {
/*
* A value has been given: set the variable, pop the value
*/
- CompileWord(envPtr, valueTokenPtr, interp, 1);
+ CompileWord(envPtr, valueTokenPtr, interp, i+1);
Emit14Inst( INST_STORE_SCALAR, localIndex, envPtr);
TclEmitOpcode( INST_POP, envPtr);
}
@@ -6006,7 +6030,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. */
@@ -6187,10 +6211,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 7bead0d..f73beca 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);
}
/*
@@ -1953,11 +1953,13 @@ TclCompileTailcallCmd(
return TCL_ERROR;
}
+ /* make room for the nsObjPtr */
+ CompileWord(envPtr, tokenPtr, interp, 0);
for (i=1 ; i<parsePtr->numWords ; i++) {
tokenPtr = TokenAfter(tokenPtr);
CompileWord(envPtr, tokenPtr, interp, i);
}
- TclEmitInstInt1( INST_TAILCALL, parsePtr->numWords-1, envPtr);
+ TclEmitInstInt1( INST_TAILCALL, parsePtr->numWords, envPtr);
return TCL_OK;
}
@@ -2737,7 +2739,7 @@ TclCompileUnsetCmd(
flags = 1;
varTokenPtr = TokenAfter(parsePtr->tokenPtr);
leadingWord = Tcl_NewObj();
- if (TclWordKnownAtCompileTime(varTokenPtr, leadingWord)) {
+ if (numWords > 0 && TclWordKnownAtCompileTime(varTokenPtr, leadingWord)) {
int len;
const char *bytes = Tcl_GetStringFromObj(leadingWord, &len);
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 309682d..45a74d7 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -529,6 +529,11 @@ InstructionDesc const tclInstructionTable[] = {
/* Forces the variable indexed by opnd to be an array. Does not touch
* the stack. */
+ {"invokeReplace", 6, INT_MIN, 2, {OPERAND_UINT4,OPERAND_UINT1}},
+ /* Invoke command named objv[0], replacing the first two words with
+ * the word at the top of the stack;
+ * <objc,objv> = <op4,top op4 after popping 1> */
+
{NULL, 0, 0, 0, {OPERAND_NONE}}
};
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index 3302f9b..4d8ed65 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -711,8 +711,10 @@ typedef struct ByteCode {
#define INST_ARRAY_MAKE_STK 161
#define INST_ARRAY_MAKE_IMM 162
+#define INST_INVOKE_REPLACE 163
+
/* The last opcode */
-#define LAST_INST_OPCODE 162
+#define LAST_INST_OPCODE 163
/*
* Table describing the Tcl bytecode instructions: their name (for displaying
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 eb3625e..170e744 100644
--- a/generic/tclDictObj.c
+++ b/generic/tclDictObj.c
@@ -91,22 +91,22 @@ static const EnsembleImplMap implementationMap[] = {
{"append", DictAppendCmd, TclCompileDictAppendCmd, NULL, NULL, 0 },
{"create", DictCreateCmd, TclCompileDictCreateCmd, NULL, NULL, 0 },
{"exists", DictExistsCmd, TclCompileDictExistsCmd, NULL, NULL, 0 },
- {"filter", DictFilterCmd, NULL, NULL, NULL, 0 },
+ {"filter", DictFilterCmd, NULL, NULL, NULL, 0 },
{"for", NULL, TclCompileDictForCmd, DictForNRCmd, NULL, 0 },
{"get", DictGetCmd, TclCompileDictGetCmd, NULL, NULL, 0 },
{"incr", DictIncrCmd, TclCompileDictIncrCmd, NULL, NULL, 0 },
- {"info", DictInfoCmd, NULL, NULL, NULL, 0 },
- {"keys", DictKeysCmd, NULL, NULL, NULL, 0 },
+ {"info", DictInfoCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0 },
+ {"keys", DictKeysCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0 },
{"lappend", DictLappendCmd, TclCompileDictLappendCmd, NULL, NULL, 0 },
{"map", NULL, TclCompileDictMapCmd, DictMapNRCmd, NULL, 0 },
{"merge", DictMergeCmd, TclCompileDictMergeCmd, NULL, NULL, 0 },
- {"remove", DictRemoveCmd, NULL, NULL, NULL, 0 },
+ {"remove", DictRemoveCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0 },
{"replace", DictReplaceCmd, NULL, NULL, NULL, 0 },
{"set", DictSetCmd, TclCompileDictSetCmd, NULL, NULL, 0 },
- {"size", DictSizeCmd, NULL, NULL, NULL, 0 },
+ {"size", DictSizeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0 },
{"unset", DictUnsetCmd, TclCompileDictUnsetCmd, NULL, NULL, 0 },
{"update", DictUpdateCmd, TclCompileDictUpdateCmd, NULL, NULL, 0 },
- {"values", DictValuesCmd, NULL, NULL, NULL, 0 },
+ {"values", DictValuesCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0 },
{"with", DictWithCmd, TclCompileDictWithCmd, NULL, NULL, 0 },
{NULL, NULL, NULL, NULL, NULL, 0}
};
diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c
index 7a55724..7d2206b 100644
--- a/generic/tclEncoding.c
+++ b/generic/tclEncoding.c
@@ -9,6 +9,7 @@
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
+#include <sys/stat.h>
#include "tclInt.h"
typedef size_t (LengthProc)(const char *src);
diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c
index b76c603..f392cad 100644
--- a/generic/tclEnsemble.c
+++ b/generic/tclEnsemble.c
@@ -4,7 +4,7 @@
* Contains support for ensembles (see TIP#112), which provide simple
* mechanism for creating composite commands on top of namespaces.
*
- * Copyright (c) 2005-2010 Donal K. Fellows.
+ * Copyright (c) 2005-2013 Donal K. Fellows.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -35,6 +35,15 @@ static void MakeCachedEnsembleCommand(Tcl_Obj *objPtr,
static void FreeEnsembleCmdRep(Tcl_Obj *objPtr);
static void DupEnsembleCmdRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr);
static void StringOfEnsembleCmdRep(Tcl_Obj *objPtr);
+static int CompileToCompiledCommand(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, int depth, Command *cmdPtr,
+ CompileEnv *envPtr);
+static void CompileToInvokedCommand(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Tcl_Obj *replacements,
+ Command *cmdPtr, CompileEnv *envPtr);
+static int CompileBasicNArgCommand(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ CompileEnv *envPtr);
/*
* The lists of subcommands and options for the [namespace ensemble] command.
@@ -78,6 +87,17 @@ const Tcl_ObjType tclEnsembleCmdType = {
StringOfEnsembleCmdRep, /* updateStringProc */
NULL /* setFromAnyProc */
};
+
+/*
+ * Copied from tclCompCmds.c
+ */
+
+#define DefineLineInformation \
+ ExtCmdLoc *mapPtr = envPtr->extCmdMapPtr; \
+ int eclIndex = mapPtr->nuloc - 1
+#define SetLineInformation(word) \
+ envPtr->line = mapPtr->loc[eclIndex].line[(word)]; \
+ envPtr->clNext = mapPtr->loc[eclIndex].next[(word)]
static inline Tcl_Obj *
NewNsObj(
@@ -1565,21 +1585,23 @@ TclMakeEnsemble(
NULL);
}
cmdPtr->compileProc = map[i].compileProc;
- if (map[i].compileProc != NULL) {
- ensembleFlags |= ENSEMBLE_COMPILE;
- }
}
}
Tcl_SetEnsembleMappingDict(interp, ensemble, mapDict);
- if (ensembleFlags & ENSEMBLE_COMPILE) {
- Tcl_SetEnsembleFlags(interp, ensemble, ensembleFlags);
- }
+
+ /*
+ * Switch on compilation always for core ensembles now that we can do
+ * nice bytecode things with them.
+ */
+
+ Tcl_SetEnsembleFlags(interp, ensemble,
+ ensembleFlags | ENSEMBLE_COMPILE);
}
Tcl_DStringFree(&buf);
Tcl_DStringFree(&hiddenBuf);
if (nameParts != NULL) {
- Tcl_Free((char *) nameParts);
+ ckfree((char *) nameParts);
}
return ensemble;
}
@@ -1892,7 +1914,7 @@ NsEnsembleImplementationCmdNR(
* Hand off to the target command.
*/
- iPtr->evalFlags |= TCL_EVAL_REDIRECT;
+ TclSkipTailcall(interp);
return TclNREvalObjEx(interp, copyPtr, TCL_EVAL_INVOKE, NULL,INT_MIN);
}
@@ -2100,7 +2122,7 @@ EnsembleUnknownCallback(
*/
Tcl_Preserve(ensemblePtr);
- ((Interp *) interp)->evalFlags |= TCL_EVAL_REDIRECT;
+ TclSkipTailcall(interp);
result = Tcl_EvalObjv(interp, paramc, paramv, 0);
if ((result == TCL_OK) && (ensemblePtr->flags & ENSEMBLE_DEAD)) {
if (!Tcl_InterpDeleted(interp)) {
@@ -2174,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 {
@@ -2731,25 +2753,33 @@ TclCompileEnsemble(
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
- Tcl_Token *tokenPtr;
+ Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
Tcl_Obj *mapObj, *subcmdObj, *targetCmdObj, *listObj, **elems;
+ Tcl_Obj *replaced = Tcl_NewObj(), *replacement;
Tcl_Command ensemble = (Tcl_Command) cmdPtr;
- Tcl_Parse synthetic;
- int len, result, flags = 0, i;
+ Command *oldCmdPtr = cmdPtr, *newCmdPtr;
+ int len, result, flags = 0, i, depth = 1, invokeAnyway = 0;
+ int ourResult = TCL_ERROR;
unsigned numBytes;
const char *word;
- if (parsePtr->numWords < 2) {
- return TCL_ERROR;
- }
+ Tcl_IncrRefCount(replaced);
- tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ /*
+ * This is where we return to if we are parsing multiple nested compiled
+ * ensembles. [info object] is such a beast.
+ */
+
+ checkNextWord:
+ if (parsePtr->numWords < depth + 1) {
+ goto failed;
+ }
if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
/*
* Too hard.
*/
- return TCL_ERROR;
+ goto failed;
}
word = tokenPtr[1].start;
@@ -2768,7 +2798,7 @@ TclCompileEnsemble(
* to proceed.
*/
- return TCL_ERROR;
+ goto failed;
}
/*
@@ -2782,7 +2812,7 @@ TclCompileEnsemble(
* Figuring out how to compile this has become too much. Bail out.
*/
- return TCL_ERROR;
+ goto failed;
}
/*
@@ -2805,7 +2835,7 @@ TclCompileEnsemble(
Tcl_Obj *matchObj = NULL;
if (Tcl_ListObjGetElements(NULL, listObj, &len, &elems) != TCL_OK) {
- return TCL_ERROR;
+ goto failed;
}
for (i=0 ; i<len ; i++) {
str = Tcl_GetStringFromObj(elems[i], &sclen);
@@ -2816,8 +2846,9 @@ TclCompileEnsemble(
result = Tcl_DictObjGet(NULL, mapObj,elems[i], &targetCmdObj);
if (result != TCL_OK || targetCmdObj == NULL) {
- return TCL_ERROR;
+ goto failed;
}
+ replacement = elems[i];
goto doneMapLookup;
}
@@ -2833,18 +2864,19 @@ TclCompileEnsemble(
if ((flags & TCL_ENSEMBLE_PREFIX)
&& strncmp(word, str, numBytes) == 0) {
if (matchObj != NULL) {
- return TCL_ERROR;
+ goto failed;
}
matchObj = elems[i];
}
}
if (matchObj == NULL) {
- return TCL_ERROR;
+ goto failed;
}
result = Tcl_DictObjGet(NULL, mapObj, matchObj, &targetCmdObj);
if (result != TCL_OK || targetCmdObj == NULL) {
- return TCL_ERROR;
+ goto failed;
}
+ replacement = matchObj;
} else {
Tcl_DictSearch s;
int done, matched;
@@ -2856,14 +2888,15 @@ TclCompileEnsemble(
TclNewStringObj(subcmdObj, word, (int) numBytes);
result = Tcl_DictObjGet(NULL, mapObj, subcmdObj, &targetCmdObj);
- TclDecrRefCount(subcmdObj);
if (result == TCL_OK && targetCmdObj != NULL) {
/*
* Got it. Skip the fiddling around with prefixes.
*/
+ replacement = subcmdObj;
goto doneMapLookup;
}
+ TclDecrRefCount(subcmdObj);
/*
* We've not literally got a valid subcommand. But maybe we have a
@@ -2871,7 +2904,7 @@ TclCompileEnsemble(
*/
if (!(flags & TCL_ENSEMBLE_PREFIX)) {
- return TCL_ERROR;
+ goto failed;
}
/*
@@ -2881,6 +2914,7 @@ TclCompileEnsemble(
Tcl_DictObjFirst(NULL, mapObj, &s, &subcmdObj, &tmpObj, &done);
matched = 0;
+ replacement = NULL; /* Silence, fool compiler! */
while (!done) {
if (strncmp(TclGetString(subcmdObj), word, numBytes) == 0) {
if (matched++) {
@@ -2891,6 +2925,7 @@ TclCompileEnsemble(
break;
}
+ replacement = subcmdObj;
targetCmdObj = tmpObj;
}
Tcl_DictObjNext(&s, &subcmdObj, &tmpObj, &done);
@@ -2903,7 +2938,8 @@ TclCompileEnsemble(
*/
if (matched != 1) {
- return TCL_ERROR;
+ invokeAnyway = 1;
+ goto failed;
}
}
@@ -2917,75 +2953,157 @@ TclCompileEnsemble(
*/
doneMapLookup:
+ Tcl_ListObjAppendElement(NULL, replaced, replacement);
if (Tcl_ListObjGetElements(NULL, targetCmdObj, &len, &elems) != TCL_OK) {
- return TCL_ERROR;
- }
- if (len > 1 && Tcl_IsSafe(interp)) {
- return TCL_ERROR;
+ goto failed;
+ } else if (len != 1) {
+ /*
+ * Note that at this point we know we can't issue any special
+ * instruction sequence as the mapping isn't one that we support at
+ * the compiled level.
+ */
+
+ goto cleanup;
}
targetCmdObj = elems[0];
+ oldCmdPtr = cmdPtr;
Tcl_IncrRefCount(targetCmdObj);
- cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, targetCmdObj);
+ newCmdPtr = (Command *) Tcl_GetCommandFromObj(interp, targetCmdObj);
TclDecrRefCount(targetCmdObj);
- if (cmdPtr == NULL || cmdPtr->compileProc == NULL
- || cmdPtr->nsPtr->flags & NS_SUPPRESS_COMPILATION
- || cmdPtr->flags * CMD_HAS_EXEC_TRACES
+ if (newCmdPtr == NULL || Tcl_IsSafe(interp)
+ || newCmdPtr->nsPtr->flags & NS_SUPPRESS_COMPILATION
+ || newCmdPtr->flags & CMD_HAS_EXEC_TRACES
|| ((Interp *)interp)->flags & DONT_COMPILE_CMDS_INLINE) {
/*
* Maps to an undefined command or a command without a compiler.
* Cannot compile.
*/
- return TCL_ERROR;
+ goto cleanup;
+ }
+ cmdPtr = newCmdPtr;
+ depth++;
+
+ /*
+ * See whether we have a nested ensemble. If we do, we can go round the
+ * mulberry bush again, consuming the next word.
+ */
+
+ if (cmdPtr->compileProc == TclCompileEnsemble) {
+ tokenPtr = TokenAfter(tokenPtr);
+ ensemble = (Tcl_Command) cmdPtr;
+ goto checkNextWord;
}
/*
* Now we've done the mapping process, can now actually try to compile.
- * We do this by handing off to the subcommand's actual compiler. But to
- * do that, we have to perform some trickery to rewrite the arguments.
+ * If there is a subcommand compiler and that successfully produces code,
+ * we'll use that. Otherwise, we fall back to generating opcodes to do the
+ * invoke at runtime.
*/
- TclParseInit(interp, NULL, 0, &synthetic);
- synthetic.numWords = parsePtr->numWords - 2 + len;
- TclGrowParseTokenArray(&synthetic, 2*len);
- synthetic.numTokens = 2*len;
+ invokeAnyway = 1;
+ if (CompileToCompiledCommand(interp, parsePtr, depth, cmdPtr,
+ envPtr) == TCL_OK) {
+ ourResult = TCL_OK;
+ goto cleanup;
+ }
/*
- * Now we have the space to work in, install something rewritten. Note
- * that we are here praying for all our might that none of these words are
- * a script; the error detection code will crash if that happens and there
- * is nothing we can do to avoid it!
+ * Failed to do a full compile for some reason. Try to do a direct invoke
+ * instead of going through the ensemble lookup process again.
*/
- for (i=0 ; i<len ; i++) {
- int sclen;
- const char *str = Tcl_GetStringFromObj(elems[i], &sclen);
+ failed:
+ if (depth < 250) {
+ if (depth > 1) {
+ if (!invokeAnyway) {
+ cmdPtr = oldCmdPtr;
+ depth--;
+ }
+ (void) Tcl_ListObjReplace(NULL, replaced, depth, 2, 0, NULL);
+ }
+ CompileToInvokedCommand(interp, parsePtr, replaced, cmdPtr, envPtr);
+ ourResult = TCL_OK;
+ }
+
+ /*
+ * Release the memory we allocated. If we've got here, we've either done
+ * something useful or we're in a case that we can't compile at all and
+ * we're just giving up.
+ */
+
+ cleanup:
+ Tcl_DecrRefCount(replaced);
+ return ourResult;
+}
+
+/*
+ * How to compile a subcommand using its own command compiler. To do that, we
+ * have to perform some trickery to rewrite the arguments, as compilers *must*
+ * have parse tokens that refer to addresses in the original script.
+ */
+
+static int
+CompileToCompiledCommand(
+ Tcl_Interp *interp,
+ Tcl_Parse *parsePtr,
+ int depth,
+ Command *cmdPtr,
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ Tcl_Parse synthetic;
+ Tcl_Token *tokenPtr;
+ int result, i;
+ int savedNumCmds = envPtr->numCommands;
+ int savedStackDepth = envPtr->currStackDepth;
+ unsigned savedCodeNext = envPtr->codeNext - envPtr->codeStart;
- synthetic.tokenPtr[2*i].type = TCL_TOKEN_SIMPLE_WORD;
- synthetic.tokenPtr[2*i].start = str;
- synthetic.tokenPtr[2*i].size = sclen;
- synthetic.tokenPtr[2*i].numComponents = 1;
+ if (cmdPtr->compileProc == NULL) {
+ return TCL_ERROR;
+ }
- synthetic.tokenPtr[2*i+1].type = TCL_TOKEN_TEXT;
- synthetic.tokenPtr[2*i+1].start = str;
- synthetic.tokenPtr[2*i+1].size = sclen;
- synthetic.tokenPtr[2*i+1].numComponents = 0;
+ TclParseInit(interp, NULL, 0, &synthetic);
+ synthetic.numWords = parsePtr->numWords - depth + 1;
+ TclGrowParseTokenArray(&synthetic, 2);
+ synthetic.numTokens = 2;
+
+ /*
+ * Now we have the space to work in, install something rewritten. The
+ * first word will "officially" be the bytes of the structured ensemble
+ * name. That's technically wrong, but nobody will care; we just need
+ * *something* here...
+ */
+
+ synthetic.tokenPtr[0].type = TCL_TOKEN_SIMPLE_WORD;
+ synthetic.tokenPtr[0].start = parsePtr->tokenPtr[0].start;
+ synthetic.tokenPtr[0].numComponents = 1;
+ synthetic.tokenPtr[1].type = TCL_TOKEN_TEXT;
+ synthetic.tokenPtr[1].start = parsePtr->tokenPtr[0].start;
+ synthetic.tokenPtr[1].numComponents = 0;
+ for (i=0,tokenPtr=parsePtr->tokenPtr ; i<depth ; i++) {
+ int sclen = (tokenPtr->start - synthetic.tokenPtr[0].start)
+ + tokenPtr->size;
+
+ synthetic.tokenPtr[0].size = sclen;
+ synthetic.tokenPtr[1].size = sclen;
+ tokenPtr = TokenAfter(tokenPtr);
}
/*
* Copy over the real argument tokens.
*/
- for (i=len; i<synthetic.numWords; i++) {
+ for (i=1; i<synthetic.numWords; i++) {
int toCopy;
- tokenPtr = TokenAfter(tokenPtr);
toCopy = tokenPtr->numComponents + 1;
TclGrowParseTokenArray(&synthetic, toCopy);
memcpy(synthetic.tokenPtr + synthetic.numTokens, tokenPtr,
sizeof(Tcl_Token) * toCopy);
synthetic.numTokens += toCopy;
+ tokenPtr = TokenAfter(tokenPtr);
}
/*
@@ -2995,12 +3113,428 @@ TclCompileEnsemble(
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.
*/
Tcl_FreeParse(&synthetic);
return result;
}
+
+/*
+ * How to compile a subcommand to a _replacing_ invoke of its implementation
+ * command.
+ */
+
+static void
+CompileToInvokedCommand(
+ Tcl_Interp *interp,
+ Tcl_Parse *parsePtr,
+ Tcl_Obj *replacements,
+ Command *cmdPtr,
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ Tcl_Token *tokPtr;
+ Tcl_Obj *objPtr, **words;
+ char *bytes;
+ int length, i, numWords, cmdLit;
+ DefineLineInformation;
+
+ /*
+ * Push the words of the command. Take care; the command words may be
+ * scripts that have backslashes in them, and [info frame 0] can see the
+ * difference. Hence the call to TclContinuationsEnterDerived...
+ */
+
+ Tcl_ListObjGetElements(NULL, replacements, &numWords, &words);
+ for (i=0,tokPtr=parsePtr->tokenPtr ; i<parsePtr->numWords ; i++) {
+ if (i > 0 && i < numWords+1) {
+ bytes = Tcl_GetStringFromObj(words[i-1], &length);
+ PushLiteral(envPtr, bytes, length);
+ } else if (tokPtr->type == TCL_TOKEN_SIMPLE_WORD) {
+ int literal = TclRegisterNewLiteral(envPtr,
+ tokPtr[1].start, tokPtr[1].size);
+
+ if (envPtr->clNext) {
+ TclContinuationsEnterDerived(
+ envPtr->literalArrayPtr[literal].objPtr,
+ tokPtr[1].start - envPtr->source,
+ mapPtr->loc[eclIndex].next[i]);
+ }
+ TclEmitPush(literal, envPtr);
+ } else {
+ if (envPtr->clNext) {
+ SetLineInformation(i);
+ }
+ CompileTokens(envPtr, tokPtr, interp);
+ }
+ tokPtr = TokenAfter(tokPtr);
+ }
+
+ /*
+ * Push the name of the command we're actually dispatching to as part of
+ * the implementation.
+ */
+
+ objPtr = Tcl_NewObj();
+ 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);
+
+ /*
+ * Do the replacing dispatch.
+ */
+
+ TclEmitInstInt4(INST_INVOKE_REPLACE, parsePtr->numWords, envPtr);
+ TclEmitInt1(numWords+1, envPtr);
+ TclAdjustStackDepth(-1, envPtr); /* Correction to stack depth calcs. */
+}
+
+/*
+ * Helpers that do issuing of instructions for commands that "don't have
+ * compilers" (well, they do; these). They all work by just generating base
+ * code to invoke the command; they're intended for ensemble subcommands so
+ * that the costs of INST_INVOKE_REPLACE can be avoided where we can work out
+ * that they're not needed.
+ *
+ * Note that these are NOT suitable for commands where there's an argument
+ * that is a script, as an [info level] or [info frame] in the inner context
+ * can see the difference.
+ */
+
+static int
+CompileBasicNArgCommand(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ Tcl_Token *tokenPtr;
+ Tcl_Obj *objPtr;
+ char *bytes;
+ int length, i, literal;
+ DefineLineInformation;
+
+ /*
+ * Push the name of the command we're actually dispatching to as part of
+ * the implementation.
+ */
+
+ objPtr = Tcl_NewObj();
+ Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr);
+ bytes = Tcl_GetStringFromObj(objPtr, &length);
+ literal = TclRegisterNewCmdLiteral(envPtr, bytes, length);
+ TclSetCmdNameObj(interp, envPtr->literalArrayPtr[literal].objPtr, cmdPtr);
+ TclEmitPush(literal, envPtr);
+ TclDecrRefCount(objPtr);
+
+ /*
+ * Push the words of the command.
+ */
+
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ for (i=1 ; i<parsePtr->numWords ; i++) {
+ if (envPtr->clNext) {
+ SetLineInformation(i);
+ }
+ if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
+ PushLiteral(envPtr, tokenPtr[1].start, tokenPtr[1].size);
+ } else {
+ CompileTokens(envPtr, tokenPtr, interp);
+ }
+ tokenPtr = TokenAfter(tokenPtr);
+ }
+
+ /*
+ * Do the standard dispatch.
+ */
+
+ if (i <= 255) {
+ TclEmitInstInt1(INST_INVOKE_STK1, i, envPtr);
+ } else {
+ TclEmitInstInt4(INST_INVOKE_STK4, i, envPtr);
+ }
+ return TCL_OK;
+}
+
+int
+TclCompileBasic0ArgCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ /*
+ * Verify that the number of arguments is correct; that's the only case
+ * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
+ * which is the only code that sees the shenanigans of ensemble dispatch.
+ */
+
+ if (parsePtr->numWords != 1) {
+ return TCL_ERROR;
+ }
+
+ return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
+}
+
+int
+TclCompileBasic1ArgCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ /*
+ * Verify that the number of arguments is correct; that's the only case
+ * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
+ * which is the only code that sees the shenanigans of ensemble dispatch.
+ */
+
+ if (parsePtr->numWords != 2) {
+ return TCL_ERROR;
+ }
+
+ return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
+}
+
+int
+TclCompileBasic2ArgCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ /*
+ * Verify that the number of arguments is correct; that's the only case
+ * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
+ * which is the only code that sees the shenanigans of ensemble dispatch.
+ */
+
+ if (parsePtr->numWords != 3) {
+ return TCL_ERROR;
+ }
+
+ return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
+}
+
+int
+TclCompileBasic3ArgCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ /*
+ * Verify that the number of arguments is correct; that's the only case
+ * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
+ * which is the only code that sees the shenanigans of ensemble dispatch.
+ */
+
+ if (parsePtr->numWords != 4) {
+ return TCL_ERROR;
+ }
+
+ return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
+}
+
+int
+TclCompileBasic0Or1ArgCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ /*
+ * Verify that the number of arguments is correct; that's the only case
+ * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
+ * which is the only code that sees the shenanigans of ensemble dispatch.
+ */
+
+ if (parsePtr->numWords != 1 && parsePtr->numWords != 2) {
+ return TCL_ERROR;
+ }
+
+ return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
+}
+
+int
+TclCompileBasic1Or2ArgCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ /*
+ * Verify that the number of arguments is correct; that's the only case
+ * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
+ * which is the only code that sees the shenanigans of ensemble dispatch.
+ */
+
+ if (parsePtr->numWords != 2 && parsePtr->numWords != 3) {
+ return TCL_ERROR;
+ }
+
+ return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
+}
+
+int
+TclCompileBasic2Or3ArgCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ /*
+ * Verify that the number of arguments is correct; that's the only case
+ * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
+ * which is the only code that sees the shenanigans of ensemble dispatch.
+ */
+
+ if (parsePtr->numWords != 3 && parsePtr->numWords != 4) {
+ return TCL_ERROR;
+ }
+
+ return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
+}
+
+int
+TclCompileBasic0To2ArgCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ /*
+ * Verify that the number of arguments is correct; that's the only case
+ * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
+ * which is the only code that sees the shenanigans of ensemble dispatch.
+ */
+
+ if (parsePtr->numWords < 1 || parsePtr->numWords > 3) {
+ return TCL_ERROR;
+ }
+
+ return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
+}
+
+int
+TclCompileBasic1To3ArgCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ /*
+ * Verify that the number of arguments is correct; that's the only case
+ * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
+ * which is the only code that sees the shenanigans of ensemble dispatch.
+ */
+
+ if (parsePtr->numWords < 2 || parsePtr->numWords > 4) {
+ return TCL_ERROR;
+ }
+
+ return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
+}
+
+int
+TclCompileBasicMin0ArgCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ /*
+ * Verify that the number of arguments is correct; that's the only case
+ * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
+ * which is the only code that sees the shenanigans of ensemble dispatch.
+ */
+
+ if (parsePtr->numWords < 1) {
+ return TCL_ERROR;
+ }
+
+ return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
+}
+
+int
+TclCompileBasicMin1ArgCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ /*
+ * Verify that the number of arguments is correct; that's the only case
+ * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
+ * which is the only code that sees the shenanigans of ensemble dispatch.
+ */
+
+ if (parsePtr->numWords < 2) {
+ return TCL_ERROR;
+ }
+
+ return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
+}
+
+int
+TclCompileBasicMin2ArgCmd(
+ Tcl_Interp *interp, /* Used for error reporting. */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ /*
+ * Verify that the number of arguments is correct; that's the only case
+ * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
+ * which is the only code that sees the shenanigans of ensemble dispatch.
+ */
+
+ if (parsePtr->numWords < 3) {
+ return TCL_ERROR;
+ }
+
+ return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
+}
/*
* Local Variables:
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 2b5f713..c2cef2a 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -251,13 +251,27 @@ VarHashCreateVar(
* otherwise, push objResultPtr. If (result < 0), objResultPtr already
* has the correct reference count.
*
- * We use the new compile-time assertions to cheack that nCleanup is constant
+ * We use the new compile-time assertions to check that nCleanup is constant
* and within range.
*/
-#define NEXT_INST_F(pcAdjustment, nCleanup, resultHandling) \
+/* Verify the stack depth, only when no expansion is in progress */
+
+#if TCL_COMPILE_DEBUG
+#define CHECK_STACK() \
+ do { \
+ ValidatePcAndStackTop(codePtr, pc, CURR_DEPTH, \
+ /*checkStack*/ !(starting || auxObjList)); \
+ starting = 0; \
+ } while (0)
+#else
+#define CHECK_STACK()
+#endif
+
+#define NEXT_INST_F(pcAdjustment, nCleanup, resultHandling) \
do { \
TCL_CT_ASSERT((nCleanup >= 0) && (nCleanup <= 2)); \
+ CHECK_STACK(); \
if (nCleanup == 0) { \
if (resultHandling != 0) { \
if ((resultHandling) > 0) { \
@@ -286,7 +300,8 @@ VarHashCreateVar(
} \
} while (0)
-#define NEXT_INST_V(pcAdjustment, nCleanup, resultHandling) \
+#define NEXT_INST_V(pcAdjustment, nCleanup, resultHandling) \
+ CHECK_STACK(); \
do { \
pc += (pcAdjustment); \
cleanup = (nCleanup); \
@@ -685,7 +700,7 @@ static void PrintByteCodeInfo(ByteCode *codePtr);
static const char * StringForResultCode(int result);
static void ValidatePcAndStackTop(ByteCode *codePtr,
const unsigned char *pc, int stackTop,
- int stackLowerBound, int checkStack);
+ int checkStack);
#endif /* TCL_COMPILE_DEBUG */
static ByteCode * CompileExprObj(Tcl_Interp *interp, Tcl_Obj *objPtr);
static void DeleteExecStack(ExecStack *esPtr);
@@ -1048,6 +1063,7 @@ GrowEvaluationStack(
return MEMSTART(markerPtr);
}
} else {
+#ifndef PURIFY
Tcl_Obj **tmpMarkerPtr = esPtr->tosPtr + 1;
int offset = OFFSET(tmpMarkerPtr);
@@ -1064,6 +1080,7 @@ GrowEvaluationStack(
*esPtr->markerPtr = (Tcl_Obj *) markerPtr;
return memStart;
}
+#endif
}
/*
@@ -1077,6 +1094,7 @@ GrowEvaluationStack(
}
needed = growth + moveWords + WALLOCALIGN;
+
/*
* Check if there is enough room in the next stack (if there is one, it
* should be both empty and the last one!)
@@ -1106,10 +1124,15 @@ GrowEvaluationStack(
* including the elements to be copied over and the new marker.
*/
+#ifndef PURIFY
newElems = 2*currElems;
while (needed > newElems) {
newElems *= 2;
}
+#else
+ newElems = needed;
+#endif
+
newBytes = sizeof(ExecStack) + (newElems-1) * sizeof(Tcl_Obj *);
oldPtr = esPtr;
@@ -1212,7 +1235,7 @@ TclStackFree(
Tcl_Obj **markerPtr, *marker;
if (iPtr == NULL || iPtr->execEnvPtr == NULL) {
- Tcl_Free((char *) freePtr);
+ ckfree((char *) freePtr);
return;
}
@@ -1258,6 +1281,10 @@ TclStackFree(
}
if (esPtr->prevPtr) {
eePtr->execStackPtr = esPtr->prevPtr;
+#ifdef PURIFY
+ eePtr->execStackPtr->nextPtr = NULL;
+ DeleteExecStack(esPtr);
+#endif
} else {
eePtr->execStackPtr = esPtr;
}
@@ -1272,7 +1299,7 @@ TclStackAlloc(
int numWords = (numBytes + (sizeof(Tcl_Obj *) - 1))/sizeof(Tcl_Obj *);
if (iPtr == NULL || iPtr->execEnvPtr == NULL) {
- return (void *) Tcl_Alloc(numBytes);
+ return (void *) ckalloc(numBytes);
}
return (void *) StackAllocWords(interp, numWords);
@@ -1291,7 +1318,7 @@ TclStackRealloc(
int numWords;
if (iPtr == NULL || iPtr->execEnvPtr == NULL) {
- return (void *) Tcl_Realloc((char *) ptr, numBytes);
+ return (void *) ckrealloc((char *) ptr, numBytes);
}
eePtr = iPtr->execEnvPtr;
@@ -2060,7 +2087,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.
@@ -2085,6 +2113,7 @@ TEBCresume(
#endif
#ifdef TCL_COMPILE_DEBUG
+ int starting = 1;
traceInstructions = (tclTraceExec == 3);
#endif
@@ -2226,24 +2255,6 @@ TEBCresume(
}
cleanup0:
-#ifdef TCL_COMPILE_DEBUG
- /*
- * Skip the stack depth check if an expansion is in progress.
- */
-
- ValidatePcAndStackTop(codePtr, pc, CURR_DEPTH, 0,
- /*checkStack*/ auxObjList == NULL);
- 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).
@@ -2275,8 +2286,6 @@ TEBCresume(
CACHE_STACK_INFO();
}
- TCL_DTRACE_INST_NEXT();
-
/*
* These two instructions account for 26% of all instructions (according
* to measurements on tclbench by Ben Vitale
@@ -2286,13 +2295,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);
@@ -2376,7 +2425,6 @@ TEBCresume(
case INST_TAILCALL: {
Tcl_Obj *listPtr, *nsObjPtr;
- NRE_callback *tailcallPtr;
opnd = TclGetUInt1AtPtr(pc+1);
@@ -2410,18 +2458,12 @@ TEBCresume(
listPtr = Tcl_NewListObj(opnd, &OBJ_AT_DEPTH(opnd-1));
nsObjPtr = Tcl_NewStringObj(iPtr->varFramePtr->nsPtr->fullName, -1);
- Tcl_IncrRefCount(listPtr);
- Tcl_IncrRefCount(nsObjPtr);
- TclNRAddCallback(interp, TclNRTailcallEval, listPtr, nsObjPtr,
- NULL, NULL);
-
- /*
- * Unstitch ourselves and do a [return].
- */
+ TclListObjSetElement(interp, listPtr, 0, nsObjPtr);
+ if (iPtr->varFramePtr->tailcallPtr) {
+ Tcl_DecrRefCount(iPtr->varFramePtr->tailcallPtr);
+ }
+ iPtr->varFramePtr->tailcallPtr = listPtr;
- tailcallPtr = TOP_CB(interp);
- TOP_CB(interp) = tailcallPtr->nextPtr;
- iPtr->varFramePtr->tailcallPtr = tailcallPtr;
result = TCL_RETURN;
cleanup = opnd;
goto processExceptionReturn;
@@ -2449,23 +2491,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);
@@ -2475,68 +2500,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;
@@ -2972,6 +2939,70 @@ TEBCresume(
Tcl_Panic("TclNRExecuteByteCode: obsolete INST_CALL_FUNC1 found");
#endif
+ case INST_INVOKE_REPLACE:
+ objc = TclGetUInt4AtPtr(pc+1);
+ opnd = TclGetUInt1AtPtr(pc+5);
+ objPtr = POP_OBJECT();
+ objv = &OBJ_AT_DEPTH(objc-1);
+ cleanup = objc;
+#ifdef TCL_COMPILE_DEBUG
+ if (tclTraceExec >= 2) {
+ int i;
+
+ if (traceInstructions) {
+ strncpy(cmdNameBuf, TclGetString(objv[0]), 20);
+ TRACE(("%u => call (implementation %s) ", objc, O2S(objPtr)));
+ } else {
+ fprintf(stdout,
+ "%d: (%u) invoking (using implementation %s) ",
+ iPtr->numLevels, (unsigned)(pc - codePtr->codeStart),
+ O2S(objPtr));
+ }
+ for (i = 0; i < objc; i++) {
+ if (i < opnd) {
+ fprintf(stdout, "<");
+ TclPrintObject(stdout, objv[i], 15);
+ fprintf(stdout, ">");
+ } else {
+ TclPrintObject(stdout, objv[i], 15);
+ }
+ fprintf(stdout, " ");
+ }
+ fprintf(stdout, "\n");
+ fflush(stdout);
+ }
+#endif /*TCL_COMPILE_DEBUG*/
+ {
+ Tcl_Obj *copyPtr = Tcl_NewListObj(objc - opnd + 1, NULL);
+ register List *listRepPtr = copyPtr->internalRep.twoPtrValue.ptr1;
+ Tcl_Obj **copyObjv = &listRepPtr->elements;
+ int i;
+
+ listRepPtr->elemCount = objc - opnd + 1;
+ copyObjv[0] = objPtr;
+ memcpy(copyObjv+1, objv+opnd, sizeof(Tcl_Obj *) * (objc - opnd));
+ for (i=1 ; i<objc-opnd+1 ; i++) {
+ Tcl_IncrRefCount(copyObjv[i]);
+ }
+ objPtr = copyPtr;
+ }
+ bcFramePtr->data.tebc.pc = (char *) pc;
+ iPtr->cmdFramePtr = bcFramePtr;
+ if (iPtr->flags & INTERP_DEBUG_FRAME) {
+ TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc,
+ codePtr, bcFramePtr, pc - codePtr->codeStart);
+ }
+ iPtr->ensembleRewrite.sourceObjs = objv;
+ iPtr->ensembleRewrite.numRemovedObjs = opnd;
+ iPtr->ensembleRewrite.numInsertedObjs = 1;
+ DECACHE_STACK_INFO();
+ pc += 6;
+ TEBC_YIELD();
+
+ TclNRAddCallback(interp, TclClearRootEnsemble, NULL,NULL,NULL,NULL);
+ TclSkipTailcall(interp);
+ return TclNREvalObjEx(interp, objPtr, TCL_EVAL_INVOKE, NULL, INT_MIN);
+
/*
* -----------------------------------------------------------------
* Start of INST_LOAD instructions.
@@ -3433,8 +3464,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;
@@ -7022,6 +7053,42 @@ TEBCresume(
TclStackFree(interp, 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
@@ -8485,11 +8552,10 @@ ValidatePcAndStackTop(
int stackTop, /* Current stack top. Must be between
* stackLowerBound and stackUpperBound
* (inclusive). */
- int stackLowerBound, /* Smallest legal value for stackTop. */
int checkStack) /* 0 if the stack depth check should be
* skipped. */
{
- int stackUpperBound = stackLowerBound + codePtr->maxStackDepth;
+ int stackUpperBound = codePtr->maxStackDepth;
/* Greatest legal value for stackTop. */
unsigned relativePc = (unsigned) (pc - codePtr->codeStart);
unsigned long codeStart = (unsigned long) codePtr->codeStart;
@@ -8507,13 +8573,13 @@ ValidatePcAndStackTop(
(unsigned) opCode, relativePc);
Tcl_Panic("TclNRExecuteByteCode execution failure: bad opcode");
}
- if (checkStack &&
- ((stackTop < stackLowerBound) || (stackTop > stackUpperBound))) {
+ if (checkStack &&
+ ((stackTop < 0) || (stackTop > stackUpperBound))) {
int numChars;
const char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars, NULL);
- fprintf(stderr, "\nBad stack top %d at pc %u in TclNRExecuteByteCode (min %i, max %i)",
- stackTop, relativePc, stackLowerBound, stackUpperBound);
+ fprintf(stderr, "\nBad stack top %d at pc %u in TclNRExecuteByteCode (min 0, max %i)",
+ stackTop, relativePc, stackUpperBound);
if (cmd != NULL) {
Tcl_Obj *message;
diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c
index 33c1496..adf60d9 100644
--- a/generic/tclFCmd.c
+++ b/generic/tclFCmd.c
@@ -10,6 +10,7 @@
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
+#include <sys/stat.h>
#include "tclInt.h"
#include "tclFileSystem.h"
diff --git a/generic/tclFileName.c b/generic/tclFileName.c
index 5d4702b..193ca4e 100644
--- a/generic/tclFileName.c
+++ b/generic/tclFileName.c
@@ -11,6 +11,7 @@
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
+#include <sys/stat.h>
#include "tclInt.h"
#include "tclRegexp.h"
#include "tclFileSystem.h" /* For TclGetPathType() */
diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c
index 005713d..1673bce 100644
--- a/generic/tclIOCmd.c
+++ b/generic/tclIOCmd.c
@@ -1952,25 +1952,25 @@ TclInitChanCmd(
* function at the moment.
*/
static const EnsembleImplMap initMap[] = {
- {"blocked", Tcl_FblockedObjCmd, NULL, NULL, NULL, 0},
- {"close", Tcl_CloseObjCmd, NULL, NULL, NULL, 0},
- {"copy", Tcl_FcopyObjCmd, NULL, NULL, NULL, 0},
- {"create", TclChanCreateObjCmd, NULL, NULL, NULL, 0}, /* TIP #219 */
- {"eof", Tcl_EofObjCmd, NULL, NULL, NULL, 0},
- {"event", Tcl_FileEventObjCmd, NULL, NULL, NULL, 0},
- {"flush", Tcl_FlushObjCmd, NULL, NULL, NULL, 0},
- {"gets", Tcl_GetsObjCmd, NULL, NULL, NULL, 0},
- {"names", TclChannelNamesCmd, NULL, NULL, NULL, 0},
- {"pending", ChanPendingObjCmd, NULL, NULL, NULL, 0}, /* TIP #287 */
- {"pop", TclChanPopObjCmd, NULL, NULL, NULL, 0}, /* TIP #230 */
- {"postevent", TclChanPostEventObjCmd, NULL, NULL, NULL, 0}, /* TIP #219 */
- {"push", TclChanPushObjCmd, NULL, NULL, NULL, 0}, /* TIP #230 */
- {"puts", Tcl_PutsObjCmd, NULL, NULL, NULL, 0},
- {"read", Tcl_ReadObjCmd, NULL, NULL, NULL, 0},
- {"seek", Tcl_SeekObjCmd, NULL, NULL, NULL, 0},
- {"pipe", ChanPipeObjCmd, NULL, NULL, NULL, 0}, /* TIP #304 */
- {"tell", Tcl_TellObjCmd, NULL, NULL, NULL, 0},
- {"truncate", ChanTruncateObjCmd, NULL, NULL, NULL, 0}, /* TIP #208 */
+ {"blocked", Tcl_FblockedObjCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"close", Tcl_CloseObjCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
+ {"copy", Tcl_FcopyObjCmd, NULL, NULL, NULL, 0},
+ {"create", TclChanCreateObjCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, /* TIP #219 */
+ {"eof", Tcl_EofObjCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"event", Tcl_FileEventObjCmd, TclCompileBasic2Or3ArgCmd, NULL, NULL, 0},
+ {"flush", Tcl_FlushObjCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"gets", Tcl_GetsObjCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
+ {"names", TclChannelNamesCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
+ {"pending", ChanPendingObjCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, /* TIP #287 */
+ {"pipe", ChanPipeObjCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, /* TIP #304 */
+ {"pop", TclChanPopObjCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, /* TIP #230 */
+ {"postevent", TclChanPostEventObjCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, /* TIP #219 */
+ {"push", TclChanPushObjCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, /* TIP #230 */
+ {"puts", Tcl_PutsObjCmd, NULL, NULL, NULL, 0},
+ {"read", Tcl_ReadObjCmd, NULL, NULL, NULL, 0},
+ {"seek", Tcl_SeekObjCmd, TclCompileBasic2Or3ArgCmd, NULL, NULL, 0},
+ {"tell", Tcl_TellObjCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"truncate", ChanTruncateObjCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, /* TIP #208 */
{NULL, NULL, NULL, NULL, NULL, 0}
};
static const char *const extras[] = {
diff --git a/generic/tclIORTrans.c b/generic/tclIORTrans.c
index 2b9efb9..1de635f 100644
--- a/generic/tclIORTrans.c
+++ b/generic/tclIORTrans.c
@@ -2942,7 +2942,7 @@ ResultClear(
return;
}
- Tcl_Free((char *) rPtr->buf);
+ ckfree((char *) rPtr->buf);
rPtr->buf = NULL;
rPtr->allocated = 0;
}
@@ -2977,10 +2977,10 @@ ResultAdd(
if (rPtr->allocated == 0) {
rPtr->allocated = toWrite + RB_INCREMENT;
- rPtr->buf = UCHARP(Tcl_Alloc(rPtr->allocated));
+ rPtr->buf = UCHARP(ckalloc(rPtr->allocated));
} else {
rPtr->allocated += toWrite + RB_INCREMENT;
- rPtr->buf = UCHARP(Tcl_Realloc((char *) rPtr->buf,
+ rPtr->buf = UCHARP(ckrealloc((char *) rPtr->buf,
rPtr->allocated));
}
}
diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c
index ab08353..f523e8f 100644
--- a/generic/tclIOUtil.c
+++ b/generic/tclIOUtil.c
@@ -18,9 +18,7 @@
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
-#if defined(HAVE_SYS_STAT_H) && !defined _WIN32
-# include <sys/stat.h>
-#endif
+#include <sys/stat.h>
#include "tclInt.h"
#ifdef __WIN32__
# include "tclWinInt.h"
diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c
index cb345e2..0372668 100644
--- a/generic/tclIndexObj.c
+++ b/generic/tclIndexObj.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)
/*
*----------------------------------------------------------------------
@@ -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,6 +270,10 @@ 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.
*/
@@ -533,9 +537,9 @@ TclInitPrefixCmd(
Tcl_Interp *interp) /* Current interpreter. */
{
static const EnsembleImplMap prefixImplMap[] = {
- {"all", PrefixAllObjCmd, NULL, NULL, NULL, 0},
- {"longest", PrefixLongestObjCmd, NULL, NULL, NULL, 0},
- {"match", PrefixMatchObjCmd, NULL, NULL, NULL, 0},
+ {"all", PrefixAllObjCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
+ {"longest", PrefixLongestObjCmd,TclCompileBasic2ArgCmd, NULL, NULL, 0},
+ {"match", PrefixMatchObjCmd, TclCompileBasicMin2ArgCmd, NULL, NULL, 0},
{NULL, NULL, NULL, NULL, NULL, 0}
};
Tcl_Command prefixCmd;
diff --git a/generic/tclInt.decls b/generic/tclInt.decls
index f215d32..f0e907f 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
@@ -941,9 +941,9 @@ declare 235 {
# TIP 337 made this one public
-#declare 236 {
-# void TclBackgroundException(Tcl_Interp *interp, int code)
-#}
+declare 236 {
+ void TclBackgroundException(Tcl_Interp *interp, int code)
+}
# TIP #285: Script cancellation support.
declare 237 {
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 1d04c82..18768d9 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -1154,7 +1154,7 @@ typedef struct CallFrame {
* meaning of the value is, which we do not
* specify. */
LocalCache *localCachePtr;
- struct NRE_callback *tailcallPtr;
+ Tcl_Obj *tailcallPtr;
/* NULL if no tailcall is scheduled */
} CallFrame;
@@ -2250,7 +2250,6 @@ typedef struct InterpList {
#define TCL_ALLOW_EXCEPTIONS 4
#define TCL_EVAL_FILE 2
#define TCL_EVAL_CTX 8
-#define TCL_EVAL_REDIRECT 16
/*
* Flag bits for Interp structures:
@@ -2805,8 +2804,12 @@ MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldmObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldToObjCmd;
-MODULE_SCOPE void TclSpliceTailcall(Tcl_Interp *interp,
- struct NRE_callback *tailcallPtr);
+MODULE_SCOPE void TclSetTailcall(Tcl_Interp *interp, Tcl_Obj *tailcallPtr);
+MODULE_SCOPE void TclPushTailcallPoint(Tcl_Interp *interp);
+
+/* These two can be considered for the public api */
+MODULE_SCOPE void TclMarkTailcall(Tcl_Interp *interp);
+MODULE_SCOPE void TclSkipTailcall(Tcl_Interp *interp);
/*
* This structure holds the data for the various iteration callbacks used to
@@ -2881,7 +2884,6 @@ MODULE_SCOPE void TclAppendBytesToByteArray(Tcl_Obj *objPtr,
const unsigned char *bytes, int len);
MODULE_SCOPE int TclNREvalCmd(Tcl_Interp *interp, Tcl_Obj *objPtr,
int flags);
-MODULE_SCOPE void TclPushTailcallPoint(Tcl_Interp *interp);
MODULE_SCOPE void TclAdvanceContinuations(int *line, int **next,
int loc);
MODULE_SCOPE void TclAdvanceLines(int *line, const char *start,
@@ -3716,6 +3718,42 @@ MODULE_SCOPE int TclCompileWhileCmd(Tcl_Interp *interp,
MODULE_SCOPE int TclCompileYieldCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileBasic0ArgCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileBasic1ArgCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileBasic2ArgCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileBasic3ArgCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileBasic0Or1ArgCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileBasic1Or2ArgCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileBasic2Or3ArgCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileBasic0To2ArgCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileBasic1To3ArgCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileBasicMin0ArgCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileBasicMin1ArgCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileBasicMin2ArgCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
MODULE_SCOPE int TclInvertOpCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
@@ -4008,12 +4046,13 @@ typedef const char *TclDTraceStr;
*/
# define TclAllocObjStorageEx(interp, objPtr) \
- (objPtr) = (Tcl_Obj *) Tcl_Alloc(sizeof(Tcl_Obj))
+ (objPtr) = (Tcl_Obj *) ckalloc(sizeof(Tcl_Obj))
# define TclFreeObjStorageEx(interp, objPtr) \
ckfree((char *) (objPtr))
#undef USE_THREAD_ALLOC
+#undef USE_TCLALLOC
#elif defined(TCL_THREADS) && defined(USE_THREAD_ALLOC)
/*
@@ -4771,35 +4810,6 @@ typedef struct NRE_callback {
TOP_CB(interp) = callbackPtr; \
} while (0)
-#define TclNRDeferCallback(interp,postProcPtr,data0,data1,data2,data3) \
- do { \
- NRE_callback *callbackPtr; \
- TCLNR_ALLOC((interp), (callbackPtr)); \
- callbackPtr->procPtr = (postProcPtr); \
- callbackPtr->data[0] = (ClientData)(data0); \
- callbackPtr->data[1] = (ClientData)(data1); \
- callbackPtr->data[2] = (ClientData)(data2); \
- callbackPtr->data[3] = (ClientData)(data3); \
- callbackPtr->nextPtr = ((Interp *)interp)->deferredCallbacks; \
- ((Interp *)interp)->deferredCallbacks = callbackPtr; \
- } while (0)
-
-#define TclNRSpliceCallbacks(interp, topPtr) \
- do { \
- NRE_callback *bottomPtr = topPtr; \
- while (bottomPtr->nextPtr) { \
- bottomPtr = bottomPtr->nextPtr; \
- } \
- bottomPtr->nextPtr = TOP_CB(interp); \
- TOP_CB(interp) = topPtr; \
- } while (0)
-
-#define TclNRSpliceDeferred(interp) \
- if (((Interp *)interp)->deferredCallbacks) { \
- TclNRSpliceCallbacks(interp, ((Interp *)interp)->deferredCallbacks); \
- ((Interp *)interp)->deferredCallbacks = NULL; \
- }
-
#if NRE_USE_SMALL_ALLOC
#define TCLNR_ALLOC(interp, ptr) \
TclSmallAllocEx(interp, sizeof(NRE_callback), (ptr))
diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h
index df5ac97..cf88e5f 100644
--- a/generic/tclIntDecls.h
+++ b/generic/tclIntDecls.h
@@ -29,19 +29,20 @@
#endif
/* [Bug #803489] Tcl_FindNamespace problem in the Stubs table */
-#undef Tcl_AppendExportList
#undef Tcl_CreateNamespace
#undef Tcl_DeleteNamespace
+#undef Tcl_AppendExportList
#undef Tcl_Export
-#undef Tcl_FindCommand
-#undef Tcl_FindNamespace
-#undef Tcl_FindNamespaceVar
+#undef Tcl_Import
#undef Tcl_ForgetImport
-#undef Tcl_GetCommandFromObj
-#undef Tcl_GetCommandFullName
#undef Tcl_GetCurrentNamespace
#undef Tcl_GetGlobalNamespace
-#undef Tcl_Import
+#undef Tcl_FindNamespace
+#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
@@ -395,8 +396,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,
@@ -414,8 +417,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);
@@ -447,8 +452,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 */
@@ -557,7 +565,8 @@ EXTERN Var * TclVarHashCreateVar(TclVarHashTable *tablePtr,
/* 235 */
EXTERN void TclInitVarHashTable(TclVarHashTable *tablePtr,
Namespace *nsPtr);
-/* Slot 236 is reserved */
+/* 236 */
+EXTERN void TclBackgroundException(Tcl_Interp *interp, int code);
/* 237 */
EXTERN int TclResetCancellation(Tcl_Interp *interp, int force);
/* 238 */
@@ -764,8 +773,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 */
@@ -773,8 +782,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 */
@@ -784,8 +793,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 */
@@ -842,7 +851,7 @@ typedef struct TclIntStubs {
void (*tclGetSrcInfoForPc) (CmdFrame *contextPtr); /* 233 */
Var * (*tclVarHashCreateVar) (TclVarHashTable *tablePtr, const char *key, int *newPtr); /* 234 */
void (*tclInitVarHashTable) (TclVarHashTable *tablePtr, Namespace *nsPtr); /* 235 */
- void (*reserved236)(void);
+ void (*tclBackgroundException) (Tcl_Interp *interp, int code); /* 236 */
int (*tclResetCancellation) (Tcl_Interp *interp, int force); /* 237 */
int (*tclNRInterpProc) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 238 */
int (*tclNRInterpProcCore) (Tcl_Interp *interp, Tcl_Obj *procNameObj, int skip, ProcErrorProc *errorProc); /* 239 */
@@ -1130,8 +1139,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 */
@@ -1145,8 +1156,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 \
@@ -1164,8 +1177,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 \
@@ -1252,7 +1267,8 @@ extern const TclIntStubs *tclIntStubsPtr;
(tclIntStubsPtr->tclVarHashCreateVar) /* 234 */
#define TclInitVarHashTable \
(tclIntStubsPtr->tclInitVarHashTable) /* 235 */
-/* Slot 236 is reserved */
+#define TclBackgroundException \
+ (tclIntStubsPtr->tclBackgroundException) /* 236 */
#define TclResetCancellation \
(tclIntStubsPtr->tclResetCancellation) /* 237 */
#define TclNRInterpProc \
@@ -1289,4 +1305,55 @@ 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 */
+# undef Tcl_DeleteNamespace
+# define Tcl_DeleteNamespace \
+ (tclStubsPtr->tcl_DeleteNamespace) /* 507 */
+# undef Tcl_AppendExportList
+# define Tcl_AppendExportList \
+ (tclStubsPtr->tcl_AppendExportList) /* 508 */
+# undef Tcl_Export
+# define Tcl_Export \
+ (tclStubsPtr->tcl_Export) /* 509 */
+# undef Tcl_Import
+# define Tcl_Import \
+ (tclStubsPtr->tcl_Import) /* 510 */
+# undef Tcl_ForgetImport
+# define Tcl_ForgetImport \
+ (tclStubsPtr->tcl_ForgetImport) /* 511 */
+# undef Tcl_GetCurrentNamespace
+# define Tcl_GetCurrentNamespace \
+ (tclStubsPtr->tcl_GetCurrentNamespace) /* 512 */
+# undef Tcl_GetGlobalNamespace
+# define Tcl_GetGlobalNamespace \
+ (tclStubsPtr->tcl_GetGlobalNamespace) /* 513 */
+# undef Tcl_FindNamespace
+# define Tcl_FindNamespace \
+ (tclStubsPtr->tcl_FindNamespace) /* 514 */
+# undef Tcl_FindCommand
+# define Tcl_FindCommand \
+ (tclStubsPtr->tcl_FindCommand) /* 515 */
+# undef Tcl_GetCommandFromObj
+# define Tcl_GetCommandFromObj \
+ (tclStubsPtr->tcl_GetCommandFromObj) /* 516 */
+# undef Tcl_GetCommandFullName
+# define Tcl_GetCommandFullName \
+ (tclStubsPtr->tcl_GetCommandFullName) /* 517 */
+#endif
+
#endif /* _TCLINTDECLS */
diff --git a/generic/tclInterp.c b/generic/tclInterp.c
index 0b0f652..d5d43ed 100644
--- a/generic/tclInterp.c
+++ b/generic/tclInterp.c
@@ -1798,9 +1798,9 @@ AliasNRCmd(
*/
if (isRootEnsemble) {
- TclNRDeferCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL);
+ TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL);
}
- iPtr->evalFlags |= TCL_EVAL_REDIRECT;
+ TclSkipTailcall(interp);
return Tcl_NREvalObj(interp, listPtr, flags);
}
diff --git a/generic/tclListObj.c b/generic/tclListObj.c
index 3668b45..2d1defa 100644
--- a/generic/tclListObj.c
+++ b/generic/tclListObj.c
@@ -909,6 +909,10 @@ Tcl_ListObjReplace(
isShared = (listRepPtr->refCount > 1);
numRequired = numElems - count + objc;
+ for (i = 0; i < objc; i++) {
+ Tcl_IncrRefCount(objv[i]);
+ }
+
if ((numRequired <= listRepPtr->maxElemCount) && !isShared) {
int shift;
@@ -963,6 +967,14 @@ Tcl_ListObjReplace(
if (listRepPtr == NULL) {
listRepPtr = AttemptNewList(interp, numRequired, NULL);
if (listRepPtr == NULL) {
+ for (i = 0; i < objc; i++) {
+ /* See bug 3598580 */
+#if TCL_MAJOR_VERSION > 8
+ Tcl_DecrRefCount(objv[i]);
+#else
+ objv[i]->refCount--;
+#endif
+ }
return TCL_ERROR;
}
}
@@ -1027,14 +1039,11 @@ Tcl_ListObjReplace(
}
/*
- * Insert the new elements into elemPtrs before "first". We don't do a
- * memcpy here because we must increment the reference counts for the
- * added elements, so we must explicitly loop anyway.
+ * Insert the new elements into elemPtrs before "first".
*/
for (i=0,j=first ; i<objc ; i++,j++) {
elemPtrs[j] = objv[i];
- Tcl_IncrRefCount(objv[i]);
}
/*
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index 02d517f..304487b 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -160,23 +160,23 @@ static const Tcl_ObjType nsNameType = {
*/
static const EnsembleImplMap defaultNamespaceMap[] = {
- {"children", NamespaceChildrenCmd, NULL, NULL, NULL, 0},
+ {"children", NamespaceChildrenCmd, TclCompileBasic0To2ArgCmd, NULL, NULL, 0},
{"code", NamespaceCodeCmd, TclCompileNamespaceCodeCmd, NULL, NULL, 0},
{"current", NamespaceCurrentCmd, TclCompileNamespaceCurrentCmd, NULL, NULL, 0},
- {"delete", NamespaceDeleteCmd, NULL, NULL, NULL, 0},
+ {"delete", NamespaceDeleteCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 0},
{"ensemble", TclNamespaceEnsembleCmd, NULL, NULL, NULL, 0},
{"eval", NamespaceEvalCmd, NULL, NRNamespaceEvalCmd, NULL, 0},
- {"exists", NamespaceExistsCmd, NULL, NULL, NULL, 0},
- {"export", NamespaceExportCmd, NULL, NULL, NULL, 0},
- {"forget", NamespaceForgetCmd, NULL, NULL, NULL, 0},
- {"import", NamespaceImportCmd, NULL, NULL, NULL, 0},
+ {"exists", NamespaceExistsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"export", NamespaceExportCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 0},
+ {"forget", NamespaceForgetCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 0},
+ {"import", NamespaceImportCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 0},
{"inscope", NamespaceInscopeCmd, NULL, NRNamespaceInscopeCmd, NULL, 0},
- {"origin", NamespaceOriginCmd, NULL, NULL, NULL, 0},
- {"parent", NamespaceParentCmd, NULL, NULL, NULL, 0},
- {"path", NamespacePathCmd, NULL, NULL, NULL, 0},
+ {"origin", NamespaceOriginCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"parent", NamespaceParentCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
+ {"path", NamespacePathCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
{"qualifiers", NamespaceQualifiersCmd, TclCompileNamespaceQualifiersCmd, NULL, NULL, 0},
{"tail", NamespaceTailCmd, TclCompileNamespaceTailCmd, NULL, NULL, 0},
- {"unknown", NamespaceUnknownCmd, NULL, NULL, NULL, 0},
+ {"unknown", NamespaceUnknownCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
{"upvar", NamespaceUpvarCmd, TclCompileNamespaceUpvarCmd, NULL, NULL, 0},
{"which", NamespaceWhichCmd, TclCompileNamespaceWhichCmd, NULL, NULL, 0},
{NULL, NULL, NULL, NULL, NULL, 0}
@@ -423,7 +423,7 @@ Tcl_PopCallFrame(
framePtr->nsPtr = NULL;
if (framePtr->tailcallPtr) {
- TclSpliceTailcall(interp, framePtr->tailcallPtr);
+ TclSetTailcall(interp, framePtr->tailcallPtr);
}
}
@@ -1945,7 +1945,7 @@ InvokeImportedNRCmd(
ImportedCmdData *dataPtr = clientData;
Command *realCmdPtr = dataPtr->realCmdPtr;
- ((Interp *) interp)->evalFlags |= TCL_EVAL_REDIRECT;
+ TclSkipTailcall(interp);
return Tcl_NRCmdSwap(interp, (Tcl_Command) realCmdPtr, objc, objv, 0);
}
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/tclOOInfo.c b/generic/tclOOInfo.c
index 5be9b01..3217f98 100644
--- a/generic/tclOOInfo.c
+++ b/generic/tclOOInfo.c
@@ -48,18 +48,18 @@ static Tcl_ObjCmdProc InfoClassVariablesCmd;
*/
static const EnsembleImplMap infoObjectCmds[] = {
- {"call", InfoObjectCallCmd, NULL, NULL, NULL, 0},
+ {"call", InfoObjectCallCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
{"class", InfoObjectClassCmd, TclCompileInfoObjectClassCmd, NULL, NULL, 0},
- {"definition", InfoObjectDefnCmd, NULL, NULL, NULL, 0},
- {"filters", InfoObjectFiltersCmd, NULL, NULL, NULL, 0},
- {"forward", InfoObjectForwardCmd, NULL, NULL, NULL, 0},
+ {"definition", InfoObjectDefnCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
+ {"filters", InfoObjectFiltersCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"forward", InfoObjectForwardCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
{"isa", InfoObjectIsACmd, TclCompileInfoObjectIsACmd, NULL, NULL, 0},
- {"methods", InfoObjectMethodsCmd, NULL, NULL, NULL, 0},
- {"methodtype", InfoObjectMethodTypeCmd, NULL, NULL, NULL, 0},
- {"mixins", InfoObjectMixinsCmd, NULL, NULL, NULL, 0},
+ {"methods", InfoObjectMethodsCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0},
+ {"methodtype", InfoObjectMethodTypeCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
+ {"mixins", InfoObjectMixinsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"namespace", InfoObjectNsCmd, TclCompileInfoObjectNamespaceCmd, NULL, NULL, 0},
- {"variables", InfoObjectVariablesCmd, NULL, NULL, NULL, 0},
- {"vars", InfoObjectVarsCmd, NULL, NULL, NULL, 0},
+ {"variables", InfoObjectVariablesCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"vars", InfoObjectVarsCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
{NULL, NULL, NULL, NULL, NULL, 0}
};
@@ -68,19 +68,19 @@ static const EnsembleImplMap infoObjectCmds[] = {
*/
static const EnsembleImplMap infoClassCmds[] = {
- {"call", InfoClassCallCmd, NULL, NULL, NULL, 0},
- {"constructor", InfoClassConstrCmd, NULL, NULL, NULL, 0},
- {"definition", InfoClassDefnCmd, NULL, NULL, NULL, 0},
- {"destructor", InfoClassDestrCmd, NULL, NULL, NULL, 0},
- {"filters", InfoClassFiltersCmd, NULL, NULL, NULL, 0},
- {"forward", InfoClassForwardCmd, NULL, NULL, NULL, 0},
- {"instances", InfoClassInstancesCmd, NULL, NULL, NULL, 0},
- {"methods", InfoClassMethodsCmd, NULL, NULL, NULL, 0},
- {"methodtype", InfoClassMethodTypeCmd, NULL, NULL, NULL, 0},
- {"mixins", InfoClassMixinsCmd, NULL, NULL, NULL, 0},
- {"subclasses", InfoClassSubsCmd, NULL, NULL, NULL, 0},
- {"superclasses", InfoClassSupersCmd, NULL, NULL, NULL, 0},
- {"variables", InfoClassVariablesCmd, NULL, NULL, NULL, 0},
+ {"call", InfoClassCallCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
+ {"constructor", InfoClassConstrCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"definition", InfoClassDefnCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
+ {"destructor", InfoClassDestrCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"filters", InfoClassFiltersCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"forward", InfoClassForwardCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
+ {"instances", InfoClassInstancesCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
+ {"methods", InfoClassMethodsCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0},
+ {"methodtype", InfoClassMethodTypeCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
+ {"mixins", InfoClassMixinsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"subclasses", InfoClassSubsCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
+ {"superclasses", InfoClassSupersCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"variables", InfoClassVariablesCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{NULL, NULL, NULL, NULL, NULL, 0}
};
diff --git a/generic/tclOOStubLib.c b/generic/tclOOStubLib.c
index 55f2378..921aced 100644
--- a/generic/tclOOStubLib.c
+++ b/generic/tclOOStubLib.c
@@ -2,19 +2,6 @@
* ORIGINAL SOURCE: tk/generic/tkStubLib.c, version 1.9 2004/03/17
*/
-/*
- * We need to ensure that we use the tcl stub macros so that this file
- * contains no references to any of the tcl stub functions.
- */
-
-#undef USE_TCL_STUBS
-#define USE_TCL_STUBS
-
-#ifdef HAVE_CONFIG_H
-#include "config.h"
-#endif
-
-#define USE_TCLOO_STUBS 1
#include "tclOOInt.h"
MODULE_SCOPE const TclOOStubs *tclOOStubsPtr;
@@ -35,51 +22,48 @@ const TclOOIntStubs *tclOOIntStubsPtr = NULL;
* to indicate that an error occurred.
*
* Side effects:
- * Sets the stub table pointer.
+ * Sets the stub table pointers.
*
*----------------------------------------------------------------------
*/
MODULE_SCOPE const char *
TclOOInitializeStubs(
- Tcl_Interp *interp, const char *version)
+ Tcl_Interp *interp,
+ const char *version)
{
int exact = 0;
const char *packageName = "TclOO";
const char *errMsg = NULL;
- ClientData clientData = NULL;
- const char *actualVersion =
- Tcl_PkgRequireEx(interp, packageName,version, exact, &clientData);
+ TclOOStubs *stubsPtr = NULL;
+ const char *actualVersion = tclStubsPtr->tcl_PkgRequireEx(interp,
+ packageName, version, exact, &stubsPtr);
- if (clientData == NULL) {
- Tcl_ResetResult(interp);
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "error loading %s package; package not present or incomplete",
- packageName));
+ if (actualVersion == NULL) {
return NULL;
+ }
+ if (stubsPtr == NULL) {
+ errMsg = "missing stub table pointer";
} else {
- const TclOOStubs * const stubsPtr = clientData;
- const TclOOIntStubs * const intStubsPtr = stubsPtr->hooks ?
- stubsPtr->hooks->tclOOIntStubs : NULL;
-
- if (!actualVersion) {
- return NULL;
- }
-
- if (!stubsPtr || !intStubsPtr) {
- errMsg = "missing stub table pointer";
- goto error;
- }
-
tclOOStubsPtr = stubsPtr;
- tclOOIntStubsPtr = intStubsPtr;
+ if (stubsPtr->hooks) {
+ tclOOIntStubsPtr = stubsPtr->hooks->tclOOIntStubs;
+ } else {
+ tclOOIntStubsPtr = NULL;
+ }
return actualVersion;
-
- error:
- Tcl_ResetResult(interp);
- Tcl_SetObjResult(interp, Tcl_ObjPrintf("Error loading %s package"
- " (requested version '%s', loaded version '%s'): %s",
- packageName, version, actualVersion, errMsg));
- return NULL;
}
+ tclStubsPtr->tcl_ResetResult(interp);
+ tclStubsPtr->tcl_AppendResult(interp, "Error loading ", packageName,
+ " (requested version ", version, ", actual version ",
+ actualVersion, "): ", errMsg, NULL);
+ return NULL;
}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
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/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/tclStubInit.c b/generic/tclStubInit.c
index 88ada19..1dbdc09 100644
--- a/generic/tclStubInit.c
+++ b/generic/tclStubInit.c
@@ -41,6 +41,7 @@
#undef Tcl_FindExecutable
#undef TclpGetPid
#undef TclSockMinimumBuffers
+#define TclBackgroundException Tcl_BackgroundException
/* See bug 510001: TclSockMinimumBuffers needs plat imp */
#ifdef _WIN64
@@ -53,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
@@ -347,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 */
@@ -356,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 */
@@ -367,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 */
@@ -425,7 +451,7 @@ static const TclIntStubs tclIntStubs = {
TclGetSrcInfoForPc, /* 233 */
TclVarHashCreateVar, /* 234 */
TclInitVarHashTable, /* 235 */
- 0, /* 236 */
+ TclBackgroundException, /* 236 */
TclResetCancellation, /* 237 */
TclNRInterpProc, /* 238 */
TclNRInterpProcCore, /* 239 */
diff --git a/generic/tclStubLib.c b/generic/tclStubLib.c
index a9d0f02..859cbf9 100644
--- a/generic/tclStubLib.c
+++ b/generic/tclStubLib.c
@@ -23,22 +23,8 @@ const TclPlatStubs *tclPlatStubsPtr = NULL;
const TclIntStubs *tclIntStubsPtr = NULL;
const TclIntPlatStubs *tclIntPlatStubsPtr = NULL;
-static const TclStubs *
-HasStubSupport(
- Tcl_Interp *interp)
-{
- Interp *iPtr = (Interp *) interp;
-
- if (iPtr->stubTable && (iPtr->stubTable->magic == TCL_STUB_MAGIC)) {
- return iPtr->stubTable;
- }
- iPtr->result = (char *) "interpreter uses an incompatible stubs mechanism";
- iPtr->freeProc = TCL_STATIC;
- return NULL;
-}
-
/*
- * Use our own isdigit to avoid linking to libc on windows
+ * Use our own isDigit to avoid linking to libc on windows
*/
static int isDigit(const int c)
@@ -70,9 +56,10 @@ Tcl_InitStubs(
const char *version,
int exact)
{
+ Interp *iPtr = (Interp *) interp;
const char *actualVersion = NULL;
ClientData pkgData = NULL;
- const TclStubs *stubsPtr;
+ const TclStubs *stubsPtr = iPtr->stubTable;
/*
* We can't optimize this check by caching tclStubsPtr because that
@@ -80,8 +67,9 @@ Tcl_InitStubs(
* times. [Bug 615304]
*/
- stubsPtr = HasStubSupport(interp);
- if (!stubsPtr) {
+ if (!stubsPtr || (stubsPtr->magic != TCL_STUB_MAGIC)) {
+ iPtr->result = "interpreter uses an incompatible stubs mechanism";
+ iPtr->freeProc = TCL_STATIC;
return NULL;
}
diff --git a/generic/tclTest.c b/generic/tclTest.c
index a8b27fb..297fe4d 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -19,6 +19,7 @@
#ifndef USE_TCL_STUBS
# define USE_TCL_STUBS
#endif
+#include <sys/stat.h>
#include "tclInt.h"
#include "tclOO.h"
#include <math.h>
diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c
index 7494beb..4bddc42 100644
--- a/generic/tclTestObj.c
+++ b/generic/tclTestObj.c
@@ -963,6 +963,17 @@ TestobjCmd(
}
SetVarToObj(varPtr, destIndex, varPtr[varIndex]);
Tcl_SetObjResult(interp, varPtr[destIndex]);
+ } else if (strcmp(subCmd, "bug3598580") == 0) {
+ Tcl_Obj *listObjPtr, *elemObjPtr;
+ if (objc != 2) {
+ goto wrongNumArgs;
+ }
+ elemObjPtr = Tcl_NewIntObj(123);
+ listObjPtr = Tcl_NewListObj(1, &elemObjPtr);
+ /* Replace the single list element through itself, nonsense but legal. */
+ Tcl_ListObjReplace(interp, listObjPtr, 0, 1, 1, &elemObjPtr);
+ Tcl_SetObjResult(interp, listObjPtr);
+ return TCL_OK;
} else if (strcmp(subCmd, "convert") == 0) {
const char *typeName;
diff --git a/generic/tclThreadTest.c b/generic/tclThreadTest.c
index 22b5995..8708f9a 100644
--- a/generic/tclThreadTest.c
+++ b/generic/tclThreadTest.c
@@ -513,7 +513,6 @@ ThreadCreate(
TCL_THREAD_STACK_DEFAULT, joinable) != TCL_OK) {
Tcl_MutexUnlock(&threadMutex);
Tcl_AppendResult(interp, "can't create a new thread", NULL);
- ckfree(ctrl.script);
return TCL_ERROR;
}
@@ -927,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/tclTomMathInterface.c b/generic/tclTomMathInterface.c
index 775e86b..48db8c3 100644
--- a/generic/tclTomMathInterface.c
+++ b/generic/tclTomMathInterface.c
@@ -111,7 +111,7 @@ extern void *
TclBNAlloc(
size_t x)
{
- return (void *) Tcl_Alloc((unsigned int) x);
+ return (void *) ckalloc((unsigned int) x);
}
/*
@@ -135,7 +135,7 @@ TclBNRealloc(
void *p,
size_t s)
{
- return (void *) Tcl_Realloc((char *) p, (unsigned int) s);
+ return (void *) ckrealloc((char *) p, (unsigned int) s);
}
/*
@@ -161,7 +161,7 @@ extern void
TclBNFree(
void *p)
{
- Tcl_Free((char *) p);
+ ckree((char *) p);
}
#endif
diff --git a/generic/tclTomMathStubLib.c b/generic/tclTomMathStubLib.c
index a3bc4b3..324f2a3 100644
--- a/generic/tclTomMathStubLib.c
+++ b/generic/tclTomMathStubLib.c
@@ -11,15 +11,6 @@
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
-/*
- * We need to ensure that we use the stub macros so that this file contains no
- * references to any of the stub functions. This will make it possible to
- * build an extension that references Tcl_InitStubs but doesn't end up
- * including the rest of the stub functions.
- */
-
-#define USE_TCL_STUBS
-
#include "tclInt.h"
MODULE_SCOPE const TclTomMathStubs *tclTomMathStubsPtr;
@@ -55,31 +46,30 @@ TclTomMathInitializeStubs(
int exact = 0;
const char *packageName = "tcl::tommath";
const char *errMsg = NULL;
- ClientData pkgClientData = NULL;
- const char *actualVersion =
- Tcl_PkgRequireEx(interp, packageName, version, exact, &pkgClientData);
- const TclTomMathStubs *stubsPtr = pkgClientData;
+ TclTomMathStubs *stubsPtr = NULL;
+ const char *actualVersion = tclStubsPtr->tcl_PkgRequireEx(interp,
+ packageName, version, exact, &stubsPtr);
if (actualVersion == NULL) {
return NULL;
}
- if (pkgClientData == NULL) {
+ if (stubsPtr == NULL) {
errMsg = "missing stub table pointer";
- } else if ((stubsPtr->tclBN_epoch)() != epoch) {
+ } else if(stubsPtr->tclBN_epoch() != epoch) {
errMsg = "epoch number mismatch";
- } else if ((stubsPtr->tclBN_revision)() != revision) {
+ } else if(stubsPtr->tclBN_revision() != revision) {
errMsg = "requires a later revision";
} else {
tclTomMathStubsPtr = stubsPtr;
return actualVersion;
}
-
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "error loading %s (requested version %s, actual version %s): %s",
- packageName, version, actualVersion, errMsg));
+ tclStubsPtr->tcl_ResetResult(interp);
+ tclStubsPtr->tcl_AppendResult(interp, "Error loading ", packageName,
+ " (requested version ", version, ", actual version ",
+ actualVersion, "): ", errMsg, NULL);
return NULL;
}
-
+
/*
* Local Variables:
* mode: c
diff --git a/generic/tclTrace.c b/generic/tclTrace.c
index 519f201..0f297a4 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/tclUtil.c b/generic/tclUtil.c
index 13e54ec..27e2474 100644
--- a/generic/tclUtil.c
+++ b/generic/tclUtil.c
@@ -167,7 +167,7 @@ const Tcl_ObjType tclEndOffsetType = {
* separating whitespace, or a string terminator. It is just another
* character in a list element.
*
- * The interpretaton of a formatted substring as a list element follows rules
+ * The interpretation of a formatted substring as a list element follows rules
* similar to the parsing of the words of a command in a Tcl script. Backslash
* substitution plays a key role, and is defined exactly as it is in command
* parsing. The same routine, TclParseBackslash() is used in both command
@@ -179,7 +179,7 @@ const Tcl_ObjType tclEndOffsetType = {
* Backslash substitution replaces an "escape sequence" of one or more
* characters starting with
* \u005c \ BACKSLASH
- * with a single character. The one character escape sequent case happens only
+ * with a single character. The one character escape sequence case happens only
* when BACKSLASH is the last character in the string. In all other cases, the
* escape sequence is at least two characters long.
*
@@ -2927,14 +2927,16 @@ TclDStringToObj(
{
Tcl_Obj *result;
- if (dsPtr->length == 0) {
- TclNewObj(result);
- } else if (dsPtr->string == dsPtr->staticSpace) {
- /*
- * Static buffer, so must copy.
- */
-
- TclNewStringObj(result, dsPtr->string, dsPtr->length);
+ if (dsPtr->string == dsPtr->staticSpace) {
+ if (dsPtr->length == 0) {
+ TclNewObj(result);
+ } else {
+ /*
+ * Static buffer, so must copy.
+ */
+
+ TclNewStringObj(result, dsPtr->string, dsPtr->length);
+ }
} else {
/*
* Dynamic buffer, so transfer ownership and reset.
diff --git a/generic/tclVar.c b/generic/tclVar.c
index 1c01e41..2d1479d 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -47,6 +47,13 @@ static inline void CleanupVar(Var *varPtr, Var *arrayPtr);
#define VarHashGetValue(hPtr) \
((Var *) ((char *)hPtr - TclOffset(VarInHash, entry)))
+/*
+ * NOTE: VarHashCreateVar increments the recount of its key argument.
+ * All callers that will call Tcl_DecrRefCount on that argument must
+ * call Tcl_IncrRefCount on it before passing it in. This requirement
+ * can bubble up to callers of callers .... etc.
+ */
+
static inline Var *
VarHashCreateVar(
TclVarHashTable *tablePtr,
@@ -383,11 +390,12 @@ TclLookupVar(
* address of array variable. Otherwise this
* is set to NULL. */
{
- Tcl_Obj *part1Ptr;
Var *varPtr;
+ Tcl_Obj *part1Ptr = Tcl_NewStringObj(part1, -1);
- part1Ptr = Tcl_NewStringObj(part1, -1);
- Tcl_IncrRefCount(part1Ptr);
+ if (createPart1) {
+ Tcl_IncrRefCount(part1Ptr);
+ }
varPtr = TclObjLookupVar(interp, part1Ptr, part2, flags, msg,
createPart1, createPart2, arrayPtrPtr);
@@ -432,6 +440,8 @@ TclLookupVar(
* are 1. The object part1Ptr is converted to one of localVarNameType,
* tclNsVarNameType or tclParsedVarNameType and caches as much of the
* lookup as it can.
+ * When createPart1 is 1, callers must IncrRefCount part1Ptr if they
+ * plan to DecrRefCount it.
*
*----------------------------------------------------------------------
*/
@@ -460,14 +470,11 @@ TclObjLookupVar(
* address of array variable. Otherwise this
* is set to NULL. */
{
- Tcl_Obj *part2Ptr;
+ Tcl_Obj *part2Ptr = NULL;
Var *resPtr;
if (part2) {
part2Ptr = Tcl_NewStringObj(part2, -1);
- Tcl_IncrRefCount(part2Ptr);
- } else {
- part2Ptr = NULL;
}
resPtr = TclObjLookupVarEx(interp, part1Ptr, part2Ptr,
@@ -847,6 +854,7 @@ TclObjLookupVarEx(
*
* Side effects:
* A new hashtable entry may be created if create is 1.
+ * Callers must Incr varNamePtr if they plan to Decr it if create is 1.
*
*----------------------------------------------------------------------
*/
@@ -1314,15 +1322,10 @@ Tcl_GetVar2Ex(
int flags) /* OR-ed combination of TCL_GLOBAL_ONLY, and
* TCL_LEAVE_ERR_MSG bits. */
{
- Tcl_Obj *part1Ptr, *part2Ptr, *resPtr;
+ Tcl_Obj *resPtr, *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;
}
resPtr = Tcl_ObjGetVar2(interp, part1Ptr, part2Ptr, flags);
@@ -1618,27 +1621,9 @@ Tcl_SetVar2(
* TCL_APPEND_VALUE, TCL_LIST_ELEMENT, or
* TCL_LEAVE_ERR_MSG. */
{
- Tcl_Obj *valuePtr, *part1Ptr, *part2Ptr;
- Tcl_Obj *varValuePtr;
-
- part1Ptr = Tcl_NewStringObj(part1, -1);
- Tcl_IncrRefCount(part1Ptr);
- if (part2 != NULL) {
- part2Ptr = Tcl_NewStringObj(part2, -1);
- Tcl_IncrRefCount(part2Ptr);
- } else {
- part2Ptr = NULL;
- }
- valuePtr = Tcl_NewStringObj(newValue, -1);
- Tcl_IncrRefCount(valuePtr);
+ Tcl_Obj *varValuePtr = Tcl_SetVar2Ex(interp, part1, part2,
+ Tcl_NewStringObj(newValue, -1), flags);
- varValuePtr = Tcl_ObjSetVar2(interp, part1Ptr, part2Ptr, valuePtr, flags);
-
- Tcl_DecrRefCount(part1Ptr);
- if (part2Ptr != NULL) {
- Tcl_DecrRefCount(part2Ptr);
- }
- Tcl_DecrRefCount(valuePtr);
if (varValuePtr == NULL) {
return NULL;
}
@@ -1697,15 +1682,12 @@ Tcl_SetVar2Ex(
* TCL_APPEND_VALUE, TCL_LIST_ELEMENT or
* TCL_LEAVE_ERR_MSG. */
{
- Tcl_Obj *part1Ptr, *part2Ptr, *resPtr;
+ Tcl_Obj *resPtr, *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;
}
resPtr = Tcl_ObjSetVar2(interp, part1Ptr, part2Ptr, newValuePtr, flags);
@@ -1738,6 +1720,7 @@ Tcl_SetVar2Ex(
* Side effects:
* 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.
*
*----------------------------------------------------------------------
*/
@@ -2027,6 +2010,7 @@ TclPtrSetVar(
* variable is created. The ref count for the returned object is _not_
* 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.
*
*----------------------------------------------------------------------
*/
@@ -2052,8 +2036,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,
@@ -2109,8 +2093,7 @@ TclPtrIncrObjVar(
* variable, or -1. Only used when part1Ptr is
* NULL. */
{
- register Tcl_Obj *varValuePtr, *newValuePtr = NULL;
- int duplicated, code;
+ register Tcl_Obj *varValuePtr;
if (TclIsVarInHash(varPtr)) {
VarHashRefCount(varPtr)++;
@@ -2124,19 +2107,33 @@ TclPtrIncrObjVar(
varValuePtr = Tcl_NewIntObj(0);
}
if (Tcl_IsShared(varValuePtr)) {
- duplicated = 1;
+ /* Copy on write */
varValuePtr = Tcl_DuplicateObj(varValuePtr);
+
+ if (TCL_OK == TclIncrObj(interp, varValuePtr, incrPtr)) {
+ return TclPtrSetVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr,
+ varValuePtr, flags, index);
+ } else {
+ Tcl_DecrRefCount(varValuePtr);
+ return NULL;
+ }
} else {
- duplicated = 0;
- }
- code = TclIncrObj(interp, varValuePtr, incrPtr);
- if (code == TCL_OK) {
- newValuePtr = TclPtrSetVar(interp, varPtr, arrayPtr, part1Ptr,
- part2Ptr, varValuePtr, flags, index);
- } else if (duplicated) {
- Tcl_DecrRefCount(varValuePtr);
+ /* Unshared - can Incr in place */
+ if (TCL_OK == TclIncrObj(interp, varValuePtr, incrPtr)) {
+
+ /*
+ * This seems dumb to write the incremeted value into the var
+ * after we just adjusted the value in place, but the spec for
+ * [incr] requires that write traces fire, and making this call
+ * is the way to make that happen.
+ */
+
+ return TclPtrSetVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr,
+ varValuePtr, flags, index);
+ } else {
+ return NULL;
+ }
}
- return newValuePtr;
}
/*
@@ -2219,13 +2216,10 @@ Tcl_UnsetVar2(
* TCL_LEAVE_ERR_MSG. */
{
int result;
- Tcl_Obj *part1Ptr, *part2Ptr = NULL;
+ 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);
}
/*
@@ -2841,6 +2835,7 @@ Tcl_LappendObjCmd(
*
* Side effects:
* A variable will be created if one does not already exist.
+ * Callers must Incr arrayNameObj if they pland to Decr it.
*
*----------------------------------------------------------------------
*/
@@ -4222,16 +4217,16 @@ TclInitArrayCmd(
Tcl_Interp *interp) /* Current interpreter. */
{
static const EnsembleImplMap arrayImplMap[] = {
- {"anymore", ArrayAnyMoreCmd, NULL, NULL, NULL, 0},
- {"donesearch", ArrayDoneSearchCmd, NULL, NULL, NULL, 0},
+ {"anymore", ArrayAnyMoreCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
+ {"donesearch", ArrayDoneSearchCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
{"exists", ArrayExistsCmd, TclCompileArrayExistsCmd, NULL, NULL, 0},
- {"get", ArrayGetCmd, NULL, NULL, NULL, 0},
- {"names", ArrayNamesCmd, NULL, NULL, NULL, 0},
- {"nextelement", ArrayNextElementCmd, NULL, NULL, NULL, 0},
+ {"get", ArrayGetCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
+ {"names", ArrayNamesCmd, TclCompileBasic1To3ArgCmd, NULL, NULL, 0},
+ {"nextelement", ArrayNextElementCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
{"set", ArraySetCmd, TclCompileArraySetCmd, NULL, NULL, 0},
- {"size", ArraySizeCmd, NULL, NULL, NULL, 0},
- {"startsearch", ArrayStartSearchCmd, NULL, NULL, NULL, 0},
- {"statistics", ArrayStatsCmd, NULL, NULL, NULL, 0},
+ {"size", ArraySizeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"startsearch", ArrayStartSearchCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"statistics", ArrayStatsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"unset", ArrayUnsetCmd, TclCompileArrayUnsetCmd, NULL, NULL, 0},
{NULL, NULL, NULL, NULL, NULL, 0}
};
@@ -4255,6 +4250,8 @@ TclInitArrayCmd(
* The variable given by myName is linked to the variable in framePtr
* given by otherP1 and otherP2, so that references to myName are
* redirected to the other variable like a symbolic link.
+ * Callers must Incr myNamePtr if they plan to Decr it.
+ * Callers must Incr otherP1Ptr if they plan to Decr it.
*
*----------------------------------------------------------------------
*/
@@ -4363,14 +4360,12 @@ TclPtrMakeUpvar(
int index) /* If the variable to be linked is an indexed
* scalar, this is its index. Otherwise, -1 */
{
- Tcl_Obj *myNamePtr;
+ Tcl_Obj *myNamePtr = NULL;
int result;
if (myName) {
myNamePtr = Tcl_NewStringObj(myName, -1);
Tcl_IncrRefCount(myNamePtr);
- } else {
- myNamePtr = NULL;
}
result = TclPtrObjMakeUpvar(interp, otherPtr, myNamePtr, myFlags, index);
if (myNamePtr) {
@@ -4379,6 +4374,8 @@ TclPtrMakeUpvar(
return result;
}
+/* Callers must Incr myNamePtr if they plan to Decr it. */
+
int
TclPtrObjMakeUpvar(
Tcl_Interp *interp, /* Interpreter containing variables. Used for
@@ -5242,8 +5239,6 @@ TclDeleteNamespaceVars(
for (varPtr = VarHashFirstVar(tablePtr, &search); varPtr != NULL;
varPtr = VarHashFirstVar(tablePtr, &search)) {
Tcl_Obj *objPtr = Tcl_NewObj();
-
- Tcl_IncrRefCount(objPtr);
VarHashRefCount(varPtr)++; /* Make sure we get to remove from
* hash. */
Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, objPtr);
@@ -5507,15 +5502,10 @@ TclVarErrMsg(
* e.g. "read", "set", or "unset". */
const char *reason) /* String describing why operation failed. */
{
- Tcl_Obj *part1Ptr = NULL, *part2Ptr = NULL;
+ 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 {
- part2 = NULL;
}
TclObjVarErrMsg(interp, part1Ptr, part2Ptr, operation, reason, -1);
@@ -5788,7 +5778,6 @@ Tcl_FindNamespaceVar(
Tcl_Obj *namePtr = Tcl_NewStringObj(name, -1);
Tcl_Var var;
- Tcl_IncrRefCount(namePtr);
var = ObjFindNamespaceVar(interp, namePtr, contextNsPtr, flags);
Tcl_DecrRefCount(namePtr);
return var;
@@ -5883,7 +5872,6 @@ ObjFindNamespaceVar(
varPtr = NULL;
if (simpleName != name) {
simpleNamePtr = Tcl_NewStringObj(simpleName, -1);
- Tcl_IncrRefCount(simpleNamePtr);
} else {
simpleNamePtr = namePtr;
}
diff --git a/generic/tclZlib.c b/generic/tclZlib.c
index 9c1176e..47091de 100644
--- a/generic/tclZlib.c
+++ b/generic/tclZlib.c
@@ -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 49a2c61..e86257e 100644
--- a/library/auto.tcl
+++ b/library/auto.tcl
@@ -27,7 +27,7 @@ proc auto_reset {} {
if {$fqcn eq ""} {
continue
}
- rename $fqcn ""
+ rename $fqcn {}
}
}
unset -nocomplain auto_execs auto_index ::tcl::auto_oldpath
@@ -54,16 +54,14 @@ proc auto_reset {} {
proc tcl_findLibrary {basename version patch initScript enVarName varName} {
upvar #0 $varName the_library
- global auto_path
- global env
- global tcl_platform
+ global auto_path env tcl_platform
- set dirs [list]
- set errors ""
+ set dirs {}
+ set errors {}
# The C application may have hardwired a path, which we honor
- if {[info exists the_library] && ($the_library ne "")} {
+ if {[info exists the_library] && $the_library ne ""} {
lappend dirs $the_library
} else {
# Do the canonical search
@@ -88,10 +86,8 @@ proc tcl_findLibrary {basename version patch initScript enVarName varName} {
# auto_path that is not relative to the core library or binary paths.
foreach d $auto_path {
lappend dirs [file join $d $basename$version]
- if {
- ($tcl_platform(platform) eq "unix")
- && ($tcl_platform(os) eq "Darwin")
- } {
+ 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]
}
@@ -138,7 +134,7 @@ proc tcl_findLibrary {basename version patch initScript enVarName varName} {
if {[info exists seen($norm)]} {
continue
}
- set seen($norm) ""
+ set seen($norm) {}
lappend uniqdirs $i
}
set dirs $uniqdirs
@@ -223,17 +219,17 @@ proc auto_mkindex {dir args} {
auto_mkindex_parser::cleanup
set fid [open "tclIndex" w]
- chan puts -nonewline $fid $index
- chan close $fid
+ puts -nonewline $fid $index
+ close $fid
cd $oldDir
}
# Original version of auto_mkindex that just searches the source code for
# "proc" at the beginning of the line.
-proc auto_mkindex_old {a_dir args} {
+proc auto_mkindex_old {dir args} {
set oldDir [pwd]
- cd $a_dir
+ cd $dir
set dir [pwd]
append index "# Tcl autoload index file, version 2.0\n"
append index "# This file is generated by the \"auto_mkindex\" command\n"
@@ -249,17 +245,17 @@ proc auto_mkindex_old {a_dir args} {
set f ""
set error [catch {
set f [open $file]
- while {[chan gets $f line] >= 0} {
+ while {[gets $f line] >= 0} {
if {[regexp {^proc[ ]+([^ ]*)} $line match procName]} {
set procName [lindex [auto_qualify $procName "::"] 0]
append index "set [list auto_index($procName)]"
append index " \[list source \[file join \$dir [list $file]\]\]\n"
}
}
- chan close $f
+ close $f
} msg opts]
if {$error} {
- catch {chan close $f}
+ catch {close $f}
cd $oldDir
return -options $opts $msg
}
@@ -267,12 +263,12 @@ proc auto_mkindex_old {a_dir args} {
set f ""
set error [catch {
set f [open tclIndex w]
- chan puts -nonewline $f $index
- chan close $f
+ puts -nonewline $f $index
+ close $f
cd $oldDir
} msg opts]
if {$error} {
- catch {chan close $f}
+ catch {close $f}
cd $oldDir
error $msg $info $code
return -options $opts $msg
@@ -497,10 +493,10 @@ proc auto_mkindex_parser::commandInit {name arglist body} {
proc auto_mkindex_parser::fullname {name} {
variable contextStack
- if {![string match "::*" $name]} {
+ if {![string match ::* $name]} {
foreach ns $contextStack {
set name "${ns}::$name"
- if {[string match "::*" $name]} {
+ if {[string match ::* $name]} {
break
}
}
diff --git a/library/http/http.tcl b/library/http/http.tcl
index 00140d7..9441acc 100644
--- a/library/http/http.tcl
+++ b/library/http/http.tcl
@@ -11,7 +11,7 @@
package require Tcl 8.6
# Keep this in sync with pkgIndex.tcl and with the install directories in
# Makefiles
-package provide http 2.8.5
+package provide http 2.8.6
namespace eval http {
# Allow resourcing to not clobber existing data
@@ -535,11 +535,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
@@ -595,10 +594,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} {
- chan event $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]} {
@@ -614,13 +618,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
chan configure $sock -translation {auto crlf} -buffersize $state(-blocksize)
@@ -751,35 +771,17 @@ proc http::geturl {url args} {
chan event $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:
@@ -863,7 +865,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 [set token]
upvar 0 $token state
set err "due to unexpected EOF"
@@ -871,10 +873,10 @@ proc http::Connect {token} {
[chan eof $state(sock)] ||
([set err [chan configure $state(sock) -error]] ne "")
} {
- Finish $token "connect failed $err" 1
+ Finish $token "connect failed $err"
} else {
- set state(status) connect
chan event $state(sock) writable {}
+ ::http::Connected $token $proto $phost $srvurl
}
return
}
@@ -979,7 +981,7 @@ proc http::Event {sock token} {
} elseif {$n == 0} {
# We have now read all headers
# We ignore HTTP/1.1 100 Continue returns. RFC2616 sec 8.2.3
- if {($state(http) == "") || ([lindex $state(http) 1] == 100)} {
+ if {($state(http) == "") || ([regexp {^\S+\s(\d+)} $state(http) {} x] && $x == 100)} {
return
}
@@ -1379,7 +1381,7 @@ proc http::mapReply {string} {
}
set converted [string map $formMap $string]
if {[string match "*\[\u0100-\uffff\]*" $converted]} {
- regexp {[\u0100-\uffff]} $converted badChar
+ regexp "\[\u0100-\uffff\]" $converted badChar
# Return this error message for maximum compatability... :^/
return -code error \
"can't read \"formMap($badChar)\": no such element in array"
diff --git a/library/http/pkgIndex.tcl b/library/http/pkgIndex.tcl
index 303d3bd..a8641e1 100644
--- a/library/http/pkgIndex.tcl
+++ b/library/http/pkgIndex.tcl
@@ -1,2 +1,2 @@
if {![package vsatisfies [package provide Tcl] 8.6]} {return}
-package ifneeded http 2.8.5 [list tclPkgSetup $dir http 2.8.5 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}]
+package ifneeded http 2.8.6 [list tclPkgSetup $dir http 2.8.6 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}]
diff --git a/library/init.tcl b/library/init.tcl
index 7526002..bedc06e 100644
--- a/library/init.tcl
+++ b/library/init.tcl
@@ -12,7 +12,8 @@
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-if {[info commands package] eq ""} {
+# 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]"
}
package require -exact Tcl 8.6.0
@@ -84,7 +85,7 @@ namespace eval tcl {
foreach arg $args {
# This will handle forcing the numeric value without
# ruining the internal type of a numeric object
- if {[catch {expr { double ($arg) }} err]} {
+ if {[catch {expr {double($arg)}} err]} {
return -code error $err
}
if {$arg < $val} {set val $arg}
@@ -100,7 +101,7 @@ namespace eval tcl {
foreach arg $args {
# This will handle forcing the numeric value without
# ruining the internal type of a numeric object
- if {[catch {expr { double ($arg) }} err]} {
+ if {[catch {expr {double($arg)}} err]} {
return -code error $err
}
if {$arg > $val} {set val $arg}
@@ -137,7 +138,6 @@ if {(![interp issafe]) && ($tcl_platform(platform) eq "windows")} {
trace add variable env($u) write \
[namespace code [list EnvTraceProc $p]]
}
- default {}
}
}
}
@@ -155,13 +155,14 @@ if {(![interp issafe]) && ($tcl_platform(platform) eq "windows")} {
# Setup the unknown package handler
+
if {[interp issafe]} {
package unknown {::tcl::tm::UnknownHandler ::tclPkgUnknown}
} 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 {
@@ -172,7 +173,7 @@ if {[interp issafe]} {
namespace eval ::tcl::clock [list variable TclLibDir $::tcl_library]
- proc clock {args} {
+ proc clock args {
namespace eval ::tcl::clock [list namespace ensemble create -command \
[uplevel 1 [list namespace origin [lindex [info level 0] 0]]] \
-subcommands {
@@ -182,7 +183,7 @@ if {[interp issafe]} {
# Auto-loading stubs for 'clock.tcl'
foreach cmd {add format scan} {
- proc ::tcl::clock::$cmd {args} {
+ proc ::tcl::clock::$cmd args {
variable TclLibDir
source -encoding utf-8 [file join $TclLibDir clock.tcl]
return [uplevel 1 [info level 0]]
@@ -232,11 +233,10 @@ if {[namespace which -command tclLog] eq ""} {
# args - A list whose elements are the words of the original
# command, including the command name.
-proc unknown {args} {
+proc unknown args {
variable ::tcl::UnknownPending
global auto_noexec auto_noload env tcl_interactive errorInfo errorCode
-
if {[info exists errorInfo]} {
set savedErrorInfo $errorInfo
}
@@ -267,9 +267,9 @@ proc unknown {args} {
}
if {$msg} {
if {[info exists savedErrorCode]} {
- set errorCode $savedErrorCode
+ set ::errorCode $savedErrorCode
} else {
- unset -nocomplain errorCode
+ unset -nocomplain ::errorCode
}
if {[info exists savedErrorInfo]} {
set errorInfo $savedErrorInfo
@@ -283,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]
@@ -301,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.
@@ -316,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
@@ -336,8 +336,8 @@ proc unknown {args} {
}
}
- if {([info level] == 1) && ([info script] eq "") &&
- [info exists tcl_interactive] && $tcl_interactive} {
+ if {([info level] == 1) && ([info script] eq "")
+ && [info exists tcl_interactive] && $tcl_interactive} {
if {![info exists auto_noexec]} {
set new [auto_execok $name]
if {$new ne ""} {
@@ -354,9 +354,9 @@ proc unknown {args} {
}
if {$name eq "!!"} {
set newcmd [history event]
- } elseif {[regexp {^!(.+)$} $name ___ event]} {
+ } elseif {[regexp {^!(.+)$} $name -> event]} {
set newcmd [history event $event]
- } elseif {[regexp {^\^([^^]*)\^([^^]*)\^?$} $name ___ old new]} {
+ } elseif {[regexp {^\^([^^]*)\^([^^]*)\^?$} $name -> old new]} {
set newcmd [history event -1]
catch {regsub -all -- $old $newcmd $new newcmd}
}
@@ -538,7 +538,7 @@ proc auto_qualify {cmd namespace} {
# count separators and clean them up
# (making sure that foo:::::bar will be treated as foo::bar)
- set n [regsub -all "::+" $cmd :: cmd]
+ set n [regsub -all {::+} $cmd :: cmd]
# Ignore namespace if the name starts with ::
# Handle special case of only leading ::
@@ -547,7 +547,7 @@ proc auto_qualify {cmd namespace} {
# with the following form :
# (inputCmd, inputNameSpace) -> output
- if {[string match "::*" $cmd]} {
+ if {[string match ::* $cmd]} {
if {$n > 1} {
# (::foo::bar , *) -> ::foo::bar
return [list $cmd]
@@ -631,7 +631,7 @@ if {$tcl_platform(platform) eq "windows"} {
# may be in the Path or PATH environment variables, and path
# components are separated with semicolons, not colons as under Unix.
#
-proc auto_execok {name} {
+proc auto_execok name {
global auto_execs env tcl_platform
if {[info exists auto_execs($name)]} {
@@ -649,7 +649,7 @@ proc auto_execok {name} {
# Add an initial ; to have the {} extension check first.
set execExtensions [split ";$env(PATHEXT)" ";"]
} else {
- set execExtensions [list "" .com .exe .bat .cmd]
+ set execExtensions [list {} .com .exe .bat .cmd]
}
if {[string tolower $name] in $shellBuiltins} {
@@ -666,7 +666,7 @@ proc auto_execok {name} {
if {[llength [file split $name]] != 1} {
foreach ext $execExtensions {
set file ${name}${ext}
- if {[file exists $file] && (![file isdirectory $file])} {
+ if {[file exists $file] && ![file isdirectory $file]} {
return [set auto_execs($name) [list $file]]
}
}
@@ -692,14 +692,14 @@ proc auto_execok {name} {
foreach ext $execExtensions {
unset -nocomplain checked
- foreach dir [split $path ";"] {
+ foreach dir [split $path {;}] {
# Skip already checked directories
if {[info exists checked($dir)] || ($dir eq "")} {
continue
}
- set checked($dir) ""
+ set checked($dir) {}
set file [file join $dir ${name}${ext}]
- if {[file exists $file] && (![file isdirectory $file])} {
+ if {[file exists $file] && ![file isdirectory $file]} {
return [set auto_execs($name) [list $file]]
}
}
@@ -710,7 +710,7 @@ proc auto_execok {name} {
} else {
# Unix version.
#
-proc auto_execok {name} {
+proc auto_execok name {
global auto_execs env
if {[info exists auto_execs($name)]} {
@@ -718,7 +718,7 @@ proc auto_execok {name} {
}
set auto_execs($name) ""
if {[llength [file split $name]] != 1} {
- if {[file executable $name] && (![file isdirectory $name])} {
+ if {[file executable $name] && ![file isdirectory $name]} {
set auto_execs($name) [list $name]
}
return $auto_execs($name)
@@ -728,7 +728,7 @@ proc auto_execok {name} {
set dir .
}
set file [file join $dir $name]
- if {[file executable $file] && (![file isdirectory $file])} {
+ if {[file executable $file] && ![file isdirectory $file]} {
set auto_execs($name) [list $file]
return $auto_execs($name)
}
@@ -789,7 +789,7 @@ proc tcl::CopyDirectory {action src dest} {
lappend existing {*}[glob -nocomplain -directory $dest \
-type hidden * .*]
foreach s $existing {
- if {[file tail $s] ni ". .."} {
+ if {[file tail $s] ni {. ..}} {
return -code error "error $action \"$src\" to\
\"$dest\": file already exists"
}
@@ -817,37 +817,9 @@ proc tcl::CopyDirectory {action src dest} {
[glob -nocomplain -directory $src -types hidden *]]
foreach s [lsort -unique $filelist] {
- if {[file tail $s] ni ". .."} {
+ 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/msgcat/msgcat.tcl b/library/msgcat/msgcat.tcl
index 5ebb642..112507a 100644
--- a/library/msgcat/msgcat.tcl
+++ b/library/msgcat/msgcat.tcl
@@ -238,7 +238,7 @@ proc msgcat::mclocale {args} {
could be path to unsafe code."
}
set Locale [string tolower $newLocale]
- set Loclist [list]
+ set Loclist {}
set word ""
foreach part [split $Locale _] {
set word [string trim "${word}_${part}" _]
@@ -246,7 +246,7 @@ proc msgcat::mclocale {args} {
set Loclist [linsert $Loclist 0 $word]
}
}
- lappend Loclist ""
+ lappend Loclist {}
set Locale [lindex $Loclist 0]
}
return $Locale
@@ -465,7 +465,7 @@ proc msgcat::mcmax {args} {
foreach string $args {
set translated [uplevel 1 [list [namespace origin mc] $string]]
set len [string length $translated]
- if {$len > $max} {
+ if {$len>$max} {
set max $len
}
}
@@ -488,7 +488,7 @@ proc msgcat::ConvertLocale {value} {
# $ # Match all the way to the end
# } $value -> language _ territory _ codeset _ modifier
if {![regexp {^([^_.@]+)(_([^.@]*))?([.]([^@]*))?(@(.*))?$} $value \
- ___ language _ territory _ codeset _ modifier]} {
+ -> language _ territory _ codeset _ modifier]} {
return -code error "invalid locale '$value': empty language part"
}
set ret $language
@@ -520,7 +520,7 @@ proc msgcat::Init {} {
#
# On Darwin, fallback to current CFLocale identifier if available.
#
- if {[info exists ::tcl::mac::locale] && ($::tcl::mac::locale ne "")} {
+ if {[info exists ::tcl::mac::locale] && $::tcl::mac::locale ne ""} {
if {![catch {
mclocale [ConvertLocale $::tcl::mac::locale]
}]} {
diff --git a/library/package.tcl b/library/package.tcl
index 296553c..52daa0e 100644
--- a/library/package.tcl
+++ b/library/package.tcl
@@ -125,7 +125,6 @@ proc pkg_mkIndex {args} {
}
}
- set fileList [list]
set dir [lindex $args $idx]
set patternList [lrange $args [expr {$idx + 1}] end]
if {![llength $patternList]} {
@@ -395,13 +394,13 @@ proc pkg_mkIndex {args} {
append index "# full path name of this file's directory.\n"
foreach pkg [lsort [array names files]] {
- set cmd [list]
+ set cmd {}
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 {
if {$direct} {
- set procs ""
+ set procs {}
}
lappend cmd "-$type" [list $file $procs]
}
@@ -410,8 +409,8 @@ proc pkg_mkIndex {args} {
}
set f [open [file join $dir pkgIndex.tcl] w]
- chan puts $f $index
- chan close $f
+ puts $f $index
+ close $f
}
# tclPkgSetup --
@@ -543,7 +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)]) && ($dir ni $use_path)} {
+ if {![info exists tclSeenPath($dir)] && ($dir ni $use_path)} {
lappend use_path $dir
}
}
@@ -626,7 +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)]) && ($dir ni $use_path)} {
+ if {![info exists tclSeenPath($dir)] && ($dir ni $use_path)} {
lappend use_path $dir
}
}
@@ -678,7 +677,7 @@ proc ::tcl::Pkg::Create {args} {
}
# Initialize parameters
- array set opts {-name "" -version "" -source "" -load ""}
+ array set opts {-name {} -version {} -source {} -load {}}
# process parameters
for {set i 0} {$i < $len} {incr i} {
@@ -720,16 +719,15 @@ proc ::tcl::Pkg::Create {args} {
# OK, now everything is good. Generate the package ifneeded statment.
set cmdline "package ifneeded $opts(-name) $opts(-version) "
- set cmdList [list]
- set lazyFileList [list]
+ set cmdList {}
+ set lazyFileList {}
# Handle -load and -source specs
foreach key {load source} {
foreach filespec $opts(-$key) {
- lassign "" filename proclist
lassign $filespec filename proclist
-
- if {![llength $proclist]} {
+
+ if { [llength $proclist] == 0 } {
set cmd "\[list $key \[file join \$dir [list $filename]\]\]"
lappend cmdList $cmd
} else {
@@ -746,4 +744,4 @@ proc ::tcl::Pkg::Create {args} {
return $cmdline
}
-interp alias "" ::pkg::create "" ::tcl::Pkg::Create
+interp alias {} ::pkg::create {} ::tcl::Pkg::Create
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 71b9b7e..d9b1aee 100644
--- a/library/platform/platform.tcl
+++ b/library/platform/platform.tcl
@@ -259,7 +259,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
lassign [split $v "."] major minor
set v glibc${major}.${minor}
return 1
@@ -372,7 +372,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 532ccd6..d6e6487 100644
--- a/library/tcltest/tcltest.tcl
+++ b/library/tcltest/tcltest.tcl
@@ -156,15 +156,15 @@ namespace eval tcltest {
# rather than go through command interfaces.
#
proc ArrayDefault {varName value} {
- variable [set varName]
- if {[array exists [set varName]]} {
+ variable $varName
+ if {[array exists $varName]} {
return
}
- if {[info exists [set varName]]} {
+ if {[info exists $varName]} {
# Pre-initialized value is a scalar: destroy it!
- unset -- [set varName]
+ unset $varName
}
- array set [set varName] $value
+ array set $varName $value
}
# save the original environment so that it can be restored later
@@ -177,7 +177,7 @@ namespace eval tcltest {
# createdNewFiles will store test files as indices and the list of
# files (that should not have been) left behind by the test files
# as values.
- ArrayDefault createdNewFiles ""
+ ArrayDefault createdNewFiles {}
# initialize skippedBecause array to keep track of constraints that
# kept tests from running; a constraint name of "userSpecifiedSkip"
@@ -186,12 +186,12 @@ namespace eval tcltest {
# the test didn't match the argument given to the -match flag; both
# of these constraints are counted only if tcltest::debug is set to
# true.
- ArrayDefault skippedBecause ""
+ ArrayDefault skippedBecause {}
# initialize the testConstraints array to keep track of valid
# predefined constraints (see the explanation for the
# InitConstraints proc for more details).
- ArrayDefault testConstraints ""
+ ArrayDefault testConstraints {}
##### Initialize internal variables of tcltest, but only if the caller
# has not already pre-initialized them. This is done to support
@@ -199,18 +199,18 @@ namespace eval tcltest {
# rather than go through command interfaces.
#
proc Default {varName value {verify AcceptAll}} {
- variable [set varName]
- if {![info exists [set varName]]} {
- variable [set varName] [$verify $value]
+ variable $varName
+ if {![info exists $varName]} {
+ variable $varName [$verify $value]
} else {
- variable [set varName] [$verify [set [set varName]]]
+ variable $varName [$verify [set $varName]]
}
}
# Save any arguments that we might want to pass through to other
# programs. This is used by the -args flag.
# FINDUSER
- Default parameters ""
+ Default parameters {}
# Count the number of files tested (0 if runAllTests wasn't called).
# runAllTests will set testSingleFile to false, so stats will
@@ -221,7 +221,7 @@ namespace eval tcltest {
Default numTestFiles 0 AcceptInteger
Default testSingleFile true AcceptBoolean
Default currentFailure false AcceptBoolean
- Default failFiles "" AcceptList
+ Default failFiles {} AcceptList
# Tests should remove all files they create. The test suite will
# check the current working dir for files created by the tests.
@@ -231,8 +231,8 @@ namespace eval tcltest {
#
# Note that $filesExisted lists only those files that exist in
# the original [temporaryDirectory].
- Default filesMade "" AcceptList
- Default filesExisted "" AcceptList
+ Default filesMade {} AcceptList
+ Default filesExisted {} AcceptList
proc FillFilesExisted {} {
variable filesExisted
@@ -242,20 +242,20 @@ namespace eval tcltest {
}
# After successful filling, turn this into a no-op.
- proc FillFilesExisted {args} {}
+ proc FillFilesExisted args {}
}
# Kept only for compatibility
- Default constraintsSpecified "" AcceptList
- trace add variable constraintsSpecified read \
- {set ::tcltest::constraintsSpecified [array names ::tcltest::testConstraints] ;# }
+ Default constraintsSpecified {} AcceptList
+ 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] ne ""} {
+ if {[info commands thread::id] ne {}} {
set mainThread [thread::id]
- } elseif {[info commands testthread] ne ""} {
+ } elseif {[info commands testthread] ne {}} {
set mainThread [testthread id]
}
@@ -264,7 +264,7 @@ namespace eval tcltest {
# change to that directory.
variable workingDirectory
trace add variable workingDirectory write \
- [namespace code {cd $workingDirectory ;#}]
+ [namespace code {cd $workingDirectory ;#}]
Default workingDirectory [pwd] AcceptAbsolutePath
proc workingDirectory { {dir ""} } {
@@ -290,15 +290,15 @@ namespace eval tcltest {
}
# stdout and stderr buffers for use when we want to store them
- Default outData ""
- Default errData ""
+ Default outData {}
+ Default errData {}
# keep track of test level for nested test commands
variable testLevel 0
# the variables and procs that existed when saveState was called are
# stored in a variable of the same name
- Default saveState ""
+ Default saveState {}
# Internationalization support -- used in [SetIso8859_1_Locale] and
# [RestoreLocale]. Those commands are used in cmdIL.test.
@@ -334,12 +334,10 @@ namespace eval tcltest {
"windows" {
set isoLocale French
}
- default {}
}
}
- variable ChannelsWeOpened
- array set ChannelsWeOpened {}
+ variable ChannelsWeOpened; array set ChannelsWeOpened {}
# output goes to stdout by default
Default outputChannel stdout
proc outputChannel { {filename ""} } {
@@ -466,16 +464,13 @@ namespace eval tcltest {
##### Set up the configurable options
#
# The configurable options of the package
- variable Option
- array set Option ""
+ variable Option; array set Option {}
# Usage strings for those options
- variable Usage
- array set Usage ""
+ variable Usage; array set Usage {}
# Verification commands for those options
- variable Verify
- array set Verify ""
+ variable Verify; array set Verify {}
# Initialize the default values of the configurable options that are
# historically associated with an exported variable. If that variable
@@ -498,14 +493,14 @@ namespace eval tcltest {
set Option($option) $msg
}
if {[string length $varName]} {
- variable [set varName]
- if {[info exists [set varName]]} {
- if {[catch {$verify [set [set varName]]} msg]} {
+ variable $varName
+ if {[info exists $varName]} {
+ if {[catch {$verify [set $varName]} msg]} {
return -code error $msg
} else {
set Option($option) $msg
}
- unset -- [set varName]
+ unset $varName
}
namespace eval [namespace current] \
[list upvar 0 Option($option) $varName]
@@ -553,20 +548,21 @@ namespace eval tcltest {
proc EstablishAutoConfigureTraces {} {
variable OptionControlledVariables
foreach varName [concat $OptionControlledVariables Option] {
- variable [set varName]
- trace add variable [set varName] read [namespace code {ProcessCmdLineArgs ;#}]
+ variable $varName
+ trace add variable $varName read [namespace code {
+ ProcessCmdLineArgs ;#}]
}
}
proc RemoveAutoConfigureTraces {} {
variable OptionControlledVariables
foreach varName [concat $OptionControlledVariables Option] {
- variable [set varName]
- foreach pair [trace info variable [set varName]] {
+ variable $varName
+ foreach pair [trace info variable $varName] {
lassign $pair op cmd
- if {("read" eq $op) &&
- [string match "*ProcessCmdLineArgs*" $cmd]} {
- trace remove variable [set varName] $op $cmd
+ if {($op eq "read") &&
+ [string match *ProcessCmdLineArgs* $cmd]} {
+ trace remove variable $varName $op $cmd
}
}
}
@@ -574,7 +570,7 @@ namespace eval tcltest {
proc RemoveAutoConfigureTraces {} {}
}
- proc Configure {args} {
+ proc Configure args {
variable Option
variable Verify
set n [llength $args]
@@ -605,7 +601,7 @@ namespace eval tcltest {
return -code error "missing value for option $option"
}
}
- proc configure {args} {
+ proc configure args {
if {[llength $args] > 1} {
RemoveAutoConfigureTraces
}
@@ -619,7 +615,7 @@ namespace eval tcltest {
if {![regexp {^(pass|body|skip|start|error|line)$} $level]} {
# translate single characters abbreviations to expanded list
set level [string map {p pass b body s skip t start e error l line} \
- [split $level ""]]
+ [split $level {}]]
}
}
set valid [list]
@@ -694,7 +690,7 @@ namespace eval tcltest {
Internal debug level
} AcceptInteger debug
- proc SetSelectedConstraints {args} {
+ proc SetSelectedConstraints args {
variable Option
foreach c $Option(-constraints) {
testConstraint $c 1
@@ -704,10 +700,10 @@ namespace eval tcltest {
Do not skip the listed constraints listed in -constraints.
} AcceptList
trace add variable Option(-constraints) write \
- [namespace code {SetSelectedConstraints ;#}]
+ [namespace code {SetSelectedConstraints ;#}]
# Don't run only the "-constraint" specified tests by default
- proc ClearUnselectedConstraints {args} {
+ proc ClearUnselectedConstraints args {
variable Option
variable testConstraints
if {!$Option(-limitconstraints)} {return}
@@ -768,13 +764,13 @@ namespace eval tcltest {
[namespace code {normalizePath Option(-testdir) ;#}]
proc AcceptLoadFile { file } {
- if {"" eq $file} {return $file}
+ if {$file eq {}} {return $file}
set file [file join [temporaryDirectory] $file]
return [AcceptReadable $file]
}
proc ReadLoadScript {args} {
variable Option
- if {"" eq $Option(-loadfile)} {return}
+ if {$Option(-loadfile) eq {}} {return}
set tmp [open $Option(-loadfile) r]
loadScript [read $tmp]
close $tmp
@@ -785,7 +781,8 @@ namespace eval tcltest {
trace add variable Option(-loadfile) write [namespace code ReadLoadScript]
proc AcceptOutFile { file } {
- if {$file in "stderr stdout"} {return $file}
+ if {[string equal stderr $file]} {return $file}
+ if {[string equal stdout $file]} {return $file}
return [file join [temporaryDirectory] $file]
}
@@ -808,7 +805,7 @@ namespace eval tcltest {
interp eval $slave [package ifneeded tcltest $Version]
interp eval $slave "tcltest::configure {*}{$args}"
interp alias $slave ::tcltest::ReportToMaster \
- "" ::tcltest::ReportedFromSlave
+ {} ::tcltest::ReportedFromSlave
}
proc ReportedFromSlave {total passed skipped failed because newfiles} {
variable numTests
@@ -881,7 +878,7 @@ proc tcltest::DebugPArray {level arrayvar} {
variable debug
if {$debug >= $level} {
- catch {upvar 1 $arrayvar [set arrayvar]}
+ catch {upvar 1 $arrayvar $arrayvar}
parray $arrayvar
}
return
@@ -965,8 +962,7 @@ proc tcltest::testConstraint {constraint {value ""}} {
if {[catch {expr {$value && $value}} msg]} {
return -code error $msg
}
- if {[limitConstraints] &&
- ($constraint ni $Option(-constraints))} {
+ if {[limitConstraints] && ($constraint ni $Option(-constraints))} {
set value 0
}
set testConstraints($constraint) $value
@@ -990,11 +986,7 @@ proc tcltest::interpreter { {interp ""} } {
if {[llength [info level 0]] == 1} {
return $tcltest
}
- if {"" eq $interp} {
- set tcltest ""
- } else {
- set tcltest $interp
- }
+ set tcltest $interp
}
#####################################################################
@@ -1059,7 +1051,7 @@ proc tcltest::PrintError {errorMsg} {
[expr {80 - $InitialMsgLen}]]]
puts [errorChannel] [string range $errorMsg 0 $beginningIndex]
- while {"end" ne $beginningIndex} {
+ while {$beginningIndex ne "end"} {
puts -nonewline [errorChannel] \
[string repeat " " $InitialMsgLen]
if {($endingIndex - $beginningIndex)
@@ -1112,7 +1104,7 @@ proc tcltest::PrintError {errorMsg} {
proc tcltest::SafeFetch {n1 n2 op} {
variable testConstraints
DebugPuts 3 "entering SafeFetch $n1 $n2 $op"
- if {"" eq $n2} {return}
+ if {$n2 eq {}} {return}
if {![info exists testConstraints($n2)]} {
if {[catch {testConstraint $n2 [eval [ConstraintInitializer $n2]]}]} {
testConstraint $n2 0
@@ -1182,13 +1174,13 @@ proc tcltest::DefineConstraintInitializers {} {
# constraints.
ConstraintInitializer unixOnly \
- {string equal $::tcl_platform(platform) "unix"}
+ {string equal $::tcl_platform(platform) unix}
ConstraintInitializer macOnly \
- {string equal $::tcl_platform(platform) "macintosh"}
+ {string equal $::tcl_platform(platform) macintosh}
ConstraintInitializer pcOnly \
- {string equal $::tcl_platform(platform) "windows"}
+ {string equal $::tcl_platform(platform) windows}
ConstraintInitializer winOnly \
- {string equal $::tcl_platform(platform) "windows"}
+ {string equal $::tcl_platform(platform) windows}
ConstraintInitializer unix {testConstraint unixOnly}
ConstraintInitializer mac {testConstraint macOnly}
@@ -1257,9 +1249,8 @@ proc tcltest::DefineConstraintInitializers {} {
# are running as root on Unix.
ConstraintInitializer root {expr \
- {("unix" eq $::tcl_platform(platform)) &&
- (("root" eq $::tcl_platform(user)) ||
- ("" eq $::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
@@ -1268,7 +1259,7 @@ proc tcltest::DefineConstraintInitializers {} {
ConstraintInitializer nonBlockFiles {
set code [expr {[catch {set f [open defs r]}]
|| [catch {chan configure $f -blocking off}]}]
- catch {chan close $f}
+ catch {close $f}
set code
}
@@ -1293,10 +1284,10 @@ proc tcltest::DefineConstraintInitializers {} {
ConstraintInitializer unixExecs {
set code 1
- if {"macintosh" eq $::tcl_platform(platform)} {
+ if {$::tcl_platform(platform) eq "macintosh"} {
set code 0
}
- if {"windows" eq $::tcl_platform(platform)} {
+ if {$::tcl_platform(platform) eq "windows"} {
if {[catch {
set file _tcl_test_remove_me.txt
makeFile {hello} $file
@@ -1400,7 +1391,7 @@ proc tcltest::Usage { {option ""} } {
append msg \n$line($opt)
append msg [string repeat " " [expr {$max - $length($opt)}]]
set u [string trim $usage($opt)]
- catch {append u " (default: \[[Configure $opt]\])"}
+ catch {append u " (default: \[[Configure $opt]])"}
regsub -all {\s*\n\s*} $u " " u
while {[string length $u] > $rest} {
set break [string wordstart $u $rest]
@@ -1414,7 +1405,7 @@ proc tcltest::Usage { {option ""} } {
append msg $u
}
return $msg\n
- } elseif {"-help" eq $option} {
+ } elseif {$option eq "-help"} {
return [list -help "" "Display this usage information."]
} else {
set type [lindex [info args $Verify($option)] 0]
@@ -1441,15 +1432,15 @@ proc tcltest::Usage { {option ""} } {
proc tcltest::ProcessFlags {flagArray} {
# Process -help first
if {"-help" in $flagArray} {
- PrintUsageInfo
+ PrintUsageInfo
exit 1
}
- if {![llength $flagArray]} {
- RemoveAutoConfigureTraces
+ if {[llength $flagArray] == 0} {
+ 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"
@@ -1572,7 +1563,7 @@ namespace eval tcltest::Replace {
proc tcltest::Replace::puts {args} {
variable [namespace parent]::outData
variable [namespace parent]::errData
- switch -- [llength $args] {
+ switch [llength $args] {
1 {
# Only the string to be printed is specified
append outData [lindex $args 0]\n
@@ -1581,7 +1572,7 @@ proc tcltest::Replace::puts {args} {
}
2 {
# Either -nonewline or channelId has been specified
- if {"-nonewline" eq [lindex $args 0]} {
+ if {[lindex $args 0] eq "-nonewline"} {
append outData [lindex $args end]
return
# return [Puts -nonewline [lindex $args end]]
@@ -1591,23 +1582,20 @@ proc tcltest::Replace::puts {args} {
}
}
3 {
- if {"-nonewline" eq [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]
set newline ""
}
}
- default {}
}
if {[info exists channel]} {
- if {($channel eq [[namespace parent]::outputChannel]) ||
- ($channel eq "stdout")} {
+ if {$channel in [list [[namespace parent]::outputChannel] stdout]} {
append outData [lindex $args end]$newline
return
- } elseif {($channel eq [[namespace parent]::errorChannel]) ||
- ($channel eq "stderr")} {
+ } elseif {$channel in [list [[namespace parent]::errorChannel] stderr]} {
append errData [lindex $args end]$newline
return
}
@@ -1641,8 +1629,8 @@ proc tcltest::Eval {script {ignoreOutput 1}} {
variable errData
DebugPuts 3 "[lindex [info level 0] 0] called"
if {!$ignoreOutput} {
- set outData ""
- set errData ""
+ set outData {}
+ set errData {}
rename ::puts [namespace current]::Replace::Puts
namespace eval :: [list namespace import [namespace origin Replace::puts]]
namespace import Replace::puts
@@ -1750,11 +1738,11 @@ proc tcltest::SubstArguments {argList} {
# separated strings as it throws away the whitespace which maybe
# important so we have to do it all by hand.
- set result ""
+ set result {}
set token ""
while {[string length $argList]} {
- # Look for the next word containing a quote: \" \{ \}
+ # Look for the next word containing a quote: " { }
if {[regexp -indices {[^ \t\n]*[\"\{\}]+[^ \t\n]*} \
$argList all]} {
# Get the text leading up to this word, but not including
@@ -1772,11 +1760,11 @@ proc tcltest::SubstArguments {argList} {
} else {
# Take everything up to the end of the argList.
set text $argList
- set word ""
- set argList [list]
+ set word {}
+ set argList {}
}
- if {$token ne ""} {
+ 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.
@@ -1791,11 +1779,11 @@ proc tcltest::SubstArguments {argList} {
set token $word
}
- if { ([catch {llength $token} length] == 0) && ($length == 1)} {
+ if { [catch {llength $token} length] == 0 && $length == 1} {
# The token is a valid list so add it to the result.
# lappend result [string trim $token]
append result \{$token\}
- set token ""
+ set token {}
}
}
@@ -1883,7 +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.
- lassign "" constraints setup cleanup body result returnCodes match
+ lassign {} constraints setup cleanup body result returnCodes match
# Set the default match mode
set match exact
@@ -1895,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 {
@@ -2037,7 +2024,7 @@ proc tcltest::test {name description args} {
[file join [workingDirectory] core] \
[file join [temporaryDirectory] core-$name]
} msg
- if {$msg ne ""} {
+ if {$msg ne {}} {
append coreMsg "\nError:\
Problem renaming core file: $msg"
}
@@ -2047,7 +2034,7 @@ proc tcltest::test {name description args} {
# check if the return code matched the expected return code
set codeFailure 0
- if {(!$setupFailure) && ($returnCode ni $returnCodes)} {
+ if {!$setupFailure && ($returnCode ni $returnCodes)} {
set codeFailure 1
}
@@ -2055,7 +2042,7 @@ proc tcltest::test {name description args} {
# them. If the comparison fails, then so did the test.
set outputFailure 0
variable outData
- if {[info exists output] && (!$codeFailure)} {
+ if {[info exists output] && !$codeFailure} {
if {[set outputCompare [catch {
CompareStrings $outData $output $match
} outputMatch]] == 0} {
@@ -2067,7 +2054,7 @@ proc tcltest::test {name description args} {
set errorFailure 0
variable errData
- if {[info exists errorOutput] && (!$codeFailure)} {
+ if {[info exists errorOutput] && !$codeFailure} {
if {[set errorCompare [catch {
CompareStrings $errData $errorOutput $match
} errorMatch]] == 0} {
@@ -2116,8 +2103,8 @@ proc tcltest::test {name description args} {
}
puts [outputChannel] "\n"
if {[IsVerbose line]} {
- if {(![catch {set testFrame [info frame -1]}]) &&
- ([dict get $testFrame type] eq "source")} {
+ if {![catch {set testFrame [info frame -1]}] &&
+ [dict get $testFrame type] eq "source"} {
set testFile [dict get $testFrame file]
set testLine [dict get $testFrame line]
} else {
@@ -2171,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)"
}
@@ -2252,7 +2239,7 @@ proc tcltest::Skipped {name constraints} {
}
return 1
}
- if {"" eq $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]} {
@@ -2269,7 +2256,7 @@ proc tcltest::Skipped {name constraints} {
set doTest 0
if {[string match {*[$\[]*} $constraints] != 0} {
# full expression, e.g. {$foo > [info tclversion]}
- catch {set doTest [uplevel \#0 [list expr $constraints]]}
+ catch {set doTest [uplevel #0 [list expr $constraints]]}
} elseif {[regexp {[^.:_a-zA-Z0-9 \n\r\t]+} $constraints] != 0} {
# something like {a || b} should be turned into
# $testConstraints(a) || $testConstraints(b).
@@ -2384,7 +2371,7 @@ proc tcltest::cleanupTests {{calledFromAllFile 0}} {
set testFileName [file tail [info script]]
# Hook to handle reporting to a parent interpreter
- if {[llength [info commands "[namespace current]::ReportToMaster"]]} {
+ if {[llength [info commands [namespace current]::ReportToMaster]]} {
ReportToMaster $numTests(Total) $numTests(Passed) $numTests(Skipped) \
$numTests(Failed) [array get skippedBecause] \
[array get createdNewFiles]
@@ -2406,12 +2393,12 @@ proc tcltest::cleanupTests {{calledFromAllFile 0}} {
catch {file delete -force -- $file}
}
}
- set currentFiles [list]
+ set currentFiles {}
foreach file [glob -nocomplain \
-directory [temporaryDirectory] *] {
lappend currentFiles [file tail $file]
}
- set newFiles [list]
+ set newFiles {}
foreach file $currentFiles {
if {$file ni $filesExisted} {
lappend newFiles $file
@@ -2444,7 +2431,7 @@ proc tcltest::cleanupTests {{calledFromAllFile 0}} {
if {[llength $failFiles] > 0} {
puts [outputChannel] \
"Files with failing tests: $failFiles"
- set failFiles [list]
+ set failFiles {}
}
}
@@ -2487,7 +2474,7 @@ proc tcltest::cleanupTests {{calledFromAllFile 0}} {
# loop is running, which is the real issue.
# Actually, this doesn't belong here at all. A package
# really has no business [exit]-ing an application.
- if {(![catch {package present Tk}]) && (![testConstraint interactive])} {
+ if {![catch {package present Tk}] && ![testConstraint interactive]} {
exit
}
} else {
@@ -2560,7 +2547,7 @@ proc tcltest::cleanupTests {{calledFromAllFile 0}} {
[file join [workingDirectory] core] \
[file join [temporaryDirectory] core-$testFileName]
} msg
- if {$msg ne ""} {
+ if {$msg ne {}} {
PrintError "Problem renaming file: $msg"
}
} else {
@@ -2605,9 +2592,7 @@ proc tcltest::cleanupTests {{calledFromAllFile 0}} {
# None
# a lower case version is needed for compatibility with tcltest 1.0
-proc tcltest::getMatchingFiles {args} {
- GetMatchingFiles {*}$args
-}
+proc tcltest::getMatchingFiles args {GetMatchingFiles {*}$args}
proc tcltest::GetMatchingFiles { args } {
if {[llength $args]} {
@@ -2739,8 +2724,8 @@ proc tcltest::runAllTests { {shell ""} } {
[temporaryDirectory]"
# [file system] first available in Tcl 8.4
- if {(![catch {file system [testsDirectory]} result]) &&
- ("native" ne [lindex $result 0])} {
+ if {![catch {file system [testsDirectory]} result]
+ && ([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
@@ -2800,7 +2785,7 @@ proc tcltest::runAllTests { {shell ""} } {
incr numTestFiles
set pipeFd [open $cmd "r"]
while {[gets $pipeFd line] >= 0} {
- if {[regexp -- [join {
+ if {[regexp [join {
{^([^:]+):\t}
{Total\t([0-9]+)\t}
{Passed\t([0-9]+)\t}
@@ -2809,12 +2794,12 @@ proc tcltest::runAllTests { {shell ""} } {
} ""] $line null testFile \
Total Passed Skipped Failed]} {
foreach index {Total Passed Skipped Failed} {
- incr numTests($index) [set [set index]]
+ incr numTests($index) [set $index]
}
if {$Failed > 0} {
lappend failFiles $testFile
}
- } elseif {[regexp -- [join {
+ } elseif {[regexp [join {
{^Number of tests skipped }
{for each constraint:}
{|^\t(\d+)\t(.+)$}
@@ -2883,11 +2868,6 @@ proc tcltest::runAllTests { {shell ""} } {
# none.
proc tcltest::loadTestedCommands {} {
- variable l
- if {"" eq [loadScript]} {
- return
- }
-
return [uplevel 1 [loadScript]]
}
@@ -2930,8 +2910,7 @@ proc tcltest::saveState {} {
proc tcltest::restoreState {} {
variable saveState
foreach p [uplevel 1 {::info procs}] {
- if {($p ni [lindex $saveState 0]) &&
- ("[namespace current]::$p" ne \
+ 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"
@@ -3212,9 +3191,9 @@ proc tcltest::OpenFiles {} {
proc tcltest::LeakFiles {old} {
if {[catch {testchannel open} new]} {
- return ""
+ return {}
}
- set leak [list]
+ set leak {}
foreach p $new {
if {$p ni $old} {
lappend leak $p
@@ -3287,7 +3266,7 @@ proc tcltest::RestoreLocale {} {
#
proc tcltest::threadReap {} {
- if {[info commands testthread] ne ""} {
+ if {[info commands testthread] ne {}} {
# testthread built into tcltest
@@ -3307,7 +3286,7 @@ proc tcltest::threadReap {} {
}
testthread errorproc ThreadError
return [llength [testthread names]]
- } elseif {[info commands thread::id] ne ""} {
+ } elseif {[info commands thread::id] ne {}} {
# Thread extension
@@ -3346,7 +3325,7 @@ namespace eval tcltest {
# 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 {[namespace current] eq \
+ if {[namespace current] eq
[namespace qualifiers [namespace which initConstraintsHook]]} {
InitConstraints
} else {
@@ -3391,11 +3370,11 @@ namespace eval tcltest {
}
foreach hook { PrintUsageInfoHook processCmdLineArgsHook
processCmdLineArgsAddFlagsHook } {
- if {[namespace current] eq [namespace qualifiers \
- [namespace which $hook]]} {
+ if {[namespace current] eq
+ [namespace qualifiers [namespace which $hook]]} {
set required true
} else {
- proc $hook {args} {}
+ proc $hook args {}
}
}
return $required
diff --git a/library/tm.tcl b/library/tm.tcl
index f821abb..d2af4f5 100644
--- a/library/tm.tcl
+++ b/library/tm.tcl
@@ -45,7 +45,7 @@
namespace eval ::tcl::tm {
# Default paths. None yet.
- variable paths [list]
+ variable paths {}
# The regex pattern a file name has to match to make it a Tcl Module.
@@ -203,11 +203,11 @@ proc ::tcl::tm::UnknownHandler {original name args} {
set satisfied 0
foreach path $paths {
- if {(![interp issafe]) && (![file exists $path])} {
+ if {![interp issafe] && ![file exists $path]} {
continue
}
set currentsearchpath [file join $path $pkgroot]
- if {(![interp issafe]) && (![file exists $currentsearchpath])} {
+ if {![interp issafe] && ![file exists $currentsearchpath]} {
continue
}
set strip [llength [file split $path]]
@@ -225,7 +225,7 @@ proc ::tcl::tm::UnknownHandler {original name args} {
foreach file [glob -nocomplain -directory $currentsearchpath *.tm] {
set pkgfilename [join [lrange [file split $file] $strip end] ::]
- if {![regexp -- $pkgpattern $pkgfilename ___ pkgname pkgversion]} {
+ if {![regexp -- $pkgpattern $pkgfilename --> pkgname pkgversion]} {
# Ignore everything not matching our pattern for
# package names.
continue
@@ -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]
- } {
+ 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} {
- lassign [split [info tclversion] "."] major minor
+ 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 14bcf2d..b8f34a5 100644
--- a/library/word.tcl
+++ b/library/word.tcl
@@ -31,7 +31,7 @@ namespace eval ::tcl {
variable WordBreakRE
array set WordBreakRE {}
- proc UpdateWordBreakREs {args} {
+ proc UpdateWordBreakREs args {
# Ignores the arguments
global tcl_wordchars tcl_nonwordchars
variable WordBreakRE
@@ -66,7 +66,7 @@ namespace eval ::tcl {
proc tcl_wordBreakAfter {str start} {
variable ::tcl::WordBreakRE
- set result [list -1 -1]
+ set result {-1 -1}
regexp -indices -start $start -- $WordBreakRE(after) $str result
return [lindex $result 1]
}
@@ -84,7 +84,7 @@ proc tcl_wordBreakAfter {str start} {
proc tcl_wordBreakBefore {str start} {
variable ::tcl::WordBreakRE
- set result [list -1 -1]
+ set result {-1 -1}
regexp -indices -- $WordBreakRE(before) [string range $str 0 $start] result
return [lindex $result 1]
}
@@ -103,7 +103,7 @@ proc tcl_wordBreakBefore {str start} {
proc tcl_endOfWord {str start} {
variable ::tcl::WordBreakRE
- set result [list -1 -1]
+ set result {-1 -1}
regexp -indices -start $start -- $WordBreakRE(end) $str result
return [lindex $result 1]
}
@@ -121,7 +121,7 @@ proc tcl_endOfWord {str start} {
proc tcl_startOfNextWord {str start} {
variable ::tcl::WordBreakRE
- set result [list -1 -1]
+ set result {-1 -1}
regexp -indices -start $start -- $WordBreakRE(next) $str result
return [lindex $result 1]
}
@@ -137,7 +137,7 @@ proc tcl_startOfNextWord {str start} {
proc tcl_startOfPreviousWord {str start} {
variable ::tcl::WordBreakRE
- set word [list -1 -1]
+ set word {-1 -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..6016c6d 100644
--- a/macosx/tclMacOSXFCmd.c
+++ b/macosx/tclMacOSXFCmd.c
@@ -10,6 +10,7 @@
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
+#include <sys/stat.h>
#include "tclInt.h"
#ifdef HAVE_GETATTRLIST
diff --git a/tests/assocd.test b/tests/assocd.test
index ddab034..b543c64 100644
--- a/tests/assocd.test
+++ b/tests/assocd.test
@@ -11,17 +11,15 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-if {"::tcltest" ni [namespace children]} {
- package require tcltest
- namespace import -force ::tcltest::*
-}
+package require tcltest 2
+namespace import ::tcltest::*
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
-::tcltest::testConstraint testgetassocdata [llength [info commands testgetassocdata]]
-::tcltest::testConstraint testsetassocdata [llength [info commands testsetassocdata]]
-::tcltest::testConstraint testdelassocdata [llength [info commands testdelassocdata]]
+testConstraint testgetassocdata [llength [info commands testgetassocdata]]
+testConstraint testsetassocdata [llength [info commands testsetassocdata]]
+testConstraint testdelassocdata [llength [info commands testdelassocdata]]
test assocd-1.1 {testing setting assoc data} testsetassocdata {
testsetassocdata a 1
@@ -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 270d8d9..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]]
@@ -613,7 +613,7 @@ test basic-46.4 {Tcl_AllowExceptions: exception return not allowed} -setup {
removeFile BREAKtest
} -returnCodes error -match glob -result {invoked "break" outside of a loop
while executing*
-"foo \[set a 1\] \[break\]"
+"foo \[set a 1] \[break]"
(file "*BREAKtest" line 2)}
test basic-46.5 {Tcl_AllowExceptions: exception return not allowed} -setup {
@@ -647,12 +647,12 @@ proc l3 {} {
# Do all tests once byte compiled and once with direct string evaluation
for {set noComp 0} {$noComp <= 1} {incr noComp} {
-if {$noComp} {
- interp alias "" run "" testevalex
+if $noComp {
+ interp alias {} run {} testevalex
set constraints testevalex
} else {
- interp alias "" run "" if 1
- set constraints ""
+ interp alias {} run {} if 1
+ set constraints {}
}
test basic-47.2.$noComp {Tcl_EvalEx: error during word expansion} -body {
@@ -961,8 +961,8 @@ test basic-49.2 {Tcl_EvalEx: verify TCL_EVAL_GLOBAL operation} testevalex {
# Clean up after expand tests
unset noComp l1 l2 constraints
-rename l3 ""
-rename run ""
+rename l3 {}
+rename run {}
#cleanup
catch {namespace delete {*}[namespace children :: test_ns_*]}
@@ -973,5 +973,5 @@ catch {rename q ""}
catch {rename cmd ""}
catch {rename value:at: ""}
unset -nocomplain x
-::tcltest::cleanupTests
+cleanupTests
return
diff --git a/tests/cmdInfo.test b/tests/cmdInfo.test
index 18e5c95..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 {"::tcltest" ni [namespace children]} {
- 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]]
@@ -73,8 +71,8 @@ test cmdinfo-4.1 {Tcl_GetCommandName/Tcl_GetCommandFullName procedures} \
lappend y {*}[testcmdtoken name $x]
} {newName ::newName x1 ::x1}
-catch {rename newTestCmd ""}
-catch {rename newTestCmd2 ""}
+catch {rename newTestCmd {}}
+catch {rename newTestCmd2 {}}
test cmdinfo-5.1 {Names for commands created when inside namespaces} \
{testcmdtoken} {
@@ -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 fadbd45..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 {"::tcltest" ni [namespace children]} {
- 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/env.test b/tests/env.test
index 34c758b..8f22f53 100644
--- a/tests/env.test
+++ b/tests/env.test
@@ -70,7 +70,7 @@ set printenvScript [makeFile {
}
proc mangle s {
regsub -all {\[|\\|\]} $s {\\&} s
- regsub -all {[\u0000-\u001f\u007f-\uffff]} $s {[manglechar &]} s
+ regsub -all "\[\u0000-\u001f\u007f-\uffff\]" $s {[manglechar &]} s
return [subst -novariables $s]
}
proc manglechar c {
diff --git a/tests/exec.test b/tests/exec.test
index 916b739..a354440 100644
--- a/tests/exec.test
+++ b/tests/exec.test
@@ -157,7 +157,7 @@ test exec-2.6 {redirecting input from immediate source, with UTF} -setup {
encoding system iso8859-1
proc quotenonascii s {
regsub -all {\[|\\|\]} $s {\\&} s
- regsub -all {[\u007f-\uffff]} $s \
+ regsub -all "\[\u007f-\uffff\]" $s \
{[apply {c {format {\u%04x} [scan $c %c]}} &]} s
return [subst -novariables $s]
}
diff --git a/tests/expr-old.test b/tests/expr-old.test
index 3d93b98..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 {"::tcltest" ni [namespace children]} {
- 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]]
@@ -24,9 +22,9 @@ catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testexprlong [llength [info commands testexprlong]]
testConstraint testexprdouble [llength [info commands testexprdouble]]
testConstraint testexprstring [llength [info commands testexprstring]]
-testConstraint longIs32bit [expr { ( int (0x80000000) ) < 0}]
+testConstraint longIs32bit [expr {int(0x80000000) < 0}]
-if {[catch {expr T1()} msg] && ($msg eq {invalid command name "tcl::mathfunc::T1"})} {
+if {[catch {expr T1()} msg] && $msg eq {invalid command name "tcl::mathfunc::T1"}} {
testConstraint testmathfunctions 0
} else {
testConstraint testmathfunctions 1
@@ -1016,11 +1014,11 @@ test expr-old-36.14 {ExprLooksLikeInt procedure} {
} 123456789012345678901234567891
test expr-old-36.15 {ExprLooksLikeInt procedure} {
set x "0o99 "
- list [catch {expr {$x + 1}} msg] $msg
+ list [catch {expr {$x+1}} msg] $msg
} {1 {can't use invalid octal number as operand of "+"}}
test expr-old-36.16 {ExprLooksLikeInt procedure} {
set x " 0xffffffffffffffffffffffffffffffffffffff "
- expr {$x + 1}
+ expr {$x+1}
} [expr 0x100000000000000000000000000000000000000]
test expr-old-37.1 {Check that Tcl_ExprLong doesn't modify interpreter result if no error} testexprlong {
@@ -1165,7 +1163,7 @@ test expr-old-40.3 {min math function} -body {
} -result {1 {too few arguments to math function "min"}}
test expr-old-40.4 {min math function} -body {
expr {min(wide(-1) << 30, 4.5, -10)}
-} -result [expr { ( wide (-1) ) << 30}]
+} -result [expr {wide(-1) << 30}]
test expr-old-40.5 {min math function} -body {
expr {min("a", 0)}
} -returnCodes error -match glob -result *
@@ -1184,7 +1182,7 @@ test expr-old-41.3 {max math function} -body {
} -result {1 {too few arguments to math function "max"}}
test expr-old-41.4 {max math function} -body {
expr {max(wide(1) << 30, 4.5, -10)}
-} -result [expr { ( wide(1) ) << 30}]
+} -result [expr {wide(1) << 30}]
test expr-old-41.5 {max math function} -body {
expr {max("a", 0)}
} -returnCodes error -match glob -result *
@@ -1194,7 +1192,7 @@ test expr-old-41.6 {max math function} -body {
# Special test for Pentium arithmetic bug of 1994:
-if {(4195835.0 - ((4195835.0 / 3145727.0) * 3145727.0)) == 256.0} {
+if {(4195835.0 - (4195835.0/3145727.0)*3145727.0) == 256.0} {
puts "Warning: this machine contains a defective Pentium processor"
puts "that performs arithmetic incorrectly. I recommend that you"
puts "call Intel customer service immediately at 1-800-628-8686"
diff --git a/tests/http.test b/tests/http.test
index 5e09bfc..cd64f6d 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/info.test b/tests/info.test
index f19d91c..e6d737b 100644
--- a/tests/info.test
+++ b/tests/info.test
@@ -693,33 +693,32 @@ test info-21.5 {miscellaneous error conditions} -returnCodes error -body {
##
# ### ### ### ######### ######### #########
## info frame
+
## Helper
# For the more complex results we cut the file name down to remove path
# dependencies, and we use only part of the first line of the reported
# command. The latter is required because otherwise the whole test case may
# appear in some results, but the result is part of the testcase. An infinite
# string would be required to describe that. The cutting-down breaks this.
+
proc reduce {frame} {
- set pos [lsearch -exact $frame cmd]
- incr pos
- set cmd [lindex $frame $pos]
+ set cmd [dict get $frame cmd]
if {[regexp \n $cmd]} {
- set first [string range [lindex [split $cmd \n] 0] 0 end-4]
- set frame [lreplace $frame $pos $pos $first]
+ dict set frame cmd \
+ [string range [lindex [split $cmd \n] 0] 0 end-4]
}
- set pos [lsearch -exact $frame file]
- if {$pos >= 0} {
- incr pos
- set tail [file tail [lindex $frame $pos]]
- set frame [lreplace $frame $pos $pos $tail]
+ if {[dict exists $frame file]} {
+ dict set frame file \
+ [file tail [dict get $frame file]]
}
- set frame
+ return $frame
}
proc subinterp {} {
interp create sub
interp debug sub -frame 1
interp eval sub [list proc reduce [info args reduce] [info body reduce]]
}
+
## Helper
# Generate a stacktrace from the current location to top. This code
# not only depends on the exact location of things, but also on the
@@ -1465,9 +1464,9 @@ test info-30.1 {bs+nl in literal words, procedure body, compiled} -body {
test info-30.2 {bs+nl in literal words, namespace script} {
namespace eval xxx {
variable res \
- [reduce [info frame 0]];# line 1468
+ [info frame 0];# line 1468
}
- return $xxx::res
+ return [reduce $xxx::res]
} {type source line 1468 file info.test cmd {info frame 0} level 0}
test info-30.3 {bs+nl in literal words, namespace multi-word script} {
diff --git a/tests/listObj.test b/tests/listObj.test
index 09a84d9..081e88a 100644
--- a/tests/listObj.test
+++ b/tests/listObj.test
@@ -196,6 +196,10 @@ test listobj-10.1 {Bug [2971669]} {*}{
-result {{a b c d e} {} {a b c d e f}}
}
+test listobj-11.1 {bug 3598580} {
+ testobj bug3598580
+} 123
+
# cleanup
::tcltest::cleanupTests
return
diff --git a/tests/main.test b/tests/main.test
index 3e2b85f..351fd4f 100644
--- a/tests/main.test
+++ b/tests/main.test
@@ -618,7 +618,7 @@ namespace eval ::tcl::test::main {
after cancel $id
set wait
} -cleanup {
- if {("timeout" eq $wait) && [testConstraint unix]} {
+ if {$wait eq "timeout" && [testConstraint unix]} {
exec kill [pid $f]
}
close $f
@@ -641,7 +641,7 @@ namespace eval ::tcl::test::main {
after cancel $id
set wait
} -cleanup {
- if {("timeout" eq $wait) && [testConstraint unix]} {
+ if {$wait eq "timeout" && [testConstraint unix]} {
exec kill [pid $f]
}
close $f
diff --git a/tests/msgcat.test b/tests/msgcat.test
index 5ed61a7..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,8 +56,8 @@ namespace eval ::msgcat::test {
set result [string tolower \
[msgcat::ConvertLocale $::tcl::mac::locale]]
} else {
- if {([info sharedlibextension] eq ".dll") &&
- (![catch {package require registry}])} {
+ 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
# and the registry package is present
@@ -417,7 +417,7 @@ namespace eval ::msgcat::test {
mclocale $locale
} -body {
mcload $msgdir
- } -result [expr { $count + 1 }]
+ } -result [expr { $count+1 }]
incr count
}
diff --git a/tests/nre.test b/tests/nre.test
index 4f1bd5e..85ac8d8 100644
--- a/tests/nre.test
+++ b/tests/nre.test
@@ -74,7 +74,6 @@ test nre-1.1 {self-recursive procs} -setup {
} -constraints {
testnrelevels
} -result {{0 1 1 1} 0}
-
test nre-1.2 {self-recursive lambdas} -setup {
set a [list i [makebody {apply $::a $i}]]
} -body {
@@ -85,7 +84,6 @@ test nre-1.2 {self-recursive lambdas} -setup {
} -constraints {
testnrelevels
} -result {{0 1 1 1} 0}
-
test nre-1.3 {mutually recursive procs and lambdas} -setup {
proc a i {
apply $::b [incr i]
@@ -164,8 +162,7 @@ test nre-5.1 {[namespace eval] is not recursive} -setup {
namespace delete ::foo
} -constraints {
testnrelevels
-} -result {{0 3 2 2} 0}
-
+} -result {{0 2 2 2} 0}
test nre-5.2 {[namespace eval] is not recursive} -setup {
namespace eval ::foo {
setabs
@@ -177,7 +174,7 @@ test nre-5.2 {[namespace eval] is not recursive} -setup {
namespace delete ::foo
} -constraints {
testnrelevels
-} -result {{0 3 2 2} 0}
+} -result {{0 2 2 2} 0}
test nre-6.1 {[uplevel] is not recursive} -setup {
proc a i [makebody {uplevel 1 [list a $i]}]
@@ -189,7 +186,6 @@ test nre-6.1 {[uplevel] is not recursive} -setup {
} -constraints {
testnrelevels
} -result {{0 2 2 0} 0}
-
test nre-6.2 {[uplevel] is not recursive} -setup {
setabs
proc a i [makebody {uplevel 1 "set x $i; a $i"}]
@@ -211,7 +207,6 @@ test nre-7.1 {[catch] is not recursive} -setup {
} -constraints {
testnrelevels
} -result {{0 3 3 0} 0}
-
test nre-7.2 {[if] is not recursive} -setup {
setabs
proc a i [makebody {uplevel 1 "if 1 {a $i}"}]
@@ -222,7 +217,6 @@ test nre-7.2 {[if] is not recursive} -setup {
} -constraints {
testnrelevels
} -result {{0 2 2 0} 0}
-
test nre-7.3 {[while] is not recursive} -setup {
setabs
proc a i [makebody {uplevel 1 "while 1 {set res \[a $i\]; break}; set res"}]
@@ -233,7 +227,6 @@ test nre-7.3 {[while] is not recursive} -setup {
} -constraints {
testnrelevels
} -result {{0 2 2 0} 0}
-
test nre-7.4 {[for] is not recursive} -setup {
setabs
proc a i [makebody {uplevel 1 "for {set j 0} {\$j < 10} {incr j} {set res \[a $i\]; break}; set res"}]
@@ -244,7 +237,6 @@ test nre-7.4 {[for] is not recursive} -setup {
} -constraints {
testnrelevels
} -result {{0 2 2 0} 0}
-
test nre-7.5 {[foreach] is not recursive} -setup {
#
# Enable once [foreach] is NR-enabled
@@ -258,7 +250,6 @@ test nre-7.5 {[foreach] is not recursive} -setup {
} -constraints {
testnrelevels
} -result {{0 3 3 0} 0}
-
test nre-7.6 {[eval] is not recursive} -setup {
proc a i [makebody {eval [list a $i]}]
} -body {
@@ -269,7 +260,6 @@ test nre-7.6 {[eval] is not recursive} -setup {
} -constraints {
testnrelevels
} -result {{0 2 2 1} 0}
-
test nre-7.7 {[eval] is not recursive} -setup {
proc a i [makebody {eval "a $i"}]
} -body {
@@ -280,7 +270,6 @@ test nre-7.7 {[eval] is not recursive} -setup {
} -constraints {
testnrelevels
} -result {{0 2 2 1} 0}
-
test nre-7.8 {bug #2910748: switch out of stale BC is not nre-aware} -setup {
proc foo args {}
foo
@@ -295,17 +284,14 @@ test nre-7.8 {bug #2910748: switch out of stale BC is not nre-aware} -setup {
} -body {
# if switching to plain eval is not nre aware, this will cause a "cannot
# yield" error
-
list [bar] [bar] [bar]
} -cleanup {
rename bar ""
rename foo ""
} -result {1 2 3}
-
test nre-8.1 {nre and {*}} -body {
# force an expansion that grows the evaluation stack, check that nre
# adapts the TEBCdataPtr. This crashes on failure.
-
proc inner {} {
set long [lrepeat 1000000 1]
list {*}$long
@@ -320,14 +306,12 @@ test nre-8.2 {nre and {*}, [Bug 2415422]} -body {
# force an expansion that grows the evaluation stack, check that nre
# adapts the bcFramePtr. This causes an NRE assertion to fail if it is not
# done properly.
-
proc nop {} {}
proc crash {} {
foreach val [list {*}[lrepeat 100000 x]] {
nop
}
}
-
crash
} -cleanup {
rename nop ""
@@ -349,7 +333,6 @@ test nre-oo.1 {really deep calls in oo - direct} -setup {
} -constraints {
testnrelevels
} -result {{0 1 1 1} 0}
-
test nre-oo.2 {really deep calls in oo - call via [self]} -setup {
oo::object create foo
oo::objdefine foo method bar i [makebody {[self] bar $i}]
@@ -361,7 +344,6 @@ test nre-oo.2 {really deep calls in oo - call via [self]} -setup {
} -constraints {
testnrelevels
} -result {{0 1 1 1} 0}
-
test nre-oo.3 {really deep calls in oo - private calls} -setup {
oo::object create foo
oo::objdefine foo method bar i [makebody {my bar $i}]
@@ -373,7 +355,6 @@ test nre-oo.3 {really deep calls in oo - private calls} -setup {
} -constraints {
testnrelevels
} -result {{0 1 1 1} 0}
-
test nre-oo.4 {really deep calls in oo - overriding} -setup {
oo::class create foo {
method bar i [makebody {my bar $i}]
@@ -390,7 +371,6 @@ test nre-oo.4 {really deep calls in oo - overriding} -setup {
} -constraints {
testnrelevels
} -result {{0 1 1 1} 0}
-
test nre-oo.5 {really deep calls in oo - forwards} -setup {
oo::object create foo
set body [makebody {my boo $i}]
@@ -407,7 +387,6 @@ test nre-oo.5 {really deep calls in oo - forwards} -setup {
testnrelevels
} -result {{0 2 1 1} 0}
-
#
# NASTY BUG found by tcllib's interp package
#
diff --git a/tests/parse.test b/tests/parse.test
index bc9fb11..b9cfe80 100644
--- a/tests/parse.test
+++ b/tests/parse.test
@@ -26,6 +26,7 @@ testConstraint testparsevarname [llength [info commands testparsevarname]]
testConstraint testparsevar [llength [info commands testparsevar]]
testConstraint testasync [llength [info commands testasync]]
testConstraint testcmdtrace [llength [info commands testcmdtrace]]
+testConstraint testevent [llength [info commands testevent]]
test parse-1.1 {Tcl_ParseCommand procedure, computing string length} testparser {
testparser [bytestring "foo\0 bar"] -1
@@ -436,6 +437,7 @@ test parse-8.12 {Tcl_EvalObjv procedure, TCL_EVAL_INVOKE} {
set ::info
} global
+
test parse-9.1 {Tcl_LogCommandInfo, line numbers} testevalex {
unset -nocomplain x
list [catch {testevalex {for {} 1 {} {
@@ -1089,6 +1091,13 @@ test parse-20.12 {TclParseBackslash: truncated escape} testparser {
testparser {\x12X} 5
} {- {\x12X} 1 word {\x12X} 2 backslash {\x12} 0 text X 0 {}}
+test parse-21.0 {Bug 1884496} testevent {
+ set ::script {testevent delete a; set a [p]; set ::done $a}
+ proc ::p {} {string first s $::script}
+ testevent queue a head $::script
+ vwait done
+} {}
+
cleanupTests
}
diff --git a/tests/parseExpr.test b/tests/parseExpr.test
index 98d3f67..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 {"::tcltest" ni [namespace children]} {
- 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 0e5b68f..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 {"::tcltest" ni [namespace children]} {
- package require tcltest
- namespace import -force ::tcltest::*
-}
+package require tcltest
+namespace import ::tcltest::*
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
@@ -34,7 +32,7 @@ proc fourArgs {a b c d} {
set arg4 $d
}
-proc getArgs {args} {
+proc getArgs args {
global argv
set argv $args
}
@@ -110,7 +108,7 @@ test parseOld-3.6 {braces} {
set argv
} "a{{}}b"
test parseOld-3.7 {braces} {
- set a [format "last\]"]
+ set a [format "last]"]
set a
} {last]}
@@ -510,10 +508,11 @@ test parseOld-14.17 {TclWordEnd procedure} {testwordend} {
} {c}
test parseOld-14.18 {TclWordEnd procedure} {testwordend} {
testwordend \[a\000\]
-} {\]}
+} {]}
test parseOld-14.19 {TclWordEnd procedure} {testwordend} {
testwordend \"a\000\"
-} {\"}
+} {"}
+#" Emacs formatting :^(
test parseOld-14.20 {TclWordEnd procedure} {testwordend} {
testwordend a{\000}b
} {b}
diff --git a/tests/pkgMkIndex.test b/tests/pkgMkIndex.test
index daf9c1c..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 {"::tcltest" ni [namespace children]} {
- 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 {"-load" eq $a} {
+ if {$a eq "-load"} {
incr iarg
lappend options [lindex $args $iarg]
}
@@ -75,7 +73,7 @@ proc pkgtest::parseArgs { args } {
proc pkgtest::parseIndex { filePath } {
# create a slave interpreter, where we override "package ifneeded"
- global errorCode errorInfo
+
set slave [interp create]
if {[catch {
$slave eval {
@@ -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}
@@ -153,7 +151,7 @@ proc pkgtest::createIndex { args } {
file mkdir $dirPath
if {[catch {
- file delete -- [file join $dirPath pkgIndex.tcl]
+ file delete [file join $dirPath pkgIndex.tcl]
pkg_mkIndex {*}$options $dirPath {*}$patternList
} err]} {
return [list 1 $err]
@@ -184,7 +182,7 @@ proc makePkgList { inList } {
set pkgList ""
foreach {k v} $inList {
- switch -- [lindex $v 0] {
+ switch [lindex $v 0] {
tclPkgSetup {
set l tclPkgSetup
foreach s [lindex $v 4] {
@@ -234,7 +232,7 @@ proc pkgtest::runCreatedIndex {rv args} {
} err]} {
set result [list 1 $err]
}
- file delete -- $idxFile
+ file delete $idxFile
} else {
set result $rv
}
@@ -358,7 +356,7 @@ proc direct1::pd2 { stg } {
return [string toupper $stg]
}
} [file join direct1 direct1.tcl]
-pkg_mkIndex -direct -- $direct1 direct1.tcl
+pkg_mkIndex -direct $direct1 direct1.tcl
makeFile {
# Does a package require of direct1, whose pkgIndex.tcl entry is created
@@ -382,7 +380,7 @@ test pkgMkIndex-5.1 {requires -direct package} {
} {0 {{std:1.0 {tclPkgSetup {std.tcl source {::std::p1 ::std::p2}}}}}}
removeFile [file join direct1 direct1.tcl]
-file delete -- [file join $direct1 pkgIndex.tcl]
+file delete [file join $direct1 pkgIndex.tcl]
removeDirectory direct1
removeFile [file join pkg std.tcl]
@@ -565,7 +563,7 @@ proc pkga_neq { x } {
return [expr {! [pkgq_eq $x]}]
}
} [file join pkg pkga.tcl]
- file copy -force -- $x $fullPkgPath
+ file copy -force $x $fullPkgPath
}
testConstraint exec [llength [info commands ::exec]]
@@ -592,7 +590,7 @@ test pkgMkIndex-10.2 {package in DLL hidden by -load} [list exec $dll] {
} {0 {}}
if {[testConstraint $dll]} {
- file delete -force -- [file join $fullPkgPath [file tail $x]]
+ file delete -force [file join $fullPkgPath [file tail $x]]
removeFile [file join pkg pkga.tcl]
}
diff --git a/tests/platform.test b/tests/platform.test
index 8639f0c..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 {"::tcltest" ni [namespace children]} {
- 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/result.test b/tests/result.test
index 43cf9a5..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 {"::tcltest" ni [namespace children]} {
- 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/stack.test b/tests/stack.test
index cf46b7b..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 {"::tcltest" ni [namespace children]} {
- 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 37637d9..ce8d617 100755
--- a/tests/tcltest.test
+++ b/tests/tcltest.test
@@ -65,9 +65,9 @@ test tcltest-1.3 {tcltest -h} {exec} {
proc slave {msgVar args} {
upvar 1 $msgVar msg
- interp create -- [namespace current]::i
+ interp create [namespace current]::i
# Fake the slave interp into dumping output to a file
- i eval {namespace eval ::tcltest ""}
+ i eval {namespace eval ::tcltest {}}
i eval "set tcltest::outputChannel\
\[[list open [set of [makeFile {} output]] w]]"
i eval "set tcltest::errorChannel\
@@ -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]
@@ -520,10 +515,10 @@ set a [makeFile {
exit
} a.tcl]
-set tdiaf [::tcltest::makeFile {} thisdirectoryisafile]
+set tdiaf [makeFile {} thisdirectoryisafile]
-set normaldirectory [::tcltest::makeDirectory normaldirectory]
-::tcltest::normalizePath normaldirectory
+set normaldirectory [makeDirectory normaldirectory]
+normalizePath normaldirectory
# -tmpdir, [temporaryDirectory]
test tcltest-8.1 {tcltest a.tcl -tmpdir a} -constraints unixOrPc -setup {
@@ -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
}
@@ -717,7 +712,7 @@ test tcltest-8.60 {::workingDirectory} {
# clean up from directory testing
switch -- $::tcl_platform(platform) {
- "unix" {
+ unix {
file attributes $notReadableDir -permissions 777
file attributes $notWriteableDir -permissions 777
}
diff --git a/tests/thread.test b/tests/thread.test
index febc7a8..f32ef61 100644
--- a/tests/thread.test
+++ b/tests/thread.test
@@ -11,7 +11,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-if {"::tcltest" ni [namespace children]} {
+if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2.2
namespace import -force ::tcltest::*
}
@@ -42,11 +42,11 @@ set threadSuperKillScript {
proc getThreadErrorFromInfo { info } {
set list [split $info \n]
set idx [lsearch -glob $list "*eval*unwound*"]
- if {$idx != -1} {
+ if {$idx != -1} then {
return [lindex $list $idx]
}
set idx [lsearch -glob $list "*eval*canceled*"]
- if {$idx != -1} {
+ if {$idx != -1} then {
return [lindex $list $idx]
}
return ""; # some other error we do not care about.
@@ -55,7 +55,7 @@ proc getThreadErrorFromInfo { info } {
proc findThreadError { info } {
foreach error [lreverse $info] {
set error [getThreadErrorFromInfo $error]
- if {[string length $error] > 0} {
+ if {[string length $error] > 0} then {
return $error
}
}
@@ -64,7 +64,7 @@ proc findThreadError { info } {
proc ThreadError {id info} {
global threadSawError
- if {[string length [getThreadErrorFromInfo $info]] > 0} {
+ if {[string length [getThreadErrorFromInfo $info]] > 0} then {
global threadId threadError
set threadId $id
lappend threadError($id) $info
@@ -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
@@ -159,7 +137,7 @@ test thread-1.15 {Tcl_ThreadObjCmd: wait} {thread} {
# ThreadErrorProc, except for printing to standard error
test thread-2.1 {ListUpdateInner and ListRemove} {thread} {
- unset -nocomplain tid
+ catch {unset tid}
foreach t {0 1 2} {
upvar #0 t$t tid
set tid [thread::create -preserved]
@@ -172,7 +150,7 @@ test thread-2.1 {ListUpdateInner and ListRemove} {thread} {
} 1
test thread-3.1 {TclThreadList} {thread} {
- unset -nocomplain tid
+ catch {unset tid}
set len [llength [thread::names]]
set l1 {}
foreach t {0 1 2} {
@@ -187,7 +165,7 @@ test thread-3.1 {TclThreadList} {thread} {
} {1 0}
test thread-4.1 {TclThreadSend to self} {thread} {
- unset -nocomplain x
+ catch {unset x}
thread::send [thread::id] {
set x 4
}
@@ -233,6 +211,7 @@ test thread-4.5 {TclThreadSend preserve errorCode} {thread} {
list $x $msg $savedErrorCode
} {1 ERR CODE}
+
test thread-5.0 {Joining threads} {thread} {
set serverthread [thread::create -joinable -preserved]
thread::send -async $serverthread {after 1000 ; thread::release}
@@ -274,7 +253,7 @@ test thread-7.4 {cancel: pure bytecode loop} -constraints {thread drainEventQueu
set serverthread [thread::create -joinable \
[string map [list %ID% [thread::id]] {
proc foobar {} {
- if {![info exists foo]} {
+ if {![info exists foo]} then {
# signal the primary thread that we are ready
# to be canceled now (we are running).
thread::send %ID% [list set ::threadIdStarted [thread::id]]
@@ -305,7 +284,7 @@ test thread-7.5 {cancel: pure inside-command loop} -constraints {thread drainEve
set serverthread [thread::create -joinable \
[string map [list %ID% [thread::id]] {
proc foobar {} {
- if {![info exists foo]} {
+ if {![info exists foo]} then {
# signal the primary thread that we are ready
# to be canceled now (we are running).
thread::send %ID% [list set ::threadIdStarted [thread::id]]
@@ -337,7 +316,7 @@ test thread-7.6 {cancel: pure bytecode loop -unwind} -constraints {thread drainE
set serverthread [thread::create -joinable \
[string map [list %ID% [thread::id]] {
proc foobar {} {
- if {![info exists foo]} {
+ if {![info exists foo]} then {
# signal the primary thread that we are ready
# to be canceled now (we are running).
thread::send %ID% [list set ::threadIdStarted [thread::id]]
@@ -368,7 +347,7 @@ test thread-7.7 {cancel: pure inside-command loop -unwind} -constraints {thread
set serverthread [thread::create -joinable \
[string map [list %ID% [thread::id]] {
proc foobar {} {
- if {![info exists foo]} {
+ if {![info exists foo]} then {
# signal the primary thread that we are ready
# to be canceled now (we are running).
thread::send %ID% [list set ::threadIdStarted [thread::id]]
@@ -400,7 +379,7 @@ test thread-7.8 {cancel: pure bytecode loop custom result} -constraints {thread
set serverthread [thread::create -joinable \
[string map [list %ID% [thread::id]] {
proc foobar {} {
- if {![info exists foo]} {
+ if {![info exists foo]} then {
# signal the primary thread that we are ready
# to be canceled now (we are running).
thread::send %ID% [list set ::threadIdStarted [thread::id]]
@@ -434,7 +413,7 @@ test thread-7.9 {cancel: pure inside-command loop custom result} -constraints {
set serverthread [thread::create -joinable \
[string map [list %ID% [thread::id]] {
proc foobar {} {
- if {![info exists foo]} {
+ if {![info exists foo]} then {
# signal the primary thread that we are ready
# to be canceled now (we are running).
thread::send %ID% [list set ::threadIdStarted [thread::id]]
@@ -469,7 +448,7 @@ test thread-7.10 {cancel: pure bytecode loop custom result -unwind} -constraints
set serverthread [thread::create -joinable \
[string map [list %ID% [thread::id]] {
proc foobar {} {
- if {![info exists foo]} {
+ if {![info exists foo]} then {
# signal the primary thread that we are ready
# to be canceled now (we are running).
thread::send %ID% [list set ::threadIdStarted [thread::id]]
@@ -503,7 +482,7 @@ test thread-7.11 {cancel: pure inside-command loop custom result -unwind} -const
set serverthread [thread::create -joinable \
[string map [list %ID% [thread::id]] {
proc foobar {} {
- if {![info exists foo]} {
+ if {![info exists foo]} then {
# signal the primary thread that we are ready
# to be canceled now (we are running).
thread::send %ID% [list set ::threadIdStarted [thread::id]]
@@ -534,7 +513,7 @@ test thread-7.12 {cancel: after} -constraints {thread drainEventQueue} -setup {
} -body {
set serverthread [thread::create -joinable \
[string map [list %ID% [thread::id]] {
- if {![info exists foo]} {
+ if {![info exists foo]} then {
# signal the primary thread that we are ready
# to be canceled now (we are running).
thread::send %ID% [list set ::threadIdStarted [thread::id]]
@@ -560,7 +539,7 @@ test thread-7.13 {cancel: after -unwind} -constraints {thread drainEventQueue} -
} -body {
set serverthread [thread::create -joinable \
[string map [list %ID% [thread::id]] {
- if {![info exists foo]} {
+ if {![info exists foo]} then {
# signal the primary thread that we are ready
# to be canceled now (we are running).
thread::send %ID% [list set ::threadIdStarted [thread::id]]
@@ -586,7 +565,7 @@ test thread-7.14 {cancel: vwait} -constraints {thread drainEventQueue} -setup {
} -body {
set serverthread [thread::create -joinable \
[string map [list %ID [thread::id]] {
- if {![info exists foo]} {
+ if {![info exists foo]} then {
# signal the primary thread that we are ready
# to be canceled now (we are running).
thread::send %ID% [list set ::threadIdStarted [thread::id]]
@@ -612,7 +591,7 @@ test thread-7.15 {cancel: vwait -unwind} -constraints {thread drainEventQueue} -
} -body {
set serverthread [thread::create -joinable \
[string map [list %ID% [thread::id]] {
- if {![info exists foo]} {
+ if {![info exists foo]} then {
# signal the primary thread that we are ready
# to be canceled now (we are running).
thread::send %ID% [list set ::threadIdStarted [thread::id]]
@@ -641,7 +620,7 @@ test thread-7.16 {cancel: expr} -constraints {thread drainEventQueue} -setup {
set i [interp create]
$i eval "package require -exact Thread [package present Thread]"
$i eval {
- if {![info exists foo]} {
+ if {![info exists foo]} then {
# signal the primary thread that we are ready
# to be canceled now (we are running).
@@ -672,7 +651,7 @@ test thread-7.17 {cancel: expr -unwind} -constraints {thread drainEventQueue} -s
set i [interp create]
$i eval "package require -exact Thread [package present Thread]"
$i eval {
- if {![info exists foo]} {
+ if {![info exists foo]} then {
# signal the primary thread that we are ready
# to be canceled now (we are running).
thread::send %ID% [list set ::threadIdStarted [thread::id]]
@@ -701,7 +680,7 @@ test thread-7.18 {cancel: expr bignum} {thread drainEventQueue knownBug} {
set i [interp create]
$i eval "package require -exact Thread [package present Thread]"
$i eval {
- if {![info exists foo]} {
+ if {![info exists foo]} then {
# signal the primary thread that we are ready
# to be canceled now (we are running).
thread::send %ID% [list set ::threadIdStarted [thread::id]]
@@ -733,7 +712,7 @@ test thread-7.19 {cancel: expr bignum -unwind} {thread drainEventQueue knownBug}
set i [interp create]
$i eval "package require -exact Thread [package present Thread]"
$i eval {
- if {![info exists foo]} {
+ if {![info exists foo]} then {
# signal the primary thread that we are ready
# to be canceled now (we are running).
thread::send %ID% [list set ::threadIdStarted [thread::id]]
@@ -766,7 +745,7 @@ test thread-7.20 {cancel: subst} -constraints {thread drainEventQueue} -setup {
set i [interp create]
$i eval "package require -exact Thread [package present Thread]"
$i eval {
- if {![info exists foo]} {
+ if {![info exists foo]} then {
# signal the primary thread that we are ready
# to be canceled now (we are running).
thread::send %ID% [list set ::threadIdStarted [thread::id]]
@@ -796,7 +775,7 @@ test thread-7.21 {cancel: subst -unwind} -constraints {thread drainEventQueue} -
set i [interp create]
$i eval "package require -exact Thread [package present Thread]"
$i eval {
- if {![info exists foo]} {
+ if {![info exists foo]} then {
# signal the primary thread that we are ready
# to be canceled now (we are running).
thread::send %ID% [list set ::threadIdStarted [thread::id]]
@@ -826,7 +805,7 @@ test thread-7.22 {cancel: slave interp} -constraints {thread drainEventQueue} -s
set i [interp create]
$i eval "package require -exact Thread [package present Thread]"
$i eval {
- if {![info exists foo]} {
+ if {![info exists foo]} then {
# signal the primary thread that we are ready
# to be canceled now (we are running).
thread::send %ID% [list set ::threadIdStarted [thread::id]]
@@ -856,7 +835,7 @@ test thread-7.23 {cancel: slave interp -unwind} -constraints {thread drainEventQ
set i [interp create]
$i eval "package require -exact Thread [package present Thread]"
$i eval {
- if {![info exists foo]} {
+ if {![info exists foo]} then {
# signal the primary thread that we are ready
# to be canceled now (we are running).
thread::send %ID% [list set ::threadIdStarted [thread::id]]
@@ -884,7 +863,7 @@ test thread-7.24 {cancel: nested catch inside pure bytecode loop} {thread drainE
[string map [list %ID% [thread::id]] {
proc foobar {} {
while {1} {
- if {![info exists foo]} {
+ if {![info exists foo]} then {
# signal the primary thread that we are ready
# to be canceled now (we are running).
thread::send %ID% [list set ::threadIdStarted [thread::id]]
@@ -926,7 +905,7 @@ test thread-7.25 {cancel: nested catch inside pure inside-command loop} {thread
set catch catch
set while while
$while {1} {
- if {![info exists foo]} {
+ if {![info exists foo]} then {
# signal the primary thread that we are ready
# to be canceled now (we are running).
thread::send %ID% [list set ::threadIdStarted [thread::id]]
@@ -966,7 +945,7 @@ test thread-7.26 {cancel: send async cancel bad interp path} {thread drainEventQ
[string map [list %ID% [thread::id]] {
proc foobar {} {
while {1} {
- if {![info exists foo]} {
+ if {![info exists foo]} then {
# signal the primary thread that we are ready
# to be canceled now (we are running).
thread::send %ID% [list set ::threadIdStarted [thread::id]]
@@ -995,7 +974,7 @@ test thread-7.27 {cancel: send async cancel -- switch} -constraints {thread drai
$i eval {
proc foobar {} {
while {1} {
- if {![info exists foo]} {
+ if {![info exists foo]} then {
# signal the primary thread that we are ready
# to be canceled now (we are running).
thread::send %ID% [list set ::threadIdStarted [thread::id]]
@@ -1026,7 +1005,7 @@ test thread-7.28 {cancel: send async cancel nested catch inside pure bytecode lo
[string map [list %ID% [thread::id]] {
proc foobar {} {
while {1} {
- if {![info exists foo]} {
+ if {![info exists foo]} then {
# signal the primary thread that we are ready
# to be canceled now (we are running).
thread::send %ID% [list set ::threadIdStarted [thread::id]]
@@ -1068,7 +1047,7 @@ test thread-7.29 {cancel: send async cancel nested catch pure inside-command loo
set catch catch
set while while
$while {1} {
- if {![info exists foo]} {
+ if {![info exists foo]} then {
# signal the primary thread that we are ready
# to be canceled now (we are running).
thread::send %ID% [list set ::threadIdStarted [thread::id]]
@@ -1108,7 +1087,7 @@ test thread-7.30 {cancel: send async thread cancel nested catch inside pure byte
[string map [list %ID% [thread::id]] {
proc foobar {} {
while {1} {
- if {![info exists foo]} {
+ if {![info exists foo]} then {
# signal the primary thread that we are ready
# to be canceled now (we are running).
thread::send %ID% [list set ::threadIdStarted [thread::id]]
@@ -1150,7 +1129,7 @@ test thread-7.31 {cancel: send async thread cancel nested catch pure inside-comm
set catch catch
set while while
$while {1} {
- if {![info exists foo]} {
+ if {![info exists foo]} then {
# signal the primary thread that we are ready
# to be canceled now (we are running).
thread::send %ID% [list set ::threadIdStarted [thread::id]]
@@ -1191,7 +1170,7 @@ test thread-7.32 {cancel: nested catch inside pure bytecode loop -unwind} -const
[string map [list %ID% [thread::id]] {
proc foobar {} {
while {1} {
- if {![info exists foo]} {
+ if {![info exists foo]} then {
# signal the primary thread that we are ready
# to be canceled now (we are running).
thread::send %ID% [list set ::threadIdStarted [thread::id]]
@@ -1232,7 +1211,7 @@ test thread-7.33 {cancel: nested catch inside pure inside-command loop -unwind}
set catch catch
set while while
$while {1} {
- if {![info exists foo]} {
+ if {![info exists foo]} then {
# signal the primary thread that we are ready
# to be canceled now (we are running).
thread::send %ID% [list set ::threadIdStarted [thread::id]]
@@ -1271,7 +1250,7 @@ test thread-7.34 {cancel: send async cancel nested catch inside pure bytecode lo
[string map [list %ID% [thread::id]] {
proc foobar {} {
while {1} {
- if {![info exists foo]} {
+ if {![info exists foo]} then {
# signal the primary thread that we are ready
# to be canceled now (we are running).
thread::send %ID% [list set ::threadIdStarted [thread::id]]
@@ -1314,7 +1293,7 @@ test thread-7.35 {cancel: send async cancel nested catch inside pure inside-comm
set catch catch
set while while
$while {1} {
- if {![info exists foo]} {
+ if {![info exists foo]} then {
# signal the primary thread that we are ready
# to be canceled now (we are running).
thread::send %ID% [list set ::threadIdStarted [thread::id]]
@@ -1355,7 +1334,7 @@ test thread-7.36 {cancel: send async thread cancel nested catch inside pure byte
[string map [list %ID% [thread::id]] {
proc foobar {} {
while {1} {
- if {![info exists foo]} {
+ if {![info exists foo]} then {
# signal the primary thread that we are ready
# to be canceled now (we are running).
thread::send %ID% [list set ::threadIdStarted [thread::id]]
@@ -1398,7 +1377,7 @@ test thread-7.37 {cancel: send async thread cancel nested catch inside pure insi
set catch catch
set while while
$while {1} {
- if {![info exists foo]} {
+ if {![info exists foo]} then {
# signal the primary thread that we are ready
# to be canceled now (we are running).
thread::send %ID% [list set ::threadIdStarted [thread::id]]
diff --git a/tests/tm.test b/tests/tm.test
index 85db6aa..1b22f8c 100644
--- a/tests/tm.test
+++ b/tests/tm.test
@@ -40,6 +40,7 @@ test tm-2.3 {tm: roots command syntax} -returnCodes error -body {
::tcl::tm::roots foo bar
} -result "wrong # args: should be \"::tcl::tm::roots paths\""
+
test tm-3.1 {tm: module path management, input validation} -setup {
# Save and clear the list
set defaults [::tcl::tm::path list]
@@ -195,11 +196,12 @@ test tm-3.11 {tm: module path management, remove ignores unknown path} -setup {
::tcl::tm::path list
} -result {geode snarf foo}
-proc genpaths {a_base} {
+
+proc genpaths {base} {
# Normalizing picks up drive letters on windows [Bug 1053568]
- set base [file normalize $a_base]
- lassign [split [info tclversion] "."] major minor
- set results [list]
+ set base [file normalize $base]
+ lassign [split [package present Tcl] .] major minor
+ set results {}
set base [file join $base tcl$major]
lappend results [file join $base site-tcl]
for {set i 0} {$i <= $minor} {incr i} {
diff --git a/tests/trace.test b/tests/trace.test
index 35429f6..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 {"::tcltest" ni [namespace children]} {
- package require tcltest
- namespace import -force ::tcltest::*
-}
+package require tcltest
+namespace import ::tcltest::*
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
@@ -84,40 +82,40 @@ test trace-0.0 {memory corruption in trace (Tcl Bug 484339)} {
test trace-1.1 {trace variable reads} {
unset -nocomplain x
- set info ""
+ 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} {
unset -nocomplain x
set x 123
- set info ""
+ 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} {
unset -nocomplain x
- set info ""
+ set info {}
trace add variable x read traceScalar
set x 123
set info
} {}
test trace-1.4 {trace array element reads} {
unset -nocomplain x
- set info ""
+ 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} {
unset -nocomplain x
set x(2) zzz
- set info ""
+ 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} {
unset -nocomplain x
- set info ""
+ set info {}
trace add variable x read traceArray2
proc p {} {
global x
@@ -128,7 +126,7 @@ test trace-1.6 {trace array element reads} {
} {0 willi {x 2 read}}
test trace-1.7 {trace array element reads, create element undefined if nonexistant} {
unset -nocomplain x
- set info ""
+ set info {}
trace add variable x read q
proc q {name1 name2 op} {
global info
@@ -145,21 +143,21 @@ test trace-1.7 {trace array element reads, create element undefined if nonexista
} {0 wolf {x Y read}}
test trace-1.8 {trace reads on whole arrays} {
unset -nocomplain x
- set info ""
+ 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} {
unset -nocomplain x
set x(2) zzz
- set info ""
+ 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} {
unset -nocomplain x
set x 444
- set info ""
+ set info {}
trace add variable x read traceScalar
unset x
set info
@@ -197,21 +195,21 @@ test trace-1.14 {read traces that modify the array structure} {
test trace-2.1 {trace variable writes} {
unset -nocomplain x
- set info ""
+ 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} {
unset -nocomplain x
- set info ""
+ 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} {
unset -nocomplain x
- set info ""
+ set info {}
trace add variable x write traceArray
set x(abc) qq
set info
@@ -219,7 +217,7 @@ test trace-2.3 {trace writes on whole arrays} {
test trace-2.4 {trace variable writes} {
unset -nocomplain x
set x 1234
- set info ""
+ set info {}
trace add variable x write traceScalar
set x
set info
@@ -227,7 +225,7 @@ test trace-2.4 {trace variable writes} {
test trace-2.5 {trace variable writes} {
unset -nocomplain x
set x 1234
- set info ""
+ set info {}
trace add variable x write traceScalar
unset x
set info
@@ -239,7 +237,7 @@ test trace-2.6 {trace variable writes on compiled local} {
# already indirectly tested in trace-1.7
#
unset -nocomplain x
- set info ""
+ set info {}
proc p {} {
trace add variable x write traceArray
set x(X) willy
@@ -268,7 +266,7 @@ test trace-2.7 {trace variable writes on errorInfo} -body {
test trace-3.1 {trace variable read-modify-writes} {
unset -nocomplain x
- set info ""
+ set info {}
trace add variable x read traceScalarAppend
append x 123
append x 456
@@ -277,7 +275,7 @@ test trace-3.1 {trace variable read-modify-writes} {
} {x {} read 0 123456}
test trace-3.2 {trace variable read-modify-writes} {
unset -nocomplain x
- set info ""
+ set info {}
trace add variable x {read write} traceScalarAppend
append x 123
lappend x 456
@@ -288,7 +286,7 @@ test trace-3.2 {trace variable read-modify-writes} {
test trace-4.1 {trace variable unsets} {
unset -nocomplain x
- set info ""
+ set info {}
trace add variable x unset traceScalar
unset -nocomplain x
set info
@@ -296,14 +294,14 @@ test trace-4.1 {trace variable unsets} {
test trace-4.2 {variable mustn't exist during unset trace} {
unset -nocomplain x
set x 1234
- set info ""
+ set info {}
trace add variable x unset traceScalar
unset x
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} {
unset -nocomplain x
- set info ""
+ set info {}
trace add variable x unset traceScalar
set x 44
set x
@@ -312,7 +310,7 @@ test trace-4.3 {unset traces mustn't be called during reads and writes} {
test trace-4.4 {trace unsets on array elements} {
unset -nocomplain x
set x(0) 18
- set info ""
+ set info {}
trace add variable x(1) unset traceArray
unset -nocomplain x(1)
set info
@@ -320,7 +318,7 @@ test trace-4.4 {trace unsets on array elements} {
test trace-4.5 {trace unsets on array elements} {
unset -nocomplain x
set x(1) 18
- set info ""
+ set info {}
trace add variable x(1) unset traceArray
unset x(1)
set info
@@ -328,7 +326,7 @@ test trace-4.5 {trace unsets on array elements} {
test trace-4.6 {trace unsets on array elements} {
unset -nocomplain x
set x(1) 18
- set info ""
+ set info {}
trace add variable x(1) unset traceArray
unset x
set info
@@ -336,7 +334,7 @@ test trace-4.6 {trace unsets on array elements} {
test trace-4.7 {trace unsets on whole arrays} {
unset -nocomplain x
set x(1) 18
- set info ""
+ set info {}
trace add variable x unset traceProc
unset -nocomplain x(0)
set info
@@ -346,7 +344,7 @@ test trace-4.8 {trace unsets on whole arrays} {
set x(1) 18
set x(2) 144
set x(3) 14
- set info ""
+ set info {}
trace add variable x unset traceProc
unset x(1)
set info
@@ -356,7 +354,7 @@ test trace-4.9 {trace unsets on whole arrays} {
set x(1) 18
set x(2) 144
set x(3) 14
- set info ""
+ set info {}
trace add variable x unset traceProc
unset x
set info
@@ -367,7 +365,7 @@ test trace-5.1 {array traces fire on accesses via [array]} {
unset -nocomplain x
set x(b) 2
trace add variable x array traceArray2
- set ::info ""
+ set ::info {}
array set x {a 1}
set ::info
} {x {} array}
@@ -375,7 +373,7 @@ test trace-5.2 {array traces do not fire on normal accesses} {
unset -nocomplain x
set x(b) 2
trace add variable x array traceArray2
- set ::info ""
+ set ::info {}
set x(a) 1
set x(b) $x(a)
set ::info
@@ -383,7 +381,7 @@ test trace-5.2 {array traces do not fire on normal accesses} {
test trace-5.3 {array traces do not outlive variable} {
unset -nocomplain x
trace add variable x array traceArray2
- set ::info ""
+ set ::info {}
set x(a) 1
unset x
array set x {a 1}
@@ -405,14 +403,14 @@ test trace-5.6 {array traces don't fire on scalar variables} {
unset -nocomplain x
set x foo
trace add variable x array traceArray2
- set ::info ""
+ set ::info {}
catch {array set x {a 1}}
set ::info
} {}
test trace-5.7 {array traces fire for undefined variables} {
unset -nocomplain x
trace add variable x array traceArray2
- set ::info ""
+ set ::info {}
array set x {a 1}
set ::info
} {x {} array}
@@ -426,7 +424,7 @@ test trace-5.8 {array traces fire for undefined variables} {
test trace-6.1 {multiple ops traced at once} {
unset -nocomplain x
- set info ""
+ set info {}
trace add variable x {read write unset} traceProc
catch {set x}
set x 22
@@ -437,7 +435,7 @@ test trace-6.1 {multiple ops traced at once} {
} {x {} read x {} write x {} read x {} write x {} unset}
test trace-6.2 {multiple ops traced on array element} {
unset -nocomplain x
- set info ""
+ set info {}
trace add variable x(0) {read write unset} traceProc
catch {set x(0)}
set x(0) 22
@@ -449,7 +447,7 @@ test trace-6.2 {multiple ops traced on array element} {
} {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} {
unset -nocomplain x
- set info ""
+ set info {}
trace add variable x {read write unset} traceProc
catch {set x(0)}
set x(0) 22
@@ -464,7 +462,7 @@ test trace-6.3 {multiple ops traced on whole array} {
test trace-7.1 {order of invocation of traces} {
unset -nocomplain x
- set info ""
+ set info {}
trace add variable x read "traceTag 1"
trace add variable x read "traceTag 2"
trace add variable x read "traceTag 3"
@@ -476,7 +474,7 @@ test trace-7.1 {order of invocation of traces} {
test trace-7.2 {order of invocation of traces} {
unset -nocomplain x
set x(0) 44
- set info ""
+ set info {}
trace add variable x(0) read "traceTag 1"
trace add variable x(0) read "traceTag 2"
trace add variable x(0) read "traceTag 3"
@@ -486,7 +484,7 @@ test trace-7.2 {order of invocation of traces} {
test trace-7.3 {order of invocation of traces} {
unset -nocomplain x
set x(0) 44
- set info ""
+ set info {}
trace add variable x(0) read "traceTag 1"
trace add variable x read "traceTag A1"
trace add variable x(0) read "traceTag 2"
@@ -502,7 +500,7 @@ test trace-7.3 {order of invocation of traces} {
test trace-8.1 {error returns from traces} {
unset -nocomplain x
set x 123
- set info ""
+ set info {}
trace add variable x read "traceTag 1"
trace add variable x read traceError
list [catch {set x} msg] $msg $info
@@ -510,7 +508,7 @@ test trace-8.1 {error returns from traces} {
test trace-8.2 {error returns from traces} {
unset -nocomplain x
set x 123
- set info ""
+ set info {}
trace add variable x write "traceTag 1"
trace add variable x write traceError
list [catch {set x 44} msg] $msg $info
@@ -518,14 +516,14 @@ test trace-8.2 {error returns from traces} {
test trace-8.3 {error returns from traces} {
unset -nocomplain x
set x 123
- set info ""
+ 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} {
unset -nocomplain x
set x 123
- set info ""
+ set info {}
trace add variable x unset "traceTag 1"
trace add variable x unset traceError
list [catch {unset x} msg] $msg $info
@@ -533,7 +531,7 @@ test trace-8.4 {error returns from traces} {
test trace-8.5 {error returns from traces} {
unset -nocomplain x
set x(0) 123
- set info ""
+ set info {}
trace add variable x(0) read "traceTag 1"
trace add variable x read "traceTag 2"
trace add variable x read traceError
@@ -565,7 +563,7 @@ test trace-8.8 {error returns from traces} {
# it should *never* fail.
#
# Adapted from Bug #219393 reported by Don Porter.
- catch {rename ::foo ""}
+ catch {rename ::foo {}}
proc foo {old args} {
trace remove variable ::x write [list foo $old]
trace add variable ::x write [list foo $::x]
@@ -587,31 +585,31 @@ test trace-8.8 {error returns from traces} {
test trace-9.1 {be sure variable is unset before trace is called} {
unset -nocomplain x
set x 33
- set info ""
- trace add variable x unset {traceCheck {uplevel set x}}
+ set info {}
+ 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} {
unset -nocomplain x
set x 33
- set info ""
- trace add variable x unset {traceCheck {uplevel set x 22}}
+ set info {}
+ 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} {
unset -nocomplain x
set x 33
- set info ""
- trace add variable x unset {traceCheck {uplevel trace info variable x}}
+ set info {}
+ 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} {
unset -nocomplain x
set x 33
- set info ""
+ set info {}
trace add variable x unset {traceCheck {global x; trace add variable x unset traceProc}}
unset x
concat $info [trace info variable x]
@@ -620,23 +618,23 @@ test trace-9.4 {set new trace during unset trace} {
test trace-10.1 {make sure array elements are unset before traces are called} {
unset -nocomplain x
set x(0) 33
- set info ""
- trace add variable x(0) unset {traceCheck {uplevel set x(0)}}
+ set info {}
+ 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} {
unset -nocomplain x
set x(0) 33
- set info ""
- trace add variable x(0) unset {traceCheck {uplevel set x(0) zzz}}
+ set info {}
+ 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} {
unset -nocomplain x
set x(0) 33
- set info ""
+ set info {}
trace add variable x(0) unset {traceCheck {global x; trace info variable x(0)}}
unset x(0)
set info
@@ -644,8 +642,8 @@ test trace-10.3 {array elements are unset before traces are called} {
test trace-10.4 {set new array element trace during unset trace} {
unset -nocomplain x
set x(0) 33
- set info ""
- trace add variable x(0) unset {traceCheck {uplevel {trace add variable x(0) read {}}}}
+ set info {}
+ 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 {}}}
@@ -653,32 +651,32 @@ test trace-10.4 {set new array element trace during unset trace} {
test trace-11.1 {make sure arrays are unset before traces are called} {
unset -nocomplain x
set x(0) 33
- set info ""
- trace add variable x unset {traceCheck {uplevel set x(0)}}
+ set info {}
+ 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} {
unset -nocomplain x
set x(y) 33
- set info ""
- trace add variable x unset {traceCheck {uplevel set x(y) 22}}
+ set info {}
+ 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} {
unset -nocomplain x
set x(y) 33
- set info ""
- trace add variable x unset {traceCheck {uplevel array exists x}}
+ set info {}
+ 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} {
unset -nocomplain x
set x(y) 33
- set info ""
- set cmd {traceCheck {uplevel {trace info variable x}}}
+ set info {}
+ set cmd {traceCheck {uplevel 1 {trace info variable x}}}
trace add variable x unset $cmd
unset x
set info
@@ -686,7 +684,7 @@ test trace-11.4 {make sure arrays are unset before traces are called} {
test trace-11.5 {set new array trace during unset trace} {
unset -nocomplain x
set x(y) 33
- set info ""
+ set info {}
trace add variable x unset {traceCheck {global x; trace add variable x read {}}}
unset x
concat $info [trace info variable x]
@@ -694,7 +692,7 @@ test trace-11.5 {set new array trace during unset trace} {
test trace-11.6 {create scalar during array unset trace} {
unset -nocomplain x
set x(y) 33
- set info ""
+ set info {}
trace add variable x unset {traceCheck {global x; set x 44}}
unset x
concat $info [list [catch {set x} msg] $msg]
@@ -704,39 +702,39 @@ test trace-11.6 {create scalar during array unset trace} {
test trace-12.1 {creating array when setting variable traces} {
unset -nocomplain x
- set info ""
+ 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} {
unset -nocomplain x
- set info ""
+ 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} {
unset -nocomplain x
- set info ""
+ 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} {
unset -nocomplain x
- set info ""
+ 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} {
unset -nocomplain x
- set info ""
+ 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} {
unset -nocomplain x
- set info ""
+ set info {}
trace add variable x write traceProc
set x(0) 22
set info
@@ -764,7 +762,7 @@ test trace-13.1 {delete one trace from another} {
}
unset -nocomplain x
set x 44
- set info ""
+ set info {}
trace add variable x read {traceTag 1}
trace add variable x read {traceTag 2}
trace add variable x read {traceTag 3}
@@ -896,7 +894,7 @@ foreach type {variable command execution} err $errs abbvlist $abbvs {
} [list 1 "bad operation list \"\": must be one or more of $err"]
}
}
-rename x ""
+rename x {}
test trace-14.7 {trace command, "trace variable" errors} {
list [catch {trace variable} msg] $msg
@@ -914,15 +912,16 @@ test trace-14.11 {trace command, "trace variable" errors} {
list [catch {trace variable x y z} msg] $msg
} [list 1 "bad operations \"y\": should be one or more of rwua"]
+
test trace-14.12 {trace command ("remove variable" option)} {
unset -nocomplain x
- set info ""
+ set info {}
trace add variable x write traceProc
trace remove variable x write traceProc
} {}
test trace-14.13 {trace command ("remove variable" option)} {
unset -nocomplain x
- set info ""
+ set info {}
trace add variable x write traceProc
trace remove variable x write traceProc
set x 12345
@@ -930,7 +929,7 @@ test trace-14.13 {trace command ("remove variable" option)} {
} {}
test trace-14.14 {trace command ("remove variable" option)} {
unset -nocomplain x
- set info ""
+ set info {}
trace add variable x write {traceTag 1}
trace add variable x write traceProc
trace add variable x write {traceTag 2}
@@ -945,7 +944,7 @@ test trace-14.14 {trace command ("remove variable" option)} {
} {2 x {} write 1 2 1 2}
test trace-14.15 {trace command ("remove variable" option)} {
unset -nocomplain x
- set info ""
+ set info {}
trace add variable x write {traceTag 1}
trace remove variable x write non_existent
set x 12345
@@ -983,7 +982,7 @@ test trace-14.20 {trace command ("info variable" option)} {
test trace-15.1 {long trace command} {
unset -nocomplain x
- set info ""
+ 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 \
with such long arguments by malloc-ing space. One possibility \
@@ -1009,7 +1008,7 @@ test trace-15.2 {long trace command result to ignore} {
test trace-15.3 {special list-handling in trace commands} {
unset -nocomplain "x y z"
set "x y z(a\n\{)" 44
- set info ""
+ set info {}
trace add variable "x y z(a\n\{)" write traceProc
set "x y z(a\n\{)" 33
set info
@@ -1040,7 +1039,7 @@ proc traceAppend {string name1 name2 op} {
test trace-16.1 {unsets during read traces} {
unset -nocomplain y
set y 1234
- set info ""
+ set info {}
trace add variable y read {traceUnset y}
trace add variable y unset {traceAppend unset}
lappend info [catch {set y} msg] $msg
@@ -1048,49 +1047,49 @@ test trace-16.1 {unsets during read traces} {
test trace-16.2 {unsets during read traces} {
unset -nocomplain y
set y(0) 1234
- set info ""
+ 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} {
unset -nocomplain y
set y(0) 1234
- set info ""
+ 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} {
unset -nocomplain y
set y 1234
- set info ""
+ 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} {
unset -nocomplain y
set y(0) 1234
- set info ""
+ 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} {
unset -nocomplain y
set y(0) 1234
- set info ""
+ 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} {
unset -nocomplain y
set y(0) 1234
- set info ""
+ 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} {
unset -nocomplain y
set y 1234
- set info ""
+ set info {}
trace add variable y write {traceUnset y}
trace add variable y unset {traceAppend unset}
lappend info [catch {set y xxx} msg] $msg
@@ -1098,91 +1097,91 @@ test trace-16.8 {unsets during write traces} {
test trace-16.9 {unsets during write traces} {
unset -nocomplain y
set y(0) 1234
- set info ""
+ 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} {
unset -nocomplain y
set y(0) 1234
- set info ""
+ 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} {
unset -nocomplain y
set y 1234
- set info ""
+ 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} {
unset -nocomplain y
set y(0) 1234
- set info ""
+ 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} {
unset -nocomplain y
set y(0) 1234
- set info ""
+ 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} {
unset -nocomplain y
set y(0) 1234
- set info ""
+ 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} {
unset -nocomplain y
set y 1234
- set info ""
+ 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} {
unset -nocomplain y
set y(0) 1234
- set info ""
+ 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} {
unset -nocomplain y
set y(0) 1234
- set info ""
+ 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} {
unset -nocomplain y
set y 1234
- set info ""
+ 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} {
unset -nocomplain y
set y(0) 1234
- set info ""
+ 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} {
unset -nocomplain y
set y(0) 1234
- set info ""
+ 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} {
unset -nocomplain y
set y 1234
- set info ""
+ set info {}
trace add variable y read {traceAppend first}
trace add variable y read {traceUnset y}
trace add variable y read {traceAppend third}
@@ -1192,7 +1191,7 @@ test trace-16.21 {unsets cancelling traces} {
test trace-16.22 {unsets cancelling traces} {
unset -nocomplain y
set y(0) 1234
- set info ""
+ set info {}
trace add variable y(0) read {traceAppend first}
trace add variable y(0) read {traceUnset y}
trace add variable y(0) read {traceAppend third}
@@ -1204,7 +1203,7 @@ test trace-16.22 {unsets cancelling traces} {
test trace-17.1 {trace doesn't prevent unset errors} {
unset -nocomplain x
- set info ""
+ 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}}
@@ -1216,7 +1215,7 @@ test trace-17.2 {traced variables must survive procedure exits} {
} {{write traceProc}}
test trace-17.3 {traced variables must survive procedure exits} {
unset -nocomplain x
- set info ""
+ set info {}
proc p1 {} {global x; trace add variable x write traceProc}
p1
set x 44
@@ -1228,8 +1227,8 @@ 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}]}}}
- set info ""
+ proc p2 {z} {trace add variable z unset {traceCheck {lsort [uplevel 1 {info vars}]}}}
+ set info {}
p1 foo bar
set info
} {0 {a x y}}
@@ -1259,9 +1258,9 @@ test trace-18.4 {namespace delete / trace vdelete combo, Bug \#1338280} {
global info
append info [catch {set ::$vtraced}][llength [info vars ::ref::*]]
}
- set info ""
+ set info {}
namespace delete ::ref
- rename doTrace ""
+ rename doTrace {}
set info
} 1110
@@ -1279,16 +1278,17 @@ test trace-19.0.2 {trace add command (command existence in ns)} {
list [catch {trace add command nosuchns::nosuchname rename traceCommand} msg] $msg
} {1 {unknown command "nosuchns::nosuchname"}}
+
test trace-19.1 {trace add command (rename option)} {
proc foo {} {}
- catch {rename bar ""}
+ catch {rename bar {}}
trace add command foo rename traceCommand
rename foo bar
set info
} {::foo ::bar rename}
test trace-19.2 {traces stick with renamed commands} {
proc foo {} {}
- catch {rename bar ""}
+ catch {rename bar {}}
trace add command foo rename traceCommand
rename foo bar
rename bar foo
@@ -1301,14 +1301,14 @@ test trace-19.2.1 {trace add command rename trace exists} {
} {{rename traceCommand}}
test trace-19.3 {command rename traces don't fire on command deletion} {
proc foo {} {}
- set info ""
+ set info {}
trace add command foo rename traceCommand
- rename foo ""
+ rename foo {}
set info
} {}
test trace-19.4 {trace add command rename doesn't trace recreated commands} {
proc foo {} {}
- catch {rename bar ""}
+ catch {rename bar {}}
trace add command foo rename traceCommand
proc foo {} {}
rename foo bar
@@ -1341,17 +1341,17 @@ test trace-19.9 {trace add command rename back into namespace} {
set info
} {::tcbar ::tc::tcfoo rename}
test trace-19.10 {trace add command failed rename doesn't trigger trace} {
- set info ""
+ set info {}
proc foo {} {}
proc bar {} {}
trace add command foo {rename delete} traceCommand
catch {rename foo bar}
set info
} {}
-catch {rename foo ""}
-catch {rename bar ""}
+catch {rename foo {}}
+catch {rename bar {}}
test trace-19.11 {trace add command qualifies when renamed in namespace} {
- set info ""
+ set info {}
namespace eval tc {rename tcfoo tcbar}
set info
} {::tc::tcfoo ::tc::tcbar rename}
@@ -1365,7 +1365,7 @@ test trace-20.1 {trace add command (delete option)} {
set info
} {::foo {} delete}
test trace-20.2 {trace add command delete doesn't trace recreated commands} {
- set info ""
+ set info {}
proc foo {} {}
rename foo ""
set info
@@ -1386,28 +1386,28 @@ test trace-20.3.1 {trace add command delete trace info} {
trace info command foo
} {}
test trace-20.4 {trace add command rename followed by delete} {
- set infotemp ""
+ set infotemp {}
proc foo {} {}
trace add command foo {rename delete} traceCommand
rename foo bar
lappend infotemp $info
- rename bar ""
+ rename bar {}
lappend infotemp $info
set info $infotemp
unset infotemp
set info
} {{::foo ::bar rename} {::bar {} delete}}
-catch {rename foo ""}
-catch {rename bar ""}
+catch {rename foo {}}
+catch {rename bar {}}
test trace-20.5 {trace add command rename and delete} {
- set infotemp ""
- set info ""
+ set infotemp {}
+ set info {}
proc foo {} {}
trace add command foo {rename delete} traceCommand
rename foo bar
lappend infotemp $info
- rename bar ""
+ rename bar {}
lappend infotemp $info
set info $infotemp
unset infotemp
@@ -1420,12 +1420,12 @@ test trace-20.6 {trace add command rename and delete in subinterp} {
$tc eval [list proc $p [info args $p] [info body $p]]
}
$tc eval [list set infotemp {}]
- $tc eval [list set info ""]
+ $tc eval [list set info {}]
$tc eval [list proc foo {} {}]
$tc eval [list trace add command foo {rename delete} traceCommand]
$tc eval [list rename foo bar]
$tc eval {lappend infotemp $info}
- $tc eval [list rename bar ""]
+ $tc eval [list rename bar {}]
$tc eval {lappend infotemp $info}
$tc eval {set info $infotemp}
$tc eval [list unset infotemp]
@@ -1438,7 +1438,7 @@ test trace-20.6 {trace add command rename and delete in subinterp} {
# but interp deletion means there is no interp to evaluate
# the trace in.
test trace-20.7 {trace add command delete in subinterp while being deleted} {
- set info ""
+ set info {}
set tc [interp create]
interp alias $tc traceCommand {} traceCommand
$tc eval [list proc foo {} {}]
@@ -1459,54 +1459,54 @@ proc traceCmddelete {cmd old new op} {
rename $old ""
}
test trace-20.8 {trace delete while trace is active} {
- set info ""
+ set info {}
proc foo {} {}
- catch {rename bar ""}
+ catch {rename bar {}}
trace add command foo {rename delete} [list traceDelete foo]
rename foo bar
list [set info] [trace info command bar]
} {{::foo ::bar rename} {}}
test trace-20.9 {rename trace deletes command} {
- set info ""
+ set info {}
proc foo {} {}
- catch {rename bar ""}
- catch {rename someothername ""}
+ catch {rename bar {}}
+ catch {rename someothername {}}
trace add command foo rename [list traceCmddelete foo]
rename foo bar
list [info commands foo] [info commands bar] [info commands someothername]
} {{} {} {}}
test trace-20.10 {rename trace renames command} {
- set info ""
+ set info {}
proc foo {} {}
- catch {rename bar ""}
- catch {rename someothername ""}
+ catch {rename bar {}}
+ catch {rename someothername {}}
trace add command foo rename [list traceCmdrename foo]
rename foo bar
set info [list [info commands foo] [info commands bar] [info commands someothername]]
- rename someothername ""
+ rename someothername {}
set info
} {{} {} someothername}
test trace-20.11 {delete trace deletes command} {
- set info ""
+ set info {}
proc foo {} {}
- catch {rename bar ""}
- catch {rename someothername ""}
+ catch {rename bar {}}
+ catch {rename someothername {}}
trace add command foo delete [list traceCmddelete foo]
- rename foo ""
+ rename foo {}
list [info commands foo] [info commands bar] [info commands someothername]
} {{} {} {}}
test trace-20.12 {delete trace renames command} {
- set info ""
+ set info {}
proc foo {} {}
- catch {rename bar ""}
- catch {rename someothername ""}
+ catch {rename bar {}}
+ catch {rename someothername {}}
trace add command foo delete [list traceCmdrename foo]
rename foo bar
- rename bar ""
+ rename bar {}
# None of these should exist.
list [info commands foo] [info commands bar] [info commands someothername]
} {{} {} {}}
@@ -1514,37 +1514,38 @@ test trace-20.12 {delete trace renames command} {
test trace-20.13 {rename trace discards result [Bug 1355342]} {
proc foo {} {}
trace add command foo rename {set w Aha!;#}
- list [rename foo bar] [rename bar ""]
+ list [rename foo bar] [rename bar {}]
} {{} {}}
test trace-20.14 {rename trace discards error result [Bug 1355342]} {
proc foo {} {}
trace add command foo rename {error}
- list [rename foo bar] [rename bar ""]
+ list [rename foo bar] [rename bar {}]
} {{} {}}
test trace-20.15 {delete trace discards result [Bug 1355342]} {
proc foo {} {}
trace add command foo delete {set w Aha!;#}
- rename foo ""
+ rename foo {}
} {}
test trace-20.16 {delete trace discards error result [Bug 1355342]} {
proc foo {} {}
trace add command foo delete {error}
- rename foo ""
+ rename foo {}
} {}
+
proc foo {b} { set a $b }
+
# Delete arrays when done, so they can be re-used as scalars
# elsewhere.
-unset -nocomplain x
-unset -nocomplain 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).
-catch {rename foobar ""}
-catch {rename foo ""}
-catch {rename bar ""}
+catch {rename foobar {}}
+catch {rename foo {}}
+catch {rename bar {}}
proc foo {a} {
set b $a
@@ -1556,7 +1557,7 @@ proc traceExecute {args} {
}
test trace-21.1 {trace execution: enter} {
- set info ""
+ set info {}
trace add execution foo enter [list traceExecute foo]
foo 1
trace remove execution foo enter [list traceExecute foo]
@@ -1564,7 +1565,7 @@ test trace-21.1 {trace execution: enter} {
} {{foo {foo 1} enter}}
test trace-21.2 {trace exeuction: leave} {
- set info ""
+ set info {}
trace add execution foo leave [list traceExecute foo]
foo 2
trace remove execution foo leave [list traceExecute foo]
@@ -1572,7 +1573,7 @@ test trace-21.2 {trace exeuction: leave} {
} {{foo {foo 2} 0 2 leave}}
test trace-21.3 {trace exeuction: enter, leave} {
- set info ""
+ set info {}
trace add execution foo {enter leave} [list traceExecute foo]
foo 3
trace remove execution foo {enter leave} [list traceExecute foo]
@@ -1580,7 +1581,7 @@ test trace-21.3 {trace exeuction: enter, leave} {
} {{foo {foo 3} enter} {foo {foo 3} 0 3 leave}}
test trace-21.4 {trace execution: enter, leave, enterstep} {
- set info ""
+ set info {}
trace add execution foo {enter leave enterstep} [list traceExecute foo]
foo 3
trace remove execution foo {enter leave enterstep} [list traceExecute foo]
@@ -1588,7 +1589,7 @@ test trace-21.4 {trace execution: enter, leave, enterstep} {
} {{foo {foo 3} enter} {foo {set b 3} enterstep} {foo {foo 3} 0 3 leave}}
test trace-21.5 {trace execution: enter, leave, enterstep, leavestep} {
- set info ""
+ set info {}
trace add execution foo {enter leave enterstep leavestep} [list traceExecute foo]
foo 3
trace remove execution foo {enter leave enterstep leavestep} [list traceExecute foo]
@@ -1596,7 +1597,7 @@ test trace-21.5 {trace execution: enter, leave, enterstep, leavestep} {
} {{foo {foo 3} enter} {foo {set b 3} enterstep} {foo {set b 3} 0 3 leavestep} {foo {foo 3} 0 3 leave}}
test trace-21.6 {trace execution: enterstep, leavestep} {
- set info ""
+ set info {}
trace add execution foo {enterstep leavestep} [list traceExecute foo]
foo 3
trace remove execution foo {enterstep leavestep} [list traceExecute foo]
@@ -1604,7 +1605,7 @@ test trace-21.6 {trace execution: enterstep, leavestep} {
} {{foo {set b 3} enterstep} {foo {set b 3} 0 3 leavestep}}
test trace-21.7 {trace execution: enterstep} {
- set info ""
+ set info {}
trace add execution foo {enterstep} [list traceExecute foo]
foo 3
trace remove execution foo {enterstep} [list traceExecute foo]
@@ -1612,7 +1613,7 @@ test trace-21.7 {trace execution: enterstep} {
} {{foo {set b 3} enterstep}}
test trace-21.8 {trace execution: leavestep} {
- set info ""
+ set info {}
trace add execution foo {leavestep} [list traceExecute foo]
foo 3
trace remove execution foo {leavestep} [list traceExecute foo]
@@ -1660,22 +1661,22 @@ test trace-21.11 {trace execution and alias} -setup {
} -body {
lappend res [namespace eval ::a y]
trace add execution ::x enter {
- rename ::x ""
+ rename ::x {}
proc ::x {} {return ::}
#}
lappend res [namespace eval ::a y]
} -cleanup {
namespace delete a
- rename ::x ""
+ rename ::x {}
} -result {:: ::}
proc factorial {n} {
- if {$n != 1} { return [expr {$n * [factorial [expr {$n - 1}]]}] }
+ if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }
return 1
}
test trace-22.1 {recursive(1) trace execution: enter} {
- set info ""
+ set info {}
trace add execution factorial {enter} [list traceExecute factorial]
factorial 1
trace remove execution factorial {enter} [list traceExecute factorial]
@@ -1683,7 +1684,7 @@ test trace-22.1 {recursive(1) trace execution: enter} {
} {{factorial {factorial 1} enter}}
test trace-22.2 {recursive(2) trace execution: enter} {
- set info ""
+ set info {}
trace add execution factorial {enter} [list traceExecute factorial]
factorial 2
trace remove execution factorial {enter} [list traceExecute factorial]
@@ -1691,7 +1692,7 @@ test trace-22.2 {recursive(2) trace execution: enter} {
} {{factorial {factorial 2} enter} {factorial {factorial 1} enter}}
test trace-22.3 {recursive(3) trace execution: enter} {
- set info ""
+ set info {}
trace add execution factorial {enter} [list traceExecute factorial]
factorial 3
trace remove execution factorial {enter} [list traceExecute factorial]
@@ -1699,78 +1700,78 @@ test trace-22.3 {recursive(3) trace execution: enter} {
} {{factorial {factorial 3} enter} {factorial {factorial 2} enter} {factorial {factorial 1} enter}}
test trace-23.1 {recursive(1) trace execution: enter, leave, enterstep, leavestep} {
- set info ""
+ set info {}
trace add execution factorial {enter leave enterstep leavestep} [list traceExecute]
factorial 1
trace remove execution factorial {enter leave enterstep leavestep} [list traceExecute]
join $info "\n"
} {{factorial 1} enter
-{if {$n != 1} { return [expr {$n * [factorial [expr {$n - 1}]]}] }} enterstep
-{if {$n != 1} { return [expr {$n * [factorial [expr {$n - 1}]]}] }} 0 {} leavestep
+{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} enterstep
+{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} 0 {} leavestep
{return 1} enterstep
{return 1} 2 1 leavestep
{factorial 1} 0 1 leave}
test trace-23.2 {recursive(2) trace execution: enter, leave, enterstep, leavestep} {
- set info ""
+ set info {}
trace add execution factorial {enter leave enterstep leavestep} [list traceExecute]
factorial 2
trace remove execution factorial {enter leave enterstep leavestep} [list traceExecute]
join $info "\n"
} {{factorial 2} enter
-{if {$n != 1} { return [expr {$n * [factorial [expr {$n - 1}]]}] }} enterstep
-{expr {$n * [factorial [expr {$n - 1}]]}} enterstep
-{expr {$n - 1}} enterstep
-{expr {$n - 1}} 0 1 leavestep
+{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} enterstep
+{expr {$n * [factorial [expr {$n -1 }]]}} enterstep
+{expr {$n -1 }} enterstep
+{expr {$n -1 }} 0 1 leavestep
{factorial 1} enterstep
{factorial 1} enter
-{if {$n != 1} { return [expr {$n * [factorial [expr {$n - 1}]]}] }} enterstep
-{if {$n != 1} { return [expr {$n * [factorial [expr {$n - 1}]]}] }} 0 {} leavestep
+{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} enterstep
+{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} 0 {} leavestep
{return 1} enterstep
{return 1} 2 1 leavestep
{factorial 1} 0 1 leave
{factorial 1} 0 1 leavestep
-{expr {$n * [factorial [expr {$n - 1}]]}} 0 2 leavestep
+{expr {$n * [factorial [expr {$n -1 }]]}} 0 2 leavestep
{return 2} enterstep
{return 2} 2 2 leavestep
-{if {$n != 1} { return [expr {$n * [factorial [expr {$n - 1}]]}] }} 2 2 leavestep
+{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} 2 2 leavestep
{factorial 2} 0 2 leave}
test trace-23.3 {recursive(3) trace execution: enter, leave, enterstep, leavestep} {
- set info ""
+ set info {}
trace add execution factorial {enter leave enterstep leavestep} [list traceExecute]
factorial 3
trace remove execution factorial {enter leave enterstep leavestep} [list traceExecute]
join $info "\n"
} {{factorial 3} enter
-{if {$n != 1} { return [expr {$n * [factorial [expr {$n - 1}]]}] }} enterstep
-{expr {$n * [factorial [expr {$n - 1}]]}} enterstep
-{expr {$n - 1}} enterstep
-{expr {$n - 1}} 0 2 leavestep
+{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} enterstep
+{expr {$n * [factorial [expr {$n -1 }]]}} enterstep
+{expr {$n -1 }} enterstep
+{expr {$n -1 }} 0 2 leavestep
{factorial 2} enterstep
{factorial 2} enter
-{if {$n != 1} { return [expr {$n * [factorial [expr {$n - 1}]]}] }} enterstep
-{expr {$n * [factorial [expr {$n - 1}]]}} enterstep
-{expr {$n - 1}} enterstep
-{expr {$n - 1}} 0 1 leavestep
+{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} enterstep
+{expr {$n * [factorial [expr {$n -1 }]]}} enterstep
+{expr {$n -1 }} enterstep
+{expr {$n -1 }} 0 1 leavestep
{factorial 1} enterstep
{factorial 1} enter
-{if {$n != 1} { return [expr {$n * [factorial [expr {$n - 1}]]}] }} enterstep
-{if {$n != 1} { return [expr {$n * [factorial [expr {$n - 1}]]}] }} 0 {} leavestep
+{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} enterstep
+{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} 0 {} leavestep
{return 1} enterstep
{return 1} 2 1 leavestep
{factorial 1} 0 1 leave
{factorial 1} 0 1 leavestep
-{expr {$n * [factorial [expr {$n - 1}]]}} 0 2 leavestep
+{expr {$n * [factorial [expr {$n -1 }]]}} 0 2 leavestep
{return 2} enterstep
{return 2} 2 2 leavestep
-{if {$n != 1} { return [expr {$n * [factorial [expr {$n - 1}]]}] }} 2 2 leavestep
+{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} 2 2 leavestep
{factorial 2} 0 2 leave
{factorial 2} 0 2 leavestep
-{expr {$n * [factorial [expr {$n - 1}]]}} 0 6 leavestep
+{expr {$n * [factorial [expr {$n -1 }]]}} 0 6 leavestep
{return 6} enterstep
{return 6} 2 6 leavestep
-{if {$n != 1} { return [expr {$n * [factorial [expr {$n - 1}]]}] }} 2 6 leavestep
+{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} 2 6 leavestep
{factorial 3} 0 6 leave}
proc traceDelete {cmd args} {
@@ -1780,42 +1781,42 @@ proc traceDelete {cmd args} {
}
test trace-24.1 {delete trace during enter trace} {
- set info ""
+ set info {}
trace add execution foo enter [list traceDelete foo]
foo 1
list $info [catch {trace info execution foo} res] $res
} {{{foo 1} enter} 0 {}}
test trace-24.2 {delete trace during leave trace} {
- set info ""
+ set info {}
trace add execution foo leave [list traceDelete foo]
foo 1
list $info [catch {trace info execution foo} res] $res
} {{{foo 1} 0 1 leave} 0 {}}
test trace-24.3 {delete trace during enter-leave trace} {
- set info ""
+ set info {}
trace add execution foo {enter leave} [list traceDelete foo]
foo 1
list $info [catch {trace info execution foo} res] $res
} {{{foo 1} enter} 0 {}}
test trace-24.4 {delete trace during all exec traces} {
- set info ""
+ set info {}
trace add execution foo {enter leave enterstep leavestep} [list traceDelete foo]
foo 1
list $info [catch {trace info execution foo} res] $res
} {{{foo 1} enter} 0 {}}
test trace-24.5 {delete trace during all exec traces except enter} {
- set info ""
+ set info {}
trace add execution foo {leave enterstep leavestep} [list traceDelete foo]
foo 1
list $info [catch {trace info execution foo} res] $res
} {{{set b 1} enterstep} 0 {}}
proc traceDelete {cmd args} {
- rename $cmd ""
+ rename $cmd {}
global info
set info $args
}
@@ -1825,7 +1826,7 @@ proc foo {a} {
}
test trace-25.1 {delete command during enter trace} {
- set info ""
+ set info {}
trace add execution foo enter [list traceDelete foo]
catch {foo 1} err
list $err $info [catch {trace info execution foo} res] $res
@@ -1836,7 +1837,7 @@ proc foo {a} {
}
test trace-25.2 {delete command during leave trace} {
- set info ""
+ set info {}
trace add execution foo leave [list traceDelete foo]
foo 1
list $info [catch {trace info execution foo} res] $res
@@ -1847,7 +1848,7 @@ proc foo {a} {
}
test trace-25.3 {delete command during enter then leave trace} {
- set info ""
+ set info {}
trace add execution foo enter [list traceDelete foo]
trace add execution foo leave [list traceDelete foo]
catch {foo 1} err
@@ -1865,7 +1866,7 @@ proc traceExecute2 {args} {
# This shows the peculiar consequences of having two traces
# at the same time: as well as tracing the procedure you want
test trace-25.4 {order dependencies of two enter traces} {
- set info ""
+ set info {}
trace add execution foo enter [list traceExecute traceExecute]
trace add execution foo enter [list traceExecute2 traceExecute2]
catch {foo 1} err
@@ -1878,7 +1879,7 @@ traceExecute {foo 1} enter
}
test trace-25.5 {order dependencies of two step traces} {
- set info ""
+ set info {}
trace add execution foo enterstep [list traceExecute traceExecute]
trace add execution foo enterstep [list traceExecute2 traceExecute2]
catch {foo 1} err
@@ -1902,7 +1903,7 @@ proc tracePostExecute2 {args} {
}
test trace-25.6 {order dependencies of two leave traces} {
- set info ""
+ set info {}
trace add execution foo leave [list tracePostExecute tracePostExecute]
trace add execution foo leave [list tracePostExecute2 tracePostExecute2]
catch {foo 1} err
@@ -1915,7 +1916,7 @@ tracePostExecute2 {foo 1} 0 leave
}
test trace-25.7 {order dependencies of two leavestep traces} {
- set info ""
+ set info {}
trace add execution foo leavestep [list tracePostExecute tracePostExecute]
trace add execution foo leavestep [list tracePostExecute2 tracePostExecute2]
catch {foo 1} err
@@ -1932,13 +1933,13 @@ proc foo {a} {
}
proc traceDelete {cmd args} {
- rename $cmd ""
+ rename $cmd {}
global info
set info $args
}
test trace-25.8 {delete command during enter leave and enter/leave-step traces} {
- set info ""
+ set info {}
trace add execution foo enter [list traceDelete foo]
trace add execution foo leave [list traceDelete foo]
trace add execution foo enterstep [list traceDelete foo]
@@ -1952,7 +1953,7 @@ proc foo {a} {
}
test trace-25.9 {delete command during enter leave and leavestep traces} {
- set info ""
+ set info {}
trace add execution foo enter [list traceDelete foo]
trace add execution foo leave [list traceDelete foo]
trace add execution foo leavestep [list traceDelete foo]
@@ -1965,7 +1966,7 @@ proc foo {a} {
}
test trace-25.10 {delete command during leave and leavestep traces} {
- set info ""
+ set info {}
trace add execution foo leave [list traceDelete foo]
trace add execution foo leavestep [list traceDelete foo]
catch {foo 1} err
@@ -1977,7 +1978,7 @@ proc foo {a} {
}
test trace-25.11 {delete command during enter and enterstep traces} {
- set info ""
+ set info {}
trace add execution foo enter [list traceDelete foo]
trace add execution foo enterstep [list traceDelete foo]
catch {foo 1} err
@@ -1988,7 +1989,7 @@ test trace-26.1 {trace targetCmd when invoked through an alias} {
proc foo {args} {
set b $args
}
- set info ""
+ set info {}
trace add execution foo enter [list traceExecute foo]
interp alias {} bar {} foo 1
bar 2
@@ -1999,7 +2000,7 @@ test trace-26.2 {trace targetCmd when invoked through an alias} {
proc foo {args} {
set b $args
}
- set info ""
+ set info {}
trace add execution foo enter [list traceExecute foo]
interp create child
interp alias child bar {} foo 1
@@ -2010,7 +2011,7 @@ test trace-26.2 {trace targetCmd when invoked through an alias} {
} {{foo {foo 1 2} enter}}
test trace-27.1 {memory leak in rename trace (604609)} {
- catch {rename bar ""}
+ catch {rename bar {}}
proc foo {} {error foo}
trace add command foo rename {rename foo "" ;#}
rename foo bar
@@ -2026,15 +2027,16 @@ test trace-27.3 {command trace info nonsense} {
list [catch {trace info command thisdoesntexist} res] $res
} {1 {unknown command "thisdoesntexist"}}
+
test trace-28.1 {enterstep and leavestep traces with update idletasks (615043)} {
- catch {rename foo ""}
+ catch {rename foo {}}
proc foo {} {
set a 1
update idletasks
set b 1
}
- set info ""
+ set info {}
trace add execution foo {enter enterstep leavestep leave} \
[list traceExecute foo]
update
@@ -2043,7 +2045,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 ""
+ rename foo {}
unset -nocomplain a
join $info "\n"
} {foo foo enter
@@ -2058,7 +2060,7 @@ foo {set b 1} 0 1 leavestep
foo foo 0 1 leave}
test trace-28.2 {exec traces with 'error'} {
- set info ""
+ set info {}
set res {}
proc foo {} {
@@ -2106,7 +2108,7 @@ foo {if {[catch {bar}]} {
foo foo 0 error leave}}
test trace-28.3 {exec traces with 'return -code error'} {
- set info ""
+ set info {}
set res {}
proc foo {} {
@@ -2156,9 +2158,9 @@ foo foo 0 error leave}}
test trace-28.4 {exec traces in slave with 'return -code error'} {
interp create slave
interp alias slave traceExecute {} traceExecute
- set info ""
+ set info {}
set res [interp eval slave {
- set info ""
+ set info {}
set res {}
proc foo {} {
@@ -2209,7 +2211,7 @@ foo {if {[catch {bar}]} {
foo foo 0 error leave}}
test trace-28.5 {exec traces} {
- set info ""
+ set info {}
proc foo {args} { set a 1 }
trace add execution foo {enter enterstep leave leavestep} \
[list traceExecute foo]
@@ -2227,7 +2229,7 @@ foo {set a 1} 0 1 leavestep
foo {foo test-28.4} 0 1 leave}
test trace-28.6 {exec traces firing order} {
- set info ""
+ set info {}
proc enterStep {cmd op} {lappend ::info "enter $cmd/$op"}
proc leaveStep {cmd code result op} {lappend ::info "leave $cmd/$code/$result/$op"}
@@ -2238,7 +2240,7 @@ test trace-28.6 {exec traces firing order} {
trace add execution foo enterstep enterStep
trace add execution foo leavestep leaveStep
foo 42
- rename foo ""
+ rename foo {}
join $info \n
} {enter set b x=42/enterstep
leave set b x=42/0/x=42/leavestep
@@ -2246,7 +2248,7 @@ enter incr x/enterstep
leave incr x/0/43/leavestep}
test trace-28.7 {exec trace information} {
- set info ""
+ set info {}
proc foo x { incr x }
proc bar {args} {}
trace add execution foo {enter leave enterstep leavestep} bar
@@ -2287,8 +2289,8 @@ test trace-29.4 {Tcl_CreateTrace, check that tracing doesn't cause memory faults
}
testcmdtrace tracetest {tracedLoop 0}
} {{tracedLoop 0} {tracedLoop 0} {incr level} {incr level} tracer {tracer} {expr {$level==1 ? {1 2} : {}}} {expr {$level==1 ? {1 2} : {}}} {foreach tracer [expr {$level==1 ? {1 2} : {}}] {tracedLoop $level}} {foreach tracer {1 2} {tracedLoop $level}} {tracedLoop $level} {tracedLoop 1} {incr level} {incr level} tracer {tracer} {expr {$level==1 ? {1 2} : {}}} {expr {$level==1 ? {1 2} : {}}} {foreach tracer [expr {$level==1 ? {1 2} : {}}] {tracedLoop $level}} {foreach tracer {} {tracedLoop $level}} {tracedLoop $level} {tracedLoop 1} {incr level} {incr level} tracer {tracer} {expr {$level==1 ? {1 2} : {}}} {expr {$level==1 ? {1 2} : {}}} {foreach tracer [expr {$level==1 ? {1 2} : {}}] {tracedLoop $level}} {foreach tracer {} {tracedLoop $level}}}
-catch {rename tracer ""}
-catch {rename tracedLoop ""}
+catch {rename tracer {}}
+catch {rename tracedLoop {}}
test trace-29.5 {Tcl_CreateObjTrace, status return TCL_ERROR} {testcmdtrace} {
proc Error { args } { error "Shouldn't get here" }
@@ -2345,7 +2347,7 @@ test trace-31.1 {command and execution traces shared struct} {
set result [trace info command foo]
trace remove command foo delete foo
trace remove execution foo enter foo
- rename foo ""
+ rename foo {}
set result
} [list [list delete foo]]
test trace-31.2 {command and execution traces shared struct} {
@@ -2356,7 +2358,7 @@ test trace-31.2 {command and execution traces shared struct} {
set result [trace info execution foo]
trace remove command foo delete foo
trace remove execution foo enter foo
- rename foo ""
+ rename foo {}
set result
} [list [list enter foo]]
@@ -2368,7 +2370,7 @@ test trace-32.1 {
trace add command foo delete foo
trace add execution foo enter foo
set result [trace info command foo]
- rename foo ""
+ rename foo {}
set result
} [list [list delete foo]]
@@ -2466,11 +2468,11 @@ test trace-34.6 {Bug 1458266} -setup {
expr {($first eq $second) ? "ok" : "\n$first\nand\n\n$second\ndiffer"}
} -cleanup {
unset -nocomplain log first second
- rename dummy ""
- rename stepTraceHandler ""
- rename cmdTraceHandler ""
- rename isTracedInside_1 ""
- rename isTracedInside_2 ""
+ rename dummy {}
+ rename stepTraceHandler {}
+ rename cmdTraceHandler {}
+ rename isTracedInside_1 {}
+ rename isTracedInside_2 {}
} -result ok
test trace-35.1 {527164: Keep -errorinfo of traces} -setup {
@@ -2584,14 +2586,14 @@ test trace-39 {bug #3484621: tracing Bc'ed commands} -setup {
list $::traceCalls | {*}$res
} -cleanup {
unset ::traceLog ::traceCalls ::bar res
- rename dotrace ""
- rename foo ""
+ rename dotrace {}
+ rename foo {}
} -result {3 | 0 1 1}
test trace-39.1 {bug #3485022: tracing Bc'ed commands} -setup {
set ::traceLog 0
set ::traceCalls 0
- set res [list]
+ set res {}
proc dotrace args {
incr ::traceLog
}
@@ -2614,22 +2616,22 @@ test trace-39.1 {bug #3485022: tracing Bc'ed commands} -setup {
list $::traceCalls | {*}$res
} -cleanup {
unset ::traceLog ::traceCalls res
- rename dotrace ""
- rename foo ""
+ rename dotrace {}
+ rename foo {}
} -result {3 | 0 1 1}
# Delete procedures when done, so we don't clash with other tests
# (e.g. foobar will clash with 'unknown' tests).
-catch {rename foobar ""}
-catch {rename foo ""}
-catch {rename bar ""}
-catch {rename untraced ""}
-catch {rename traceproc ""}
-catch {rename runbase ""}
+catch {rename foobar {}}
+catch {rename foo {}}
+catch {rename bar {}}
+catch {rename untraced {}}
+catch {rename traceproc {}}
+catch {rename runbase {}}
# Unset the variable when done
unset -nocomplain info base
# cleanup
-::tcltest::cleanupTests
+cleanupTests
return
diff --git a/tests/unixInit.test b/tests/unixInit.test
index 23249a8..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
@@ -172,13 +172,13 @@ test unixInit-2.6 {TclpInitLibraryPath: executable relative} -setup {
makeDirectory tmp
makeDirectory [file join tmp sparkly]
makeDirectory [file join tmp sparkly bin]
- file copy [interpreter] [file join [::tcltest::temporaryDirectory] tmp sparkly \
+ file copy [interpreter] [file join [temporaryDirectory] tmp sparkly \
bin tcltest]
makeDirectory [file join tmp sparkly lib]
makeDirectory [file join tmp sparkly lib tcl[info tclversion]]
makeFile {} [file join tmp sparkly lib tcl[info tclversion] init.tcl]
} -body {
- lrange [getlibpath [file join [::tcltest::temporaryDirectory] tmp sparkly \
+ lrange [getlibpath [file join [temporaryDirectory] tmp sparkly \
bin tcltest]] 1 2
} -cleanup {
removeFile [file join tmp sparkly lib tcl[info tclversion] init.tcl]
@@ -192,14 +192,14 @@ test unixInit-2.6 {TclpInitLibraryPath: executable relative} -setup {
set env(TCL_LIBRARY) $oldlibrary
unset oldlibrary
}
-} -result [list [::tcltest::temporaryDirectory]/tmp/sparkly/lib/tcl[info tclversion] [::tcltest::temporaryDirectory]/tmp/lib/tcl[info tclversion]]
+} -result [list [temporaryDirectory]/tmp/sparkly/lib/tcl[info tclversion] [temporaryDirectory]/tmp/lib/tcl[info tclversion]]
test unixInit-2.7 {TclpInitLibraryPath: compiled-in library path} {
# would need test command to get defaultLibDir and compare it to
# [lindex $auto_path end]
} {}
#
# The following two tests write to the directory /tmp/sparkly instead of to
-# [::tcltest::temporaryDirectory]. This is because the failures tested by these tests
+# [temporaryDirectory]. This is because the failures tested by these tests
# need paths near the "root" of the file system to present themselves.
#
test unixInit-2.8 {TclpInitLibraryPath: all absolute pathtype} -setup {
@@ -321,8 +321,8 @@ test unixInit-2.10 {TclpInitLibraryPath: executable relative} -setup {
set env(TCL_LIBRARY) $oldlibrary
unset oldlibrary
}
-} -result [list [file join [::tcltest::temporaryDirectory] tmp sparkly library] \
- [file join [::tcltest::temporaryDirectory] tmp library] ]
+} -result [list [file join [temporaryDirectory] tmp sparkly library] \
+ [file join [temporaryDirectory] tmp library] ]
test unixInit-3.1 {TclpSetInitialEncodings} -constraints {
unix stdio
diff --git a/tests/unknown.test b/tests/unknown.test
index 6f9dcb0..e80d3a6 100644
--- a/tests/unknown.test
+++ b/tests/unknown.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 {"::tcltest" ni [namespace children]} {
- package require tcltest
- namespace import -force ::tcltest::*
-}
+package require tcltest 2
+namespace import ::tcltest::*
unset -nocomplain x
catch {rename unknown unknown.old}
@@ -49,7 +47,7 @@ test unknown-3.1 {argument quoting in calls to "unknown"} {
set x
} "foobar \\{ \\} a\\{b {;} \\\\ {\$a} {a\[b} \\]"
-proc unknown {args} {
+proc unknown args {
error "unknown failed"
}
test unknown-4.1 {errors in "unknown" procedure} {
@@ -57,9 +55,9 @@ test unknown-4.1 {errors in "unknown" procedure} {
} {1 {unknown failed} NONE}
# cleanup
-catch {rename unknown ""}
+catch {rename unknown {}}
catch {rename unknown.old unknown}
-::tcltest::cleanupTests
+cleanupTests
return
# Local Variables:
diff --git a/unix/Makefile.in b/unix/Makefile.in
index df05759..f433f2f 100644
--- a/unix/Makefile.in
+++ b/unix/Makefile.in
@@ -839,8 +839,8 @@ install-libraries: libraries
do \
$(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/http1.0; \
done;
- @echo "Installing package http 2.8.5 as a Tcl Module";
- @$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.6/http-2.8.5.tm;
+ @echo "Installing package http 2.8.6 as a Tcl Module";
+ @$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.6/http-2.8.6.tm;
@echo "Installing package opt0.4 files to $(SCRIPT_INSTALL_DIR)/opt0.4/";
@for i in $(TOP_DIR)/library/opt/*.tcl ; \
do \
@@ -851,8 +851,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;
@@ -1718,7 +1718,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/dltest/pkgb.c b/unix/dltest/pkgb.c
index 9884a64..ad61d77 100644
--- a/unix/dltest/pkgb.c
+++ b/unix/dltest/pkgb.c
@@ -15,14 +15,6 @@
#include "tcl.h"
/*
- * TCL_STORAGE_CLASS is set unconditionally to DLLEXPORT because the
- * Pkgb_Init declaration is in the source file itself, which is only
- * accessed when we are building a library.
- */
-#undef TCL_STORAGE_CLASS
-#define TCL_STORAGE_CLASS DLLEXPORT
-
-/*
* Prototypes for procedures defined later in this file:
*/
@@ -50,6 +42,10 @@ static int Pkgb_DemoObjCmd(ClientData clientData,
*----------------------------------------------------------------------
*/
+#ifndef Tcl_GetErrorLine
+# define Tcl_GetErrorLine(interp) ((interp)->errorLine)
+#endif
+
static int
Pkgb_SubObjCmd(
ClientData dummy, /* Not used. */
@@ -65,6 +61,9 @@ Pkgb_SubObjCmd(
}
if ((Tcl_GetIntFromObj(interp, objv[1], &first) != TCL_OK)
|| (Tcl_GetIntFromObj(interp, objv[2], &second) != TCL_OK)) {
+ char buf[TCL_INTEGER_SPACE];
+ sprintf(buf, "%d", Tcl_GetErrorLine(interp));
+ Tcl_AppendResult(interp, " in line: ", buf, NULL);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewIntObj(first - second));
@@ -98,22 +97,6 @@ Pkgb_UnsafeObjCmd(
return Tcl_EvalEx(interp, "list unsafe command invoked", -1, TCL_EVAL_GLOBAL);
}
-#if (TCL_MAJOR_VERSION > 8)
-const char *Tcl_GetDefaultEncodingDir(void)
-{
- int numDirs;
- Tcl_Obj *first, *searchPath = Tcl_GetEncodingSearchPath();
-
- Tcl_ListObjLength(NULL, searchPath, &numDirs);
- if (numDirs == 0) {
- return NULL;
- }
- Tcl_ListObjIndex(NULL, searchPath, 0, &first);
-
- return Tcl_GetString(first);
-}
-#endif
-
static int
Pkgb_DemoObjCmd(
ClientData dummy, /* Not used. */
@@ -121,7 +104,16 @@ Pkgb_DemoObjCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
+#if (TCL_MAJOR_VERSION > 8) || (TCL_MINOR_VERSION > 4)
+ Tcl_Obj *first;
+
+ if (Tcl_ListObjIndex(NULL, Tcl_GetEncodingSearchPath(), 0, &first)
+ == TCL_OK) {
+ Tcl_SetObjResult(interp, first);
+ }
+#else
Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_GetDefaultEncodingDir(), -1));
+#endif
return TCL_OK;
}
@@ -142,14 +134,14 @@ Pkgb_DemoObjCmd(
*----------------------------------------------------------------------
*/
-EXTERN int
+DLLEXPORT int
Pkgb_Init(
Tcl_Interp *interp) /* Interpreter in which the package is to be
* made available. */
{
int code;
- if (Tcl_InitStubs(interp, "8.5-9.1", 0) == NULL) {
+ if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) {
return TCL_ERROR;
}
code = Tcl_PkgProvideEx(interp, "Pkgb", "2.3", NULL);
@@ -179,14 +171,14 @@ Pkgb_Init(
*----------------------------------------------------------------------
*/
-EXTERN int
+DLLEXPORT int
Pkgb_SafeInit(
Tcl_Interp *interp) /* Interpreter in which the package is to be
* made available. */
{
int code;
- if (Tcl_InitStubs(interp, "8.5-9.1", 0) == NULL) {
+ if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) {
return TCL_ERROR;
}
code = Tcl_PkgProvideEx(interp, "Pkgb", "2.3", NULL);
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..2b6f3f3 100644
--- a/unix/tclUnixFCmd.c
+++ b/unix/tclUnixFCmd.c
@@ -40,6 +40,7 @@
* DAMAGE.
*/
+#include <sys/stat.h>
#include "tclInt.h"
#include <utime.h>
#include <grp.h>
@@ -244,7 +245,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..5816b01 100644
--- a/unix/tclUnixFile.c
+++ b/unix/tclUnixFile.c
@@ -10,6 +10,7 @@
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
+#include <sys/stat.h>
#include "tclInt.h"
#include "tclFileSystem.h"
@@ -1181,9 +1182,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 +1205,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/tclUnixInit.c b/unix/tclUnixInit.c
index f07b123..6653e4b 100644
--- a/unix/tclUnixInit.c
+++ b/unix/tclUnixInit.c
@@ -8,6 +8,7 @@
* All rights reserved.
*/
+#include <sys/stat.h>
#include "tclInt.h"
#include <stddef.h>
#include <locale.h>
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 8cfb68c..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@
@@ -634,8 +639,8 @@ install-libraries: libraries install-tzdata install-msgs
do \
$(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/http1.0"; \
done;
- @echo "Installing package http 2.8.5 as a Tcl Module";
- @$(COPY) $(ROOT_DIR)/library/http/http.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.6/http-2.8.5.tm;
+ @echo "Installing package http 2.8.6 as a Tcl Module";
+ @$(COPY) $(ROOT_DIR)/library/http/http.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.6/http-2.8.6.tm;
@echo "Installing library opt0.4 directory";
@for j in $(ROOT_DIR)/library/opt/*.tcl; \
do \
@@ -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";
@@ -751,7 +756,7 @@ packages:
if [ ! -f $(PKG_DIR)/$$pkg/Makefile ]; then \
( cd $(PKG_DIR)/$$pkg; \
echo "Configuring package '$$i' wd = `pwd -P`"; \
- $$i/configure --with-tcl=$(PWD) --with-tclinclude=$(GENERIC_DIR) $(PKG_CFG_ARGS) --enable-shared --enable-threads; ) \
+ $$i/configure --with-tcl=$$builddir --with-tclinclude=$(GENERIC_DIR) $(PKG_CFG_ARGS) --enable-shared --enable-threads; ) \
fi ; \
echo "Building package '$$pkg'"; \
( cd $(PKG_DIR)/$$pkg; $(MAKE); ) \
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/tclWinFile.c b/win/tclWinFile.c
index a1189f5..19e6abd 100644
--- a/win/tclWinFile.c
+++ b/win/tclWinFile.c
@@ -12,10 +12,10 @@
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
+#include <sys/stat.h>
#include "tclWinInt.h"
#include "tclFileSystem.h"
#include <winioctl.h>
-#include <sys/stat.h>
#include <shlobj.h>
#include <lm.h> /* For TclpGetUserHome(). */
@@ -160,7 +160,7 @@ static unsigned short NativeStatMode(DWORD attr, int checkLinks,
int isExec);
static int NativeIsExec(const TCHAR *path);
static int NativeReadReparse(const TCHAR *LinkDirectory,
- REPARSE_DATA_BUFFER *buffer);
+ REPARSE_DATA_BUFFER *buffer, DWORD desiredAccess);
static int NativeWriteReparse(const TCHAR *LinkDirectory,
REPARSE_DATA_BUFFER *buffer);
static int NativeMatchType(int isDrive, DWORD attr,
@@ -444,7 +444,7 @@ TclWinSymLinkCopyDirectory(
DUMMY_REPARSE_BUFFER dummy;
REPARSE_DATA_BUFFER *reparseBuffer = (REPARSE_DATA_BUFFER *) &dummy;
- if (NativeReadReparse(linkOrigPath, reparseBuffer)) {
+ if (NativeReadReparse(linkOrigPath, reparseBuffer, GENERIC_READ)) {
return -1;
}
return NativeWriteReparse(linkCopyPath, reparseBuffer);
@@ -542,7 +542,7 @@ WinReadLinkDirectory(
if (!(attr & FILE_ATTRIBUTE_REPARSE_POINT)) {
goto invalidError;
}
- if (NativeReadReparse(linkDirPath, reparseBuffer)) {
+ if (NativeReadReparse(linkDirPath, reparseBuffer, 0)) {
return NULL;
}
@@ -663,12 +663,13 @@ WinReadLinkDirectory(
static int
NativeReadReparse(
const TCHAR *linkDirPath, /* The junction to read */
- REPARSE_DATA_BUFFER *buffer)/* Pointer to buffer. Cannot be NULL */
+ REPARSE_DATA_BUFFER *buffer,/* Pointer to buffer. Cannot be NULL */
+ DWORD desiredAccess)
{
HANDLE hFile;
DWORD returnedLength;
- hFile = CreateFile(linkDirPath, GENERIC_READ, 0, NULL, OPEN_EXISTING,
+ hFile = CreateFile(linkDirPath, desiredAccess, 0, NULL, OPEN_EXISTING,
FILE_FLAG_OPEN_REPARSE_POINT | FILE_FLAG_BACKUP_SEMANTICS, NULL);
if (hFile == INVALID_HANDLE_VALUE) {
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
}