From 288a283617c17d2542e9f55cdfc10207d0446e0f Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 29 Jun 2020 20:20:10 +0000 Subject: WIP: Store build info in package --- generic/tclBasic.c | 43 ++++++++++++++++++++++++++++++++++++++++++- generic/tclPkg.c | 11 +++++++++-- tests/package.test | 2 +- unix/Makefile.in | 6 +++++- win/Makefile.in | 6 ++++++ 5 files changed, 63 insertions(+), 5 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 6c14f45..dc1b109 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -21,6 +21,7 @@ #include "tclOOInt.h" #include "tclCompile.h" #include "tclTomMath.h" +#include "tclUuid.h" #include #include @@ -1170,12 +1171,52 @@ Tcl_CreateInterp(void) Tcl_SetVar2(interp, "tcl_platform", "threaded", "1", TCL_GLOBAL_ONLY); #endif +#ifndef STRINGIFY +# define STRINGIFY(x) STRINGIFY1(x) +# define STRINGIFY1(x) #x +#endif + /* * Register Tcl's version number. * TIP #268: Full patchlevel instead of just major.minor + * TIP #???: Append build information "+......" */ - Tcl_PkgProvideEx(interp, "Tcl", TCL_PATCH_LEVEL, &tclStubs); + Tcl_PkgProvideEx(interp, "Tcl", TCL_PATCH_LEVEL +#if defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8 + "+" STRINGIFY(TCL_VERSION_UUID) +#ifdef TCL_COMPILE_DEBUG + ".compiledebug" +#endif +#ifdef TCL_COMPILE_STATS + ".compilestats" +#endif +#ifndef NDEBUG + ".debug" +#endif +#ifdef TCL_MEM_DEBUG + ".memdebug" +#endif +#ifdef TCL_NO_DEPRECATED + ".nodeprecate" +#endif +#ifndef TCL_THREADS + ".nothread" +#endif +#ifndef TCL_CFG_OPTIMIZED + ".nooptimize" +#endif +#ifdef TCL_CFG_PROFILED + ".profiled" +#endif +#ifdef STATIC_BUILD + ".static" +#endif +#if TCL_UTF_MAX < 4 + ".utf16" +#endif +#endif /* TCL_NO_DEPRECATED || TCL_MAJOR_VERSION > 8 */ + , &tclStubs); if (TclTommath_Init(interp) != TCL_OK) { Tcl_Panic("%s", TclGetString(Tcl_GetObjResult(interp))); diff --git a/generic/tclPkg.c b/generic/tclPkg.c index b39224e..c2fb18e 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -1694,7 +1694,7 @@ CheckVersionAndConvert( *ip++ = *p; - for (prevChar = *p, p++; *p != 0; p++) { + for (prevChar = *p, p++; (*p != 0) && (*p != '+'); p++) { if (!isdigit(UCHAR(*p)) && /* INTL: digit */ ((*p!='.' && *p!='a' && *p!='b') || ((hasunstable && (*p=='a' || *p=='b')) || @@ -1999,6 +1999,9 @@ CheckRequirement( char *dash = NULL, *buf; dash = (char *)strchr(string, '-'); + while ((dash != NULL) && dash[1] && !isdigit(UCHAR(dash[1]))) { + dash = strchr(dash+1, '-'); + } if (dash == NULL) { /* * No dash found, has to be a simple version. @@ -2007,7 +2010,11 @@ CheckRequirement( return CheckVersionAndConvert(interp, string, NULL, NULL); } - if (strchr(dash+1, '-') != NULL) { + buf = strchr(dash+1, '-'); + while ((buf != NULL) && buf[1] && !isdigit(UCHAR(buf[1]))) { + buf = strchr(buf+1, '-'); + } + if (buf != NULL) { /* * More dashes found after the first. This is wrong. */ diff --git a/tests/package.test b/tests/package.test index 2dca06b..77d7f50 100644 --- a/tests/package.test +++ b/tests/package.test @@ -937,7 +937,7 @@ test package-4.54 {Tcl_PackageCmd procedure, "vsatisfies" option} -body { } -returnCodes error -result {expected versionMin-versionMax but got "2.1-3.2-4.5"} test package-4.55 {Tcl_PackageCmd procedure, "vsatisfies" option} -body { package vsatisfies 2.1 3.2-x.y -} -returnCodes error -result {expected version number but got "x.y"} +} -returnCodes error -result {expected version number but got "3.2-x.y"} test package-4.56 {Tcl_PackageCmd procedure, "vsatisfies" option} -body { package vsatisfies 2.1 x.y-3.2 } -returnCodes error -result {expected version number but got "x.y"} diff --git a/unix/Makefile.in b/unix/Makefile.in index 21967bd..80eb5b3 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -1256,9 +1256,13 @@ tclAssembly.o: $(GENERIC_DIR)/tclAssembly.c $(COMPILEHDR) tclAsync.o: $(GENERIC_DIR)/tclAsync.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclAsync.c -tclBasic.o: $(GENERIC_DIR)/tclBasic.c $(COMPILEHDR) $(MATHHDRS) $(NREHDR) +tclBasic.o: $(GENERIC_DIR)/tclBasic.c $(COMPILEHDR) $(MATHHDRS) $(NREHDR) tclUuid.h $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclBasic.c +tclUuid.h: $(TOP_DIR)/manifest.uuid + echo "#define TCL_VERSION_UUID \\" >$@ + cat $(TOP_DIR)/manifest.uuid >>$@ + tclBinary.o: $(GENERIC_DIR)/tclBinary.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclBinary.c diff --git a/win/Makefile.in b/win/Makefile.in index 344db71..4fbae8f 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -686,6 +686,12 @@ tclPkgConfig.${OBJEXT}: tclPkgConfig.c -DBUILD_tcl \ @DEPARG@ $(CC_OBJNAME) +tclBasic.${OBJEXT}: tclBasic.c tclUuid.h + +tclUuid.h: $(TOP_DIR)/manifest.uuid + echo "#define TCL_VERSION_UUID \\" >$@ + cat $(TOP_DIR)/manifest.uuid >>$@ + # The following objects are part of the stub library and should not be built # as DLL objects but none of the symbols should be exported -- cgit v0.12 From ef76e3161ec9acba0a8e3fac11460a93571ba362 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 30 Jun 2020 14:36:48 +0000 Subject: Add buildinfo functionality to makefile.vc too --- .fossil-settings/ignore-glob | 1 + win/Makefile.in | 4 ++++ win/gitmanifest.in | 1 + win/makefile.vc | 11 +++++++++++ win/tclUuid.h.in | 1 + 5 files changed, 18 insertions(+) create mode 100755 win/gitmanifest.in create mode 100755 win/tclUuid.h.in diff --git a/.fossil-settings/ignore-glob b/.fossil-settings/ignore-glob index a58aef5..f95c1a7 100644 --- a/.fossil-settings/ignore-glob +++ b/.fossil-settings/ignore-glob @@ -64,4 +64,5 @@ win/*.manifest win/pkgs/* win/coffbase.txt win/tcl.hpj +win/nmakehlp.out win/nmhlp-out.txt diff --git a/win/Makefile.in b/win/Makefile.in index 4fbae8f..fe3b661 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -688,6 +688,10 @@ tclPkgConfig.${OBJEXT}: tclPkgConfig.c tclBasic.${OBJEXT}: tclBasic.c tclUuid.h +$(TOP_DIR)/manifest.uuid: + printf "git." >$(TOP_DIR)/manifest.uuid + git rev-parse HEAD >>$(TOP_DIR)/manifest.uuid + tclUuid.h: $(TOP_DIR)/manifest.uuid echo "#define TCL_VERSION_UUID \\" >$@ cat $(TOP_DIR)/manifest.uuid >>$@ diff --git a/win/gitmanifest.in b/win/gitmanifest.in new file mode 100755 index 0000000..d7a20e0 --- /dev/null +++ b/win/gitmanifest.in @@ -0,0 +1 @@ +git. \ No newline at end of file diff --git a/win/makefile.vc b/win/makefile.vc index c6b53d0..ed68244 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -758,6 +758,17 @@ $(TMP_DIR)\tclMainW.obj: $(GENERICDIR)\tclMain.c $(cc32) $(pkgcflags) /DUNICODE /D_UNICODE \ -Fo$@ $? +$(ROOT)\manifest.uuid: $(WIN_DIR)\gitmanifest.in + copy $(WIN_DIR)\gitmanifest.in $(ROOT)\manifest.uuid + git rev-parse HEAD >>$(ROOT)\manifest.uuid + +$(TMP_DIR)\tclUuid.h: $(ROOT)\manifest.uuid $(WIN_DIR)\tclUuid.h.in + copy $(WIN_DIR)\tclUuid.h.in+$(ROOT)\manifest.uuid $(TMP_DIR)\tclUuid.h + +$(TMP_DIR)\tclBasic.obj: $(GENERICDIR)\tclBasic.c $(TMP_DIR)\tclUuid.h + $(cc32) $(pkgcflags) -I$(TMP_DIR) \ + -Fo$@ $(GENERICDIR)\tclBasic.c + $(TMP_DIR)\tclTest.obj: $(GENERICDIR)\tclTest.c $(cc32) $(appcflags) -Fo$@ $? diff --git a/win/tclUuid.h.in b/win/tclUuid.h.in new file mode 100755 index 0000000..cbb83e4 --- /dev/null +++ b/win/tclUuid.h.in @@ -0,0 +1 @@ +#define TCL_VERSION_UUID \ -- cgit v0.12 From 11f905cd0ac504734130b3c41a7b434b83557b7c Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 30 Jun 2020 16:36:27 +0000 Subject: Add compiler information (gcc|clang|msvc) information --- generic/tclBasic.c | 9 +++++++++ win/makefile.vc | 4 ++-- 2 files changed, 11 insertions(+), 2 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index dc1b109..d1e6fe2 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -1191,12 +1191,21 @@ Tcl_CreateInterp(void) #ifdef TCL_COMPILE_STATS ".compilestats" #endif +#if defined(__clang__) && defined(__clang_major__) + ".clang" STRINGIFY(__clang_major__) +#endif #ifndef NDEBUG ".debug" #endif +#if !defined(__clang__) && defined(__GNUC__) + ".gcc" STRINGIFY(__GNUC__) +#endif #ifdef TCL_MEM_DEBUG ".memdebug" #endif +#if defined(_MSC_VER) + ".msvc" STRINGIFY(_MSC_VER) +#endif #ifdef TCL_NO_DEPRECATED ".nodeprecate" #endif diff --git a/win/makefile.vc b/win/makefile.vc index ed68244..8ce4354 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -758,11 +758,11 @@ $(TMP_DIR)\tclMainW.obj: $(GENERICDIR)\tclMain.c $(cc32) $(pkgcflags) /DUNICODE /D_UNICODE \ -Fo$@ $? -$(ROOT)\manifest.uuid: $(WIN_DIR)\gitmanifest.in +$(ROOT)\manifest.uuid: copy $(WIN_DIR)\gitmanifest.in $(ROOT)\manifest.uuid git rev-parse HEAD >>$(ROOT)\manifest.uuid -$(TMP_DIR)\tclUuid.h: $(ROOT)\manifest.uuid $(WIN_DIR)\tclUuid.h.in +$(TMP_DIR)\tclUuid.h: $(ROOT)\manifest.uuid copy $(WIN_DIR)\tclUuid.h.in+$(ROOT)\manifest.uuid $(TMP_DIR)\tclUuid.h $(TMP_DIR)\tclBasic.obj: $(GENERICDIR)\tclBasic.c $(TMP_DIR)\tclUuid.h -- cgit v0.12 From 9e49093832a72b513ec22ea3314b95991b88dfa7 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 29 Sep 2020 13:11:08 +0000 Subject: Fix testcase --- tests/config.test | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/config.test b/tests/config.test index b78e29d..bcf948e 100644 --- a/tests/config.test +++ b/tests/config.test @@ -17,9 +17,9 @@ if {"::tcltest" ni [namespace children]} { namespace import -force ::tcltest::* } -test pkgconfig-1.1 {query keys} { +test pkgconfig-1.1 {query keys} -body { lsort [::tcl::pkgconfig list] -} {64bit bindir,install bindir,runtime compile_debug compile_stats debug dllfile,runtime docdir,install docdir,runtime includedir,install includedir,runtime libdir,install libdir,runtime mem_debug optimized profiled scriptdir,install scriptdir,runtime threaded zipfile,runtime} +} -match glob -result {*bindir,install bindir,runtime*dllfile,runtime docdir,install docdir,runtime includedir,install includedir,runtime libdir,install libdir,runtime*scriptdir,install scriptdir,runtime*zipfile,runtime} test pkgconfig-1.2 {query keys multiple times} { string compare [::tcl::pkgconfig list] [::tcl::pkgconfig list] } 0 -- cgit v0.12 From 70c1d3d8c18a991c9602ecef5cec77be5cf56f04 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 1 Oct 2020 08:17:48 +0000 Subject: Merge 8.7. Internal package renaming --- generic/tclBasic.c | 3 +- generic/tclOO.c | 9 ++++- generic/tclOOStubLib.c | 9 +++-- generic/tclTest.c | 64 ++++++++++++++++++++++++++++++++-- generic/tclTestProcBodyObj.c | 8 ++--- generic/tclZipfs.c | 2 +- generic/tclZlib.c | 5 ++- library/tm.tcl | 4 +-- tests/assocd.test | 2 +- tests/async.test | 2 +- tests/basic.test | 2 +- tests/chanio.test | 4 +-- tests/cmdAH.test | 2 +- tests/cmdIL.test | 2 +- tests/cmdInfo.test | 2 +- tests/compExpr-old.test | 2 +- tests/compExpr.test | 2 +- tests/compile.test | 4 +-- tests/coroutine.test | 2 +- tests/dcall.test | 2 +- tests/dstring.test | 2 +- tests/encoding.test | 2 +- tests/env.test | 2 +- tests/event.test | 4 +-- tests/exec.test | 2 +- tests/execute.test | 6 ++-- tests/expr-old.test | 2 +- tests/expr.test | 2 +- tests/fCmd.test | 2 +- tests/fileName.test | 2 +- tests/fileSystem.test | 4 +-- tests/get.test | 2 +- tests/indexObj.test | 2 +- tests/info.test | 2 +- tests/interp.test | 2 +- tests/io.test | 4 +-- tests/ioCmd.test | 2 +- tests/ioTrans.test | 2 +- tests/iogt.test | 2 +- tests/lindex.test | 2 +- tests/link.test | 2 +- tests/listObj.test | 2 +- tests/load.test | 2 +- tests/lrange.test | 2 +- tests/lset.test | 2 +- tests/main.test | 82 +++++++++++++++++++++----------------------- tests/misc.test | 2 +- tests/namespace.test | 2 +- tests/notify.test | 2 +- tests/nre.test | 2 +- tests/obj.test | 2 +- tests/oo.test | 24 ++++++------- tests/ooNext2.test | 2 +- tests/ooUtil.test | 2 +- tests/package.test | 4 +-- tests/parse.test | 2 +- tests/parseExpr.test | 2 +- tests/parseOld.test | 2 +- tests/platform.test | 2 +- tests/proc.test | 40 ++++++++++----------- tests/reg.test | 2 +- tests/rename.test | 2 +- tests/resolver.test | 2 +- tests/result.test | 2 +- tests/safe-zipfs.test | 8 ++--- tests/safe.test | 16 ++++----- tests/set.test | 2 +- tests/socket.test | 2 +- tests/string.test | 2 +- tests/stringObj.test | 2 +- tests/subst.test | 2 +- tests/tailcall.test | 2 +- tests/thread.test | 2 +- tests/trace.test | 2 +- tests/unixFCmd.test | 2 +- tests/unixFile.test | 2 +- tests/unload.test | 2 +- tests/upvar.test | 2 +- tests/utf.test | 2 +- tests/util.test | 2 +- tests/var.test | 2 +- tests/winFCmd.test | 2 +- tests/winFile.test | 2 +- tests/winNotify.test | 2 +- tests/winPipe.test | 4 +-- tests/winTime.test | 2 +- tools/makeHeader.tcl | 2 +- win/Makefile.in | 2 +- 88 files changed, 257 insertions(+), 185 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 3cac9f4..da56c2c 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -1181,7 +1181,8 @@ Tcl_CreateInterp(void) * TIP #???: Append build information "+......" */ - Tcl_PkgProvideEx(interp, "Tcl", TCL_PATCH_LEVEL + Tcl_PkgProvideEx(interp, "Tcl", TCL_PATCH_LEVEL, &tclStubs); + Tcl_PkgProvideEx(interp, "tcl", TCL_PATCH_LEVEL "+" STRINGIFY(TCL_VERSION_UUID) #if defined(__clang__) && defined(__clang_major__) ".clang-" STRINGIFY(__clang_major__) diff --git a/generic/tclOO.c b/generic/tclOO.c index b60ab1f..e958279 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -138,7 +138,10 @@ static const Tcl_MethodType classConstructor = { */ static const char *initScript = +#ifndef TCL_NO_DEPRECATED "package ifneeded TclOO " TCLOO_PATCHLEVEL " {# Already present, OK?};" +#endif +"package ifneeded tcl::oo " TCLOO_PATCHLEVEL " {# Already present, OK?};" "namespace eval ::oo { variable version " TCLOO_VERSION " };" "namespace eval ::oo { variable patchlevel " TCLOO_PATCHLEVEL " };"; /* "tcl_findLibrary tcloo $oo::version $oo::version" */ @@ -257,7 +260,11 @@ TclOOInit( return TCL_ERROR; } - return Tcl_PkgProvideEx(interp, "TclOO", TCLOO_PATCHLEVEL, +#ifndef TCL_NO_DEPRECATED + Tcl_PkgProvideEx(interp, "TclOO", TCLOO_PATCHLEVEL, + (void *) &tclOOStubs); +#endif + return Tcl_PkgProvideEx(interp, "tcl::oo", TCLOO_PATCHLEVEL, (void *) &tclOOStubs); } diff --git a/generic/tclOOStubLib.c b/generic/tclOOStubLib.c index a9fa212..221d99a 100644 --- a/generic/tclOOStubLib.c +++ b/generic/tclOOStubLib.c @@ -35,14 +35,19 @@ TclOOInitializeStubs( const char *version) { int exact = 0; - const char *packageName = "TclOO"; + const char *packageName = "tcl::oo"; const char *errMsg = NULL; TclOOStubs *stubsPtr = NULL; const char *actualVersion = tclStubsPtr->tcl_PkgRequireEx(interp, packageName, version, exact, &stubsPtr); if (actualVersion == NULL) { - return NULL; + packageName = "TclOO"; + actualVersion = tclStubsPtr->tcl_PkgRequireEx(interp, + packageName, version, exact, &stubsPtr); + if (actualVersion == NULL) { + return NULL; + } } if (stubsPtr == NULL) { errMsg = "missing stub table pointer"; diff --git a/generic/tclTest.c b/generic/tclTest.c index 1523666..49e97d0 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -26,6 +26,7 @@ # include "tclTomMath.h" #endif #include "tclOO.h" +#include "tclUuid.h" #include /* @@ -436,6 +437,11 @@ static const Tcl_Filesystem simpleFilesystem = { *---------------------------------------------------------------------- */ +#ifndef STRINGIFY +# define STRINGIFY(x) STRINGIFY1(x) +# define STRINGIFY1(x) #x +#endif + int Tcltest_Init( Tcl_Interp *interp) /* Interpreter for application. */ @@ -459,11 +465,65 @@ Tcltest_Init( return TCL_ERROR; } /* TIP #268: Full patchlevel instead of just major.minor */ - - if (Tcl_PkgProvideEx(interp, "Tcltest", TCL_PATCH_LEVEL, NULL) == TCL_ERROR) { + /* TIP #???: Append build information "+......" */ + + if (Tcl_PkgProvideEx(interp, "tcl::test", TCL_PATCH_LEVEL + "+" STRINGIFY(TCL_VERSION_UUID) +#if defined(__clang__) && defined(__clang_major__) + ".clang-" STRINGIFY(__clang_major__) +#if __clang_minor__ < 10 + "0" +#endif + STRINGIFY(__clang_minor__) +#endif +#ifdef TCL_COMPILE_DEBUG + ".compiledebug" +#endif +#ifdef TCL_COMPILE_STATS + ".compilestats" +#endif +#ifndef NDEBUG + ".debug" +#endif +#if !defined(__clang__) && defined(__GNUC__) + ".gcc-" STRINGIFY(__GNUC__) +#if __GNUC_MINOR__ < 10 + "0" +#endif + STRINGIFY(__GNUC_MINOR__) +#endif +#ifdef TCL_MEM_DEBUG + ".memdebug" +#endif +#if defined(_MSC_VER) + ".msvc-" STRINGIFY(_MSC_VER) +#endif +#ifdef USE_NMAKE + ".nmake" +#endif +#ifdef TCL_NO_DEPRECATED + ".no-deprecate" +#endif +#ifndef TCL_THREADS + ".no-thread" +#endif +#ifndef TCL_CFG_OPTIMIZED + ".no-optimize" +#endif +#ifdef TCL_CFG_PROFILED + ".profiled" +#endif +#ifdef STATIC_BUILD + ".static" +#endif +#if TCL_UTF_MAX < 4 + ".utf16" +#endif + , NULL) == TCL_ERROR) { return TCL_ERROR; } + /* * Create additional commands and math functions for testing Tcl. */ diff --git a/generic/tclTestProcBodyObj.c b/generic/tclTestProcBodyObj.c index db6ec8a..437644e 100644 --- a/generic/tclTestProcBodyObj.c +++ b/generic/tclTestProcBodyObj.c @@ -20,7 +20,7 @@ * name and version of this package */ -static const char packageName[] = "procbodytest"; +static const char packageName[] = "tcl::procbodytest"; static const char packageVersion[] = "1.1"; /* @@ -75,7 +75,7 @@ static const CmdTable safeCommands[] = { * * Procbodytest_Init -- * - * This function initializes the "procbodytest" package. + * This function initializes the "tcl::procbodytest" package. * * Results: * A standard Tcl result. @@ -99,7 +99,7 @@ Procbodytest_Init( * * Procbodytest_SafeInit -- * - * This function initializes the "procbodytest" package. + * This function initializes the "tcl::procbodytest" package. * * Results: * A standard Tcl result. @@ -315,7 +315,7 @@ ProcBodyTestProcObjCmd( * procbodytest::check * * Performs an internal check that the Tcl_PkgPresent() command returns - * the same version number as was registered when the procbodytest package + * the same version number as was registered when the tcl::procbodytest package * was provided. Places a boolean in the interp result indicating the * test outcome. * diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c index ecee366..1b007cf 100644 --- a/generic/tclZipfs.c +++ b/generic/tclZipfs.c @@ -4771,7 +4771,7 @@ TclZipfs_Init( Tcl_NewStringObj("::tcl::zipfs::find", -1)); Tcl_CreateObjCommand(interp, "::tcl::zipfs::tcl_library_init", ZipFSTclLibraryObjCmd, NULL, NULL); - Tcl_PkgProvide(interp, "zipfs", "2.0"); + Tcl_PkgProvide(interp, "tcl::zipfs", "2.0"); } return TCL_OK; #else /* !HAVE_ZLIB */ diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 34bf78d..92c469f 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -3957,7 +3957,10 @@ TclZlibInit( * Formally provide the package as a Tcl built-in. */ - return Tcl_PkgProvide(interp, "zlib", TCL_ZLIB_VERSION); +#ifndef TCL_NO_DEPRECATED + Tcl_PkgProvide(interp, "zlib", TCL_ZLIB_VERSION); +#endif + return Tcl_PkgProvide(interp, "tcl::zlib", TCL_ZLIB_VERSION); } /* diff --git a/library/tm.tcl b/library/tm.tcl index c60084c..ef7b8af 100644 --- a/library/tm.tcl +++ b/library/tm.tcl @@ -316,7 +316,7 @@ proc ::tcl::tm::UnknownHandler {original name args} { proc ::tcl::tm::Defaults {} { global env tcl_platform - regexp {^(\d+)\.(\d+)} [package provide Tcl] - major minor + regexp {^(\d+)\.(\d+)} [package provide tcl] - major minor set exe [file normalize [info nameofexecutable]] # Note that we're using [::list], not [list] because [list] means @@ -359,7 +359,7 @@ proc ::tcl::tm::Defaults {} { # Calls 'path add' to paths to the list of module search paths. proc ::tcl::tm::roots {paths} { - regexp {^(\d+)\.(\d+)} [package provide Tcl] - major minor + regexp {^(\d+)\.(\d+)} [package provide 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/tests/assocd.test b/tests/assocd.test index 7d89daa..5185e29 100644 --- a/tests/assocd.test +++ b/tests/assocd.test @@ -17,7 +17,7 @@ if {"::tcltest" ni [namespace children]} { } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testgetassocdata [llength [info commands testgetassocdata]] testConstraint testsetassocdata [llength [info commands testsetassocdata]] diff --git a/tests/async.test b/tests/async.test index ad058a0..642e295 100644 --- a/tests/async.test +++ b/tests/async.test @@ -17,7 +17,7 @@ if {"::tcltest" ni [namespace children]} { } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testasync [llength [info commands testasync]] testConstraint knownMsvcBug [expr {![info exists ::env(TRAVIS_OS_NAME)] || ![string match windows $::env(TRAVIS_OS_NAME)]}] diff --git a/tests/basic.test b/tests/basic.test index 38ea11e..d76cd2f 100644 --- a/tests/basic.test +++ b/tests/basic.test @@ -21,7 +21,7 @@ if {"::tcltest" ni [namespace children]} { } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testevalex [llength [info commands testevalex]] testConstraint testcmdtoken [llength [info commands testcmdtoken]] diff --git a/tests/chanio.test b/tests/chanio.test index daacdd0..bc6e3b5 100644 --- a/tests/chanio.test +++ b/tests/chanio.test @@ -36,8 +36,8 @@ namespace eval ::tcl::test::io { catch { ::tcltest::loadTestedCommands - package require -exact Tcltest [info patchlevel] - set ::tcltestlib [lindex [package ifneeded Tcltest [info patchlevel]] 1] + package require -exact tcl::test [info patchlevel] + set ::tcltestlib [lindex [package ifneeded tcl::test [info patchlevel]] 1] } package require tcltests diff --git a/tests/cmdAH.test b/tests/cmdAH.test index e1fd920..c14cbe9 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -16,7 +16,7 @@ if {"::tcltest" ni [namespace children]} { } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testchmod [llength [info commands testchmod]] testConstraint testsetplatform [llength [info commands testsetplatform]] diff --git a/tests/cmdIL.test b/tests/cmdIL.test index 68f7892..37cc52e 100644 --- a/tests/cmdIL.test +++ b/tests/cmdIL.test @@ -15,7 +15,7 @@ if {"::tcltest" ni [namespace children]} { ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] # Used for constraining memory leak tests testConstraint memory [llength [info commands memory]] diff --git a/tests/cmdInfo.test b/tests/cmdInfo.test index e690002..b4f6fa8 100644 --- a/tests/cmdInfo.test +++ b/tests/cmdInfo.test @@ -19,7 +19,7 @@ if {"::tcltest" ni [namespace children]} { } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testcmdinfo [llength [info commands testcmdinfo]] testConstraint testcmdtoken [llength [info commands testcmdtoken]] diff --git a/tests/compExpr-old.test b/tests/compExpr-old.test index f573cfa..cd3516b 100644 --- a/tests/compExpr-old.test +++ b/tests/compExpr-old.test @@ -19,7 +19,7 @@ if {"::tcltest" ni [namespace children]} { ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] # Big test for correct ordering of data in [expr] diff --git a/tests/compExpr.test b/tests/compExpr.test index e9220c1..587151a 100644 --- a/tests/compExpr.test +++ b/tests/compExpr.test @@ -14,7 +14,7 @@ if {"::tcltest" ni [namespace children]} { } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] # Constrain memory leak tests testConstraint memory [llength [info commands memory]] diff --git a/tests/compile.test b/tests/compile.test index 37bd034..5b158ff 100644 --- a/tests/compile.test +++ b/tests/compile.test @@ -18,7 +18,7 @@ if {"::tcltest" ni [namespace children]} { ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint exec [llength [info commands exec]] testConstraint memory [llength [info commands memory]] @@ -500,7 +500,7 @@ test compile-13.2 {TclCompileScript: testing expected nested scripts compilation # with 1500 (1000 in debug) nested scripts (bodies). If you get SO/SF exceptions on some low-stack # boxes or systems, please don't decrease it (either provide a constraint) ti eval {foreach cmd {eval "if 1" try catch} { - set c [gencode [expr {"debug" ni [split [package provide Tcl] .] ? 1500 : 1000}] $cmd] + set c [gencode [expr {"debug" ni [split [package provide tcl] .] ? 1500 : 1000}] $cmd] if 1 $c }} ti eval {set result} diff --git a/tests/coroutine.test b/tests/coroutine.test index 6d79fd7..3ff325e 100644 --- a/tests/coroutine.test +++ b/tests/coroutine.test @@ -15,7 +15,7 @@ if {"::tcltest" ni [namespace children]} { } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testnrelevels [llength [info commands testnrelevels]] testConstraint memory [llength [info commands memory]] diff --git a/tests/dcall.test b/tests/dcall.test index 7d86135..e2133fd 100644 --- a/tests/dcall.test +++ b/tests/dcall.test @@ -17,7 +17,7 @@ if {"::tcltest" ni [namespace children]} { } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testdcall [llength [info commands testdcall]] diff --git a/tests/dstring.test b/tests/dstring.test index 8a24ebe..c571b5f 100644 --- a/tests/dstring.test +++ b/tests/dstring.test @@ -17,7 +17,7 @@ if {"::tcltest" ni [namespace children]} { } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testdstring [llength [info commands testdstring]] if {[testConstraint testdstring]} { diff --git a/tests/encoding.test b/tests/encoding.test index d0ca114..c16c7ef 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -19,7 +19,7 @@ namespace eval ::tcl::test::encoding { catch { ::tcltest::loadTestedCommands - package require -exact Tcltest [info patchlevel] + package require -exact tcl::test [info patchlevel] } proc toutf {args} { diff --git a/tests/env.test b/tests/env.test index bad9e66..4716b5b 100644 --- a/tests/env.test +++ b/tests/env.test @@ -17,7 +17,7 @@ if {"::tcltest" ni [namespace children]} { } loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] package require tcltests # [exec] is required here to see the actual environment received by child diff --git a/tests/event.test b/tests/event.test index 3194547..ba52e30 100644 --- a/tests/event.test +++ b/tests/event.test @@ -14,8 +14,8 @@ namespace import -force ::tcltest::* catch { ::tcltest::loadTestedCommands - package require -exact Tcltest [info patchlevel] - set ::tcltestlib [lindex [package ifneeded Tcltest [info patchlevel]] 1] + package require -exact tcl::test [info patchlevel] + set ::tcltestlib [lindex [package ifneeded tcl::test [info patchlevel]] 1] } diff --git a/tests/exec.test b/tests/exec.test index 5082393..458e12a 100644 --- a/tests/exec.test +++ b/tests/exec.test @@ -20,7 +20,7 @@ if {"::tcltest" ni [namespace children]} { } loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] package require tcltests # All tests require the "exec" command. diff --git a/tests/execute.test b/tests/execute.test index 6d27e55..1525308 100644 --- a/tests/execute.test +++ b/tests/execute.test @@ -20,7 +20,7 @@ if {"::tcltest" ni [namespace children]} { } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] catch {namespace delete {*}[namespace children :: test_ns_*]} catch {rename foo ""} @@ -985,7 +985,7 @@ test execute-8.6 {Compile epoch bump in global level (bug [fa6bf38d07])} -setup interp create child child eval { package require tcltest 2.5 - catch [list package require -exact Tcltest [info patchlevel]] + catch [list package require -exact tcl::test [info patchlevel]] ::tcltest::loadTestedCommands if {[namespace which -command testbumpinterpepoch] eq ""} { proc testbumpinterpepoch {} { rename ::set ::dummy; rename ::dummy ::set } @@ -1018,7 +1018,7 @@ test execute-8.7 {Compile epoch bump in global level (bug [fa6bf38d07]), excepti interp create child child eval { package require tcltest 2.5 - catch [list package require -exact Tcltest [info patchlevel]] + catch [list package require -exact tcl::test [info patchlevel]] ::tcltest::loadTestedCommands if {[namespace which -command testbumpinterpepoch] eq ""} { proc testbumpinterpepoch {} { rename ::set ::dummy; rename ::dummy ::set } diff --git a/tests/expr-old.test b/tests/expr-old.test index ad5a6bc..30a9807 100644 --- a/tests/expr-old.test +++ b/tests/expr-old.test @@ -19,7 +19,7 @@ if {"::tcltest" ni [namespace children]} { } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testexprlong [llength [info commands testexprlong]] testConstraint testexprdouble [llength [info commands testexprdouble]] diff --git a/tests/expr.test b/tests/expr.test index 0b4fa2b..d49d7eb 100644 --- a/tests/expr.test +++ b/tests/expr.test @@ -16,7 +16,7 @@ if {"::tcltest" ni [namespace children]} { } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] # Determine if "long int" type is a 32 bit number and if the wide # type is a 64 bit number on this machine. diff --git a/tests/fCmd.test b/tests/fCmd.test index 53313dc..0978aa0 100644 --- a/tests/fCmd.test +++ b/tests/fCmd.test @@ -16,7 +16,7 @@ if {"::tcltest" ni [namespace children]} { } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] cd [temporaryDirectory] diff --git a/tests/fileName.test b/tests/fileName.test index d4dfd9a..57b5e52 100644 --- a/tests/fileName.test +++ b/tests/fileName.test @@ -17,7 +17,7 @@ if {"::tcltest" ni [namespace children]} { ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testsetplatform [llength [info commands testsetplatform]] testConstraint testtranslatefilename [llength [info commands testtranslatefilename]] diff --git a/tests/fileSystem.test b/tests/fileSystem.test index 19066ee..93a3f51 100644 --- a/tests/fileSystem.test +++ b/tests/fileSystem.test @@ -25,7 +25,7 @@ namespace eval ::tcl::test::fileSystem { testConstraint loaddll 0 catch { ::tcltest::loadTestedCommands - package require -exact Tcltest [info patchlevel] + package require -exact tcl::test [info patchlevel] set ::ddever [package require dde] set ::ddelib [lindex [package ifneeded dde $::ddever] 1] set ::regver [package require registry] @@ -33,7 +33,7 @@ catch { testConstraint loaddll 1 } -# Test for commands defined in Tcltest executable +# Test for commands defined in tcl::test package testConstraint testfilesystem [llength [info commands ::testfilesystem]] testConstraint testsetplatform [llength [info commands ::testsetplatform]] testConstraint testsimplefilesystem [llength [info commands ::testsimplefilesystem]] diff --git a/tests/get.test b/tests/get.test index 9e7728a..071b874 100644 --- a/tests/get.test +++ b/tests/get.test @@ -16,7 +16,7 @@ if {"::tcltest" ni [namespace children]} { } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testgetint [llength [info commands testgetint]] testConstraint testdoubleobj [llength [info commands testdoubleobj]] diff --git a/tests/indexObj.test b/tests/indexObj.test index 079eb52..0f3f2db 100644 --- a/tests/indexObj.test +++ b/tests/indexObj.test @@ -14,7 +14,7 @@ if {"::tcltest" ni [namespace children]} { } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testindexobj [llength [info commands testindexobj]] testConstraint testparseargs [llength [info commands testparseargs]] diff --git a/tests/info.test b/tests/info.test index 813b418..03bedf8 100644 --- a/tests/info.test +++ b/tests/info.test @@ -20,7 +20,7 @@ if {{::tcltest} ni [namespace children]} { namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint zlib [llength [info commands zlib]] # Set up namespaces needed to test operation of "info args", "info body", diff --git a/tests/interp.test b/tests/interp.test index 4453d90..0bfee4b 100644 --- a/tests/interp.test +++ b/tests/interp.test @@ -16,7 +16,7 @@ if {"::tcltest" ni [namespace children]} { } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testinterpdelete [llength [info commands testinterpdelete]] diff --git a/tests/io.test b/tests/io.test index 2752408..a2d19d2 100644 --- a/tests/io.test +++ b/tests/io.test @@ -31,8 +31,8 @@ namespace eval ::tcl::test::io { catch { ::tcltest::loadTestedCommands - package require -exact Tcltest [info patchlevel] - set ::tcltestlib [lindex [package ifneeded Tcltest [info patchlevel]] 1] + package require -exact tcl::test [info patchlevel] + set ::tcltestlib [lindex [package ifneeded tcl::test [info patchlevel]] 1] } package require tcltests diff --git a/tests/ioCmd.test b/tests/ioCmd.test index 749d225..c517878 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -19,7 +19,7 @@ if {"::tcltest" ni [namespace children]} { } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] package require tcltests diff --git a/tests/ioTrans.test b/tests/ioTrans.test index f185117..01af837 100644 --- a/tests/ioTrans.test +++ b/tests/ioTrans.test @@ -17,7 +17,7 @@ if {"::tcltest" ni [namespace children]} { } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] # Custom constraints used in this file testConstraint testchannel [llength [info commands testchannel]] diff --git a/tests/iogt.test b/tests/iogt.test index fb04b5b..0f1e439 100644 --- a/tests/iogt.test +++ b/tests/iogt.test @@ -16,7 +16,7 @@ if {"::tcltest" ni [namespace children]} { } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] namespace eval ::tcl::test::iogt { namespace import ::tcltest::* diff --git a/tests/lindex.test b/tests/lindex.test index f9397d2..1e91af4 100644 --- a/tests/lindex.test +++ b/tests/lindex.test @@ -18,7 +18,7 @@ if {"::tcltest" ni [namespace children]} { } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] set minus - testConstraint testevalex [llength [info commands testevalex]] diff --git a/tests/link.test b/tests/link.test index 89e5aa2..05959f5 100644 --- a/tests/link.test +++ b/tests/link.test @@ -17,7 +17,7 @@ if {"::tcltest" ni [namespace children]} { } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testlink [llength [info commands testlink]] testConstraint testlinkarray [llength [info commands testlinkarray]] diff --git a/tests/listObj.test b/tests/listObj.test index ce6c978..1b7f848 100644 --- a/tests/listObj.test +++ b/tests/listObj.test @@ -17,7 +17,7 @@ if {"::tcltest" ni [namespace children]} { } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testobj [llength [info commands testobj]] diff --git a/tests/load.test b/tests/load.test index 9fdf1cf..8ede78a 100644 --- a/tests/load.test +++ b/tests/load.test @@ -16,7 +16,7 @@ if {"::tcltest" ni [namespace children]} { } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] # Figure out what extension is used for shared libraries on this # platform. diff --git a/tests/lrange.test b/tests/lrange.test index a20422f..0238504 100644 --- a/tests/lrange.test +++ b/tests/lrange.test @@ -17,7 +17,7 @@ if {"::tcltest" ni [namespace children]} { } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testpurebytesobj [llength [info commands testpurebytesobj]] diff --git a/tests/lset.test b/tests/lset.test index d98a38e..5c1a0d5 100644 --- a/tests/lset.test +++ b/tests/lset.test @@ -17,7 +17,7 @@ if {"::tcltest" ni [namespace children]} { } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] proc failTrace {name1 name2 op} { error "trace failed" diff --git a/tests/main.test b/tests/main.test index c7347b9..87e0a9a 100644 --- a/tests/main.test +++ b/tests/main.test @@ -11,12 +11,10 @@ namespace eval ::tcl::test::main { # Is [exec] defined? testConstraint exec [llength [info commands exec]] - # Is the Tcltest package loaded? - # - that is, the special C-coded testing commands in tclTest.c - # - tests use testing commands introduced in Tcltest 8.4 - testConstraint Tcltest [expr { - [llength [package provide Tcltest]] - && [package vsatisfies [package provide Tcltest] 8.5-]}] + # Is the tcl::test package loaded? + testConstraint tcl::test [expr { + [llength [package provide tcl::test]] + && [package vsatisfies [package provide tcl::test] 8.5-]}] # Procedure to simulate interactive typing of commands, line by line proc type {chan script} { @@ -192,7 +190,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-2.1 { Tcl_Main: appInitProc returns error } -constraints { - exec Tcltest + exec tcl::test } -setup { makeFile {puts "In script"} script } -body { @@ -208,7 +206,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-2.2 { Tcl_Main: appInitProc returns error } -constraints { - exec Tcltest + exec tcl::test } -body { exec [interpreter] << {puts "In script"} -appinitprocerror >& result set f [open result] @@ -221,7 +219,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-2.3 { Tcl_Main: appInitProc deletes interp } -constraints { - exec Tcltest + exec tcl::test } -setup { makeFile {puts "In script"} script } -body { @@ -237,7 +235,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-2.4 { Tcl_Main: appInitProc deletes interp } -constraints { - exec Tcltest + exec tcl::test } -body { exec [interpreter] << {puts "In script"} \ -appinitprocdeleteinterp >& result @@ -251,7 +249,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-2.5 { Tcl_Main: appInitProc closes stderr } -constraints { - exec Tcltest + exec tcl::test } -body { exec [interpreter] << {puts "In script"} \ -appinitprocclosestderr >& result @@ -336,7 +334,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-3.5 { Tcl_Main: startup script sets main loop } -constraints { - exec Tcltest + exec tcl::test } -setup { makeFile { rename exit _exit @@ -364,7 +362,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-3.6 { Tcl_Main: startup script sets main loop and closes stdin } -constraints { - exec Tcltest + exec tcl::test } -setup { makeFile { close stdin @@ -393,7 +391,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-3.7 { Tcl_Main: startup script deletes interp } -constraints { - exec Tcltest + exec tcl::test } -setup { makeFile { rename exit _exit @@ -417,7 +415,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-3.8 { Tcl_Main: startup script deletes interp and sets mainloop } -constraints { - exec Tcltest + exec tcl::test } -setup { makeFile { testsetmainloop @@ -461,7 +459,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-4.1 { Tcl_Main: rcFile evaluation deletes interp } -constraints { - exec Tcltest + exec tcl::test } -setup { set rc [makeFile {testinterpdelete {}} rc] } -body { @@ -478,7 +476,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-4.2 { Tcl_Main: rcFile evaluation closes stdin } -constraints { - exec Tcltest + exec tcl::test } -setup { set rc [makeFile {close stdin} rc] } -body { @@ -495,7 +493,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-4.3 { Tcl_Main: rcFile evaluation closes stdin and sets main loop } -constraints { - exec Tcltest + exec tcl::test } -setup { set rc [makeFile { close stdin @@ -523,7 +521,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-4.4 { Tcl_Main: rcFile evaluation sets main loop } -constraints { - exec Tcltest + exec tcl::test } -setup { set rc [makeFile { testsetmainloop @@ -550,7 +548,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-4.5 { Tcl_Main: Bug 1481986 } -constraints { - exec Tcltest + exec tcl::test } -setup { set rc [makeFile { testsetmainloop @@ -698,7 +696,7 @@ namespace eval ::tcl::test::main { Tcl_Main: interactive mode: close stdin -> main loop & [exit] & exit handlers } -constraints { - exec Tcltest + exec tcl::test } -body { exec [interpreter] << { rename exit _exit @@ -722,7 +720,7 @@ namespace eval ::tcl::test::main { Tcl_Main: interactive mode: delete interp -> main loop & exit handlers, but no [exit] } -constraints { - exec Tcltest + exec tcl::test } -body { exec [interpreter] << { rename exit _exit @@ -745,7 +743,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-5.10 { Tcl_Main: exit main loop in mid-interactive command } -constraints { - exec Tcltest + exec tcl::test } -setup { catch {set f [open "|[list [interpreter]]" w+]} catch {chan configure $f -blocking 0} @@ -766,7 +764,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-5.11 { Tcl_Main: EOF in interactive main loop } -constraints { - exec Tcltest + exec tcl::test } -body { exec [interpreter] << { rename exit _exit @@ -788,7 +786,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-5.12 { Tcl_Main: close stdin in interactive main loop } -constraints { - exec Tcltest + exec tcl::test } -body { exec [interpreter] << { rename exit _exit @@ -841,7 +839,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-6.2 { Tcl_Main: prompt deletes interp } -constraints { - exec Tcltest + exec tcl::test } -body { exec [interpreter] << { set tcl_prompt1 {testinterpdelete {}} @@ -893,7 +891,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-6.5 { Tcl_Main: interactive entry to main loop } -constraints { - exec Tcltest + exec tcl::test } -body { exec [interpreter] << { set tcl_interactive 1 @@ -943,7 +941,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-7.1 { Tcl_Main: [exit] defined as no-op -> still have exithandlers } -constraints { - exec Tcltest + exec tcl::test } -body { exec [interpreter] << { proc exit args {} @@ -959,7 +957,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-7.2 { Tcl_Main: [exit] defined as no-op -> still have exithandlers } -constraints { - exec Tcltest + exec tcl::test } -body { exec [interpreter] << { proc exit args {} @@ -979,7 +977,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-8.1 { StdinProc: handles non-blocking stdin } -constraints { - exec Tcltest + exec tcl::test } -body { exec [interpreter] << { testsetmainloop @@ -996,7 +994,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-8.2 { StdinProc: handles stdin EOF } -constraints { - exec Tcltest + exec tcl::test } -body { exec [interpreter] << { testsetmainloop @@ -1018,7 +1016,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-8.3 { StdinProc: handles interactive stdin EOF } -constraints { - exec Tcltest + exec tcl::test } -body { exec [interpreter] << { testsetmainloop @@ -1039,7 +1037,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-8.4 { StdinProc: handles stdin close } -constraints { - exec Tcltest + exec tcl::test } -body { exec [interpreter] << { testsetmainloop @@ -1062,7 +1060,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-8.5 { StdinProc: handles interactive stdin close } -constraints { - exec Tcltest + exec tcl::test } -body { exec [interpreter] << { testsetmainloop @@ -1086,7 +1084,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-8.6 { StdinProc: handles event loop re-entry } -constraints { - exec Tcltest + exec tcl::test } -body { exec [interpreter] << { testsetmainloop @@ -1105,7 +1103,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-8.7 { StdinProc: handling of errors } -constraints { - exec Tcltest + exec tcl::test } -body { exec [interpreter] << { testsetmainloop @@ -1122,7 +1120,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-8.8 { StdinProc: handling of errors, closed stderr } -constraints { - exec Tcltest + exec tcl::test } -body { exec [interpreter] << { testsetmainloop @@ -1140,7 +1138,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-8.9 { StdinProc: interactive output } -constraints { - exec Tcltest + exec tcl::test } -body { exec [interpreter] << { testsetmainloop @@ -1156,7 +1154,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-8.10 { StdinProc: interactive output, closed stdout } -constraints { - exec Tcltest + exec tcl::test } -body { exec [interpreter] << { testsetmainloop @@ -1174,7 +1172,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-8.11 { StdinProc: prompt deletes interp } -constraints { - exec Tcltest + exec tcl::test } -body { exec [interpreter] << { testsetmainloop @@ -1190,7 +1188,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-8.12 { StdinProc: prompt closes stdin } -constraints { - exec Tcltest + exec tcl::test } -body { exec [interpreter] << { testsetmainloop @@ -1209,7 +1207,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-8.13 { Bug 1775878 } -constraints { - exec Tcltest + exec tcl::test } -body { exec [interpreter] << "testsetmainloop\nputs \\\npwd\ntestexitmainloop" >& result set f [open result] diff --git a/tests/misc.test b/tests/misc.test index 8f8516e..431fa19 100644 --- a/tests/misc.test +++ b/tests/misc.test @@ -18,7 +18,7 @@ if {"::tcltest" ni [namespace children]} { } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testhashsystemhash [llength [info commands testhashsystemhash]] diff --git a/tests/namespace.test b/tests/namespace.test index 8209cf3..2caf1c4 100644 --- a/tests/namespace.test +++ b/tests/namespace.test @@ -19,7 +19,7 @@ if {"::tcltest" ni [namespace children]} { testConstraint memory [llength [info commands memory]] ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] # # REMARK: the tests for 'namespace upvar' are not done here. They are to be diff --git a/tests/notify.test b/tests/notify.test index 7375f83..d83a5b8 100644 --- a/tests/notify.test +++ b/tests/notify.test @@ -19,7 +19,7 @@ if {"::tcltest" ni [namespace children]} { } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testevent [llength [info commands testevent]] diff --git a/tests/nre.test b/tests/nre.test index 7cf06d1..aec188c 100644 --- a/tests/nre.test +++ b/tests/nre.test @@ -15,7 +15,7 @@ if {"::tcltest" ni [namespace children]} { } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testnrelevels [llength [info commands testnrelevels]] diff --git a/tests/obj.test b/tests/obj.test index e10cebf..66005f6 100644 --- a/tests/obj.test +++ b/tests/obj.test @@ -17,7 +17,7 @@ if {"::tcltest" ni [namespace children]} { } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testobj [llength [info commands testobj]] testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}] diff --git a/tests/oo.test b/tests/oo.test index 0dc26f2..2a72263 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -7,7 +7,7 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require TclOO 1.0.3 +package require tcl::oo 1.0.3 if {"::tcltest" ni [namespace children]} { package require tcltest 2.5 namespace import -force ::tcltest::* @@ -38,14 +38,14 @@ if {[testConstraint memory]} { test oo-0.1 {basic test of OO's ability to clean up its initial state} { interp create t t eval { - package require TclOO + package require tcl::oo } interp delete t } {} test oo-0.2 {basic test of OO's ability to clean up its initial state} { set i [interp create] interp eval $i { - package require TclOO + package require tcl::oo namespace delete :: } interp delete $i @@ -79,7 +79,7 @@ test oo-0.6 {cleaning the core class pair; way #1} -setup { interp create t } -body { t eval { - package require TclOO + package require tcl::oo namespace path oo list [catch {class destroy} m] $m [catch {object destroy} m] $m } @@ -90,7 +90,7 @@ test oo-0.7 {cleaning the core class pair; way #2} -setup { interp create t } -body { t eval { - package require TclOO + package require tcl::oo namespace path oo list [catch {object destroy} m] $m [catch {class destroy} m] $m } @@ -109,10 +109,10 @@ test oo-0.8 {leak in variable management} -setup { } -cleanup { foo destroy } -result 0 -test oo-0.9 {various types of presence of the TclOO package} { - list [lsearch -nocase -all -inline [package names] tcloo] \ - [package present TclOO] [expr {$::oo::patchlevel in [package versions TclOO]}] -} [list TclOO $::oo::patchlevel 1] +test oo-0.9 {various types of presence of the tcl::oo package} { + list [lsearch -nocase -all -inline [package names] tcl::oo] \ + [package present tcl::oo] [expr {$::oo::patchlevel in [package versions tcl::oo]}] +} [list tcl::oo $::oo::patchlevel 1] test oo-1.1 {basic test of OO functionality: no classes} { set result {} @@ -383,7 +383,7 @@ test oo-2.1 {basic test of OO functionality: constructor} -setup { # we're modifying the root object class's constructor interp create subinterp subinterp eval { - package require TclOO + package require tcl::oo } } -body { subinterp eval { @@ -514,7 +514,7 @@ test oo-3.1 {basic test of OO functionality: destructor} -setup { # modifying the root object class's constructor interp create subinterp subinterp eval { - package require TclOO + package require tcl::oo } } -body { subinterp eval { @@ -534,7 +534,7 @@ test oo-3.2 {basic test of OO functionality: destructor} -setup { # we're modifying the root object class's constructor interp create subinterp subinterp eval { - package require TclOO + package require tcl::oo } } -body { subinterp eval { diff --git a/tests/ooNext2.test b/tests/ooNext2.test index 0ec7cdd..6c12962 100644 --- a/tests/ooNext2.test +++ b/tests/ooNext2.test @@ -7,7 +7,7 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require TclOO 1.0.3 +package require tcl::oo 1.0.3 if {"::tcltest" ni [namespace children]} { package require tcltest 2.5 namespace import -force ::tcltest::* diff --git a/tests/ooUtil.test b/tests/ooUtil.test index 7fc9b9c..606b625 100644 --- a/tests/ooUtil.test +++ b/tests/ooUtil.test @@ -9,7 +9,7 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require TclOO 1.0.3 +package require tcl::oo 1.0.3 if {"::tcltest" ni [namespace children]} { package require tcltest 2.5 namespace import -force ::tcltest::* diff --git a/tests/package.test b/tests/package.test index 1223d82..fdaf023 100644 --- a/tests/package.test +++ b/tests/package.test @@ -18,7 +18,7 @@ if {"::tcltest" ni [namespace children]} { } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] # Do all this in a child interp to avoid garbaging the package list set i [interp create] @@ -1340,7 +1340,7 @@ proc prefer {args} { test package-13.0 {package prefer defaults} -body { prefer -} -result [expr {[string match {*[ab]*} [package provide Tcl]] ? "latest" : "stable"}] +} -result [expr {[string match {*[ab]*} [package provide tcl]] ? "latest" : "stable"}] test package-13.1 {package prefer defaults} -body { set ::env(TCL_PKG_PREFER_LATEST) stable ;# value not relevant! prefer diff --git a/tests/parse.test b/tests/parse.test index 94c7f74..be32815 100644 --- a/tests/parse.test +++ b/tests/parse.test @@ -17,7 +17,7 @@ namespace eval ::tcl::test::parse { namespace import ::tcltest::* ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testparser [llength [info commands testparser]] testConstraint testbytestring [llength [info commands testbytestring]] diff --git a/tests/parseExpr.test b/tests/parseExpr.test index 8b5e429..3fbd14e 100644 --- a/tests/parseExpr.test +++ b/tests/parseExpr.test @@ -14,7 +14,7 @@ if {"::tcltest" ni [namespace children]} { } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] # Note that the Tcl expression parser (tclCompExpr.c) does not check # the semantic validity of the expressions it parses. It does not check, diff --git a/tests/parseOld.test b/tests/parseOld.test index 134a3c2..3c79882 100644 --- a/tests/parseOld.test +++ b/tests/parseOld.test @@ -19,7 +19,7 @@ if {"::tcltest" ni [namespace children]} { } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testwordend [llength [info commands testwordend]] testConstraint testbytestring [llength [info commands testbytestring]] diff --git a/tests/platform.test b/tests/platform.test index fff16fd..bdc9995 100644 --- a/tests/platform.test +++ b/tests/platform.test @@ -21,7 +21,7 @@ namespace eval ::tcl::test::platform { namespace upvar :: tcl_platform tcl_platform ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] package require tcltests testConstraint testCPUID [llength [info commands testcpuid]] diff --git a/tests/proc.test b/tests/proc.test index 7039dbb..d4eac60 100644 --- a/tests/proc.test +++ b/tests/proc.test @@ -18,7 +18,7 @@ if {"::tcltest" ni [namespace children]} { namespace import -force ::tcltest::* } -testConstraint procbodytest [expr {![catch {package require procbodytest}]}] +testConstraint tcl::test [expr {![catch {package require tcl::test}]}] testConstraint memory [llength [info commands memory]] catch {namespace delete {*}[namespace children :: test_ns_*]} @@ -210,14 +210,14 @@ catch {rename p ""} catch {rename t ""} # Note that the test require that procedures whose body is used to create -# procbody objects must be executed before the procbodytest::proc command is +# procbody objects must be executed before the tcl::procbodytest::proc command is # executed, so that the Proc struct is populated correctly (CompiledLocals are # added at compile time). -test proc-4.1 {TclCreateProc, procbody obj} -constraints procbodytest -body { +test proc-4.1 {TclCreateProc, procbody obj} -constraints tcl::test -body { proc p x {return "$x:$x"} set rv [p P] - procbodytest::proc t x p + tcl::procbodytest::proc t x p lappend rv [t T] } -cleanup { catch {rename p ""} @@ -229,9 +229,9 @@ test proc-4.2 {TclCreateProc, procbody obj, use compiled locals} -body { return "$x:$y" } set rv [p P] - procbodytest::proc t x p + tcl::procbodytest::proc t x p lappend rv [t T] -} -constraints procbodytest -cleanup { +} -constraints tcl::test -cleanup { catch {rename p ""} catch {rename t ""} } -result {P:p T:t} @@ -241,9 +241,9 @@ test proc-4.3 {TclCreateProc, procbody obj, too many args} -body { return "$x:$y" } set rv [p P] - procbodytest::proc t {x x1 x2} p + tcl::procbodytest::proc t {x x1 x2} p lappend rv [t T] -} -constraints procbodytest -returnCodes error -cleanup { +} -constraints tcl::test -returnCodes error -cleanup { catch {rename p ""} catch {rename t ""} } -result {procedure "t": arg list contains 3 entries, precompiled header expects 1} @@ -254,9 +254,9 @@ test proc-4.4 {TclCreateProc, procbody obj, inconsistent arg name} -body { return "$v:$w" } set rv [p P Q R] - procbodytest::proc t {x x1 z} p + tcl::procbodytest::proc t {x x1 z} p lappend rv [t S T U] -} -constraints procbodytest -returnCodes error -cleanup { +} -constraints tcl::test -returnCodes error -cleanup { catch {rename p ""} catch {rename t ""} } -result {procedure "t": formal parameter 1 is inconsistent with precompiled body} @@ -267,9 +267,9 @@ test proc-4.5 {TclCreateProc, procbody obj, inconsistent arg default type} -body return "$v:$w" } set rv [p P Q R] - procbodytest::proc t {x y z} p + tcl::procbodytest::proc t {x y z} p lappend rv [t S T U] -} -constraints procbodytest -returnCodes error -cleanup { +} -constraints tcl::test -returnCodes error -cleanup { catch {rename p ""} catch {rename t ""} } -result {procedure "t": formal parameter 2 is inconsistent with precompiled body} @@ -280,9 +280,9 @@ test proc-4.6 {TclCreateProc, procbody obj, inconsistent arg default type} -body return "$v:$w" } set rv [p P Q R] - procbodytest::proc t {x y {z Z}} p + tcl::procbodytest::proc t {x y {z Z}} p lappend rv [t S T U] -} -returnCodes error -constraints procbodytest -cleanup { +} -returnCodes error -constraints tcl::test -cleanup { catch {rename p ""} catch {rename t ""} } -result {procedure "t": formal parameter 2 is inconsistent with precompiled body} @@ -293,9 +293,9 @@ test proc-4.7 {TclCreateProc, procbody obj, inconsistent arg default value} -bod return "$v:$w" } set rv [p P Q R] - procbodytest::proc t {x y {z ZZ}} p + tcl::procbodytest::proc t {x y {z ZZ}} p lappend rv [t S T U] -} -constraints procbodytest -returnCodes error -cleanup { +} -constraints tcl::test -returnCodes error -cleanup { catch {rename p ""} catch {rename t ""} } -result {procedure "t": formal parameter "z" has default value inconsistent with precompiled body} @@ -309,10 +309,10 @@ test proc-4.8 {TclCreateProc, procbody obj, no leak on multiple iterations} -set return "$x:$y" } px x -} -constraints {procbodytest memory} -body { +} -constraints {tcl::test memory} -body { set end [getbytes] for {set i 0} {$i < 5} {incr i} { - procbodytest::proc tx x px + tcl::procbodytest::proc tx x px set tmp $end set end [getbytes] } @@ -321,8 +321,8 @@ test proc-4.8 {TclCreateProc, procbody obj, no leak on multiple iterations} -set rename getbytes {} unset -nocomplain end i tmp leakedBytes } -result 0 -test proc-4.9 {[39fed4dae5] Valid Tcl_PkgPresent return} procbodytest { - procbodytest::check +test proc-4.9 {[39fed4dae5] Valid Tcl_PkgPresent return} tcl::test { + tcl::procbodytest::check } 1 test proc-5.1 {Bytecompiling noop; test for correct argument substitution} -body { diff --git a/tests/reg.test b/tests/reg.test index 847da32..add8e91 100644 --- a/tests/reg.test +++ b/tests/reg.test @@ -15,7 +15,7 @@ if {"::tcltest" ni [namespace children]} { } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] # All tests require the testregexp command, return if this # command doesn't exist diff --git a/tests/rename.test b/tests/rename.test index ddda909..702a6d0 100644 --- a/tests/rename.test +++ b/tests/rename.test @@ -17,7 +17,7 @@ if {"::tcltest" ni [namespace children]} { } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testdel [llength [info commands testdel]] diff --git a/tests/resolver.test b/tests/resolver.test index 9916529..8693cdc 100644 --- a/tests/resolver.test +++ b/tests/resolver.test @@ -16,7 +16,7 @@ if {"::tcltest" ni [namespace children]} { } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testinterpresolver [llength [info commands testinterpresolver]] diff --git a/tests/result.test b/tests/result.test index f1f5fb7..7790578 100644 --- a/tests/result.test +++ b/tests/result.test @@ -16,7 +16,7 @@ if {"::tcltest" ni [namespace children]} { } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] # Some tests require the testsaveresult command diff --git a/tests/safe-zipfs.test b/tests/safe-zipfs.test index 73703e4..bbae4ba 100644 --- a/tests/safe-zipfs.test +++ b/tests/safe-zipfs.test @@ -13,8 +13,6 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require Tcl 8.5- - if {"::tcltest" ni [namespace children]} { package require tcltest 2.5 namespace import -force ::tcltest::* @@ -53,10 +51,10 @@ proc mapAndSortList {map listIn} { # thus un-autoindexed) APIs in this test result arguments: catch {safe::interpConfigure} -# testing that nested and statics do what is advertised (we use a static -# package - Tcltest - but it might be absent if we're in standard tclsh) +# testing that nested and statics do what is advertised (we use a +# package - tcl::test - but it might be absent if we're in standard tclsh) -testConstraint TcltestPackage [expr {![catch {package require Tcltest}]}] +testConstraint tcl::test [expr {![catch {package require tcl::test}]}] # Tests 5.* test the example files before using them to test safe interpreters. diff --git a/tests/safe.test b/tests/safe.test index ebaedabe..888a05e 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -54,9 +54,9 @@ proc mapAndSortList {map listIn} { catch {safe::interpConfigure} # testing that nested and statics do what is advertised (we use a static -# package - Tcltest - but it might be absent if we're in standard tclsh) +# package - tcl::test - but it might be absent if we're in standard tclsh) -testConstraint TcltestPackage [expr {![catch {package require Tcltest}]}] +testConstraint tcl::test [expr {![catch {package require tcl::test}]}] test safe-1.1 {safe::interpConfigure syntax} -returnCodes error -body { safe::interpConfigure @@ -1158,14 +1158,14 @@ test safe-9.24 {interpConfigure change the access path; check module loading; st # See comments on lsort after test safe-9.20. catch {teststaticpkg Safepkg1 0 0} -test safe-10.1 {testing statics loading} -constraints TcltestPackage -setup { +test safe-10.1 {testing statics loading} -constraints tcl::test -setup { set i [safe::interpCreate] } -body { interp eval $i {load {} Safepkg1} } -returnCodes error -cleanup { safe::interpDelete $i } -result {load of binary library for package Safepkg1 failed: can't use package in a safe interpreter: no Safepkg1_SafeInit procedure} -test safe-10.1.1 {testing statics loading} -constraints TcltestPackage -setup { +test safe-10.1.1 {testing statics loading} -constraints tcl::test -setup { set i [safe::interpCreate] } -body { catch {interp eval $i {load {} Safepkg1}} m o @@ -1178,7 +1178,7 @@ test safe-10.1.1 {testing statics loading} -constraints TcltestPackage -setup { "load {} Safepkg1" invoked from within "interp eval $i {load {} Safepkg1}"} -test safe-10.2 {testing statics loading / -nostatics} -constraints TcltestPackage -body { +test safe-10.2 {testing statics loading / -nostatics} -constraints tcl::test -body { set i [safe::interpCreate -nostatics] interp eval $i {load {} Safepkg1} } -returnCodes error -cleanup { @@ -1186,18 +1186,18 @@ test safe-10.2 {testing statics loading / -nostatics} -constraints TcltestPackag } -result {permission denied (static package)} test safe-10.3 {testing nested statics loading / no nested by default} -setup { set i [safe::interpCreate] -} -constraints TcltestPackage -body { +} -constraints tcl::test -body { interp eval $i {interp create x; load {} Safepkg1 x} } -returnCodes error -cleanup { safe::interpDelete $i } -result {permission denied (nested load)} -test safe-10.4 {testing nested statics loading / -nestedloadok} -constraints TcltestPackage -body { +test safe-10.4 {testing nested statics loading / -nestedloadok} -constraints tcl::test -body { set i [safe::interpCreate -nestedloadok] interp eval $i {interp create x; load {} Safepkg1 x} } -returnCodes error -cleanup { safe::interpDelete $i } -result {load of binary library for package Safepkg1 failed: can't use package in a safe interpreter: no Safepkg1_SafeInit procedure} -test safe-10.4.1 {testing nested statics loading / -nestedloadok} -constraints TcltestPackage -body { +test safe-10.4.1 {testing nested statics loading / -nestedloadok} -constraints tcl::test -body { set i [safe::interpCreate -nestedloadok] catch {interp eval $i {interp create x; load {} Safepkg1 x}} m o dict get $o -errorinfo diff --git a/tests/set.test b/tests/set.test index 303c2d7..30c6c6d 100644 --- a/tests/set.test +++ b/tests/set.test @@ -16,7 +16,7 @@ if {"::tcltest" ni [namespace children]} { } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testset2 [llength [info commands testset2]] diff --git a/tests/socket.test b/tests/socket.test index 868c17a..3be76f3 100644 --- a/tests/socket.test +++ b/tests/socket.test @@ -66,7 +66,7 @@ if {"::tcltest" ni [namespace children]} { } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] ::tcltest::loadTestedCommands if {[expr {[info exists ::env(TRAVIS_OSX_IMAGE)] && [string match xcode* $::env(TRAVIS_OSX_IMAGE)]}]} { diff --git a/tests/string.test b/tests/string.test index 4a8746d..2efc036 100644 --- a/tests/string.test +++ b/tests/string.test @@ -18,7 +18,7 @@ if {"::tcltest" ni [namespace children]} { } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] # Helper commands to test various optimizations, code paths, and special cases. proc makeByteArray {s} {binary format a* $s} diff --git a/tests/stringObj.test b/tests/stringObj.test index ca6c323..ed43924 100644 --- a/tests/stringObj.test +++ b/tests/stringObj.test @@ -18,7 +18,7 @@ if {"::tcltest" ni [namespace children]} { } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testobj [llength [info commands testobj]] testConstraint testbytestring [llength [info commands testbytestring]] diff --git a/tests/subst.test b/tests/subst.test index 42d1bec..33b513f 100644 --- a/tests/subst.test +++ b/tests/subst.test @@ -16,7 +16,7 @@ if {"::tcltest" ni [namespace children]} { namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testbytestring [llength [info commands testbytestring]] diff --git a/tests/tailcall.test b/tests/tailcall.test index 3704333..10945db 100644 --- a/tests/tailcall.test +++ b/tests/tailcall.test @@ -15,7 +15,7 @@ if {"::tcltest" ni [namespace children]} { } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testnrelevels [llength [info commands testnrelevels]] diff --git a/tests/thread.test b/tests/thread.test index 0a35d1b..262192b 100644 --- a/tests/thread.test +++ b/tests/thread.test @@ -20,7 +20,7 @@ if {"::tcltest" ni [namespace children]} { # be fully finalized, which avoids valgrind "still reachable" reports. ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] package require tcltests # Some tests require the testthread command diff --git a/tests/trace.test b/tests/trace.test index 3703216..b8cf28e 100644 --- a/tests/trace.test +++ b/tests/trace.test @@ -17,7 +17,7 @@ if {"::tcltest" ni [namespace children]} { } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testcmdtrace [llength [info commands testcmdtrace]] testConstraint testevalobjv [llength [info commands testevalobjv]] diff --git a/tests/unixFCmd.test b/tests/unixFCmd.test index 1ecaeef..ebc55dc 100644 --- a/tests/unixFCmd.test +++ b/tests/unixFCmd.test @@ -15,7 +15,7 @@ if {"::tcltest" ni [namespace children]} { } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testchmod [llength [info commands testchmod]] diff --git a/tests/unixFile.test b/tests/unixFile.test index 492e5d0..2ba758b 100644 --- a/tests/unixFile.test +++ b/tests/unixFile.test @@ -15,7 +15,7 @@ if {"::tcltest" ni [namespace children]} { } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testfindexecutable [llength [info commands testfindexecutable]] diff --git a/tests/unload.test b/tests/unload.test index 815ff31..3ed4ac0 100644 --- a/tests/unload.test +++ b/tests/unload.test @@ -17,7 +17,7 @@ if {"::tcltest" ni [namespace children]} { } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] # Figure out what extension is used for shared libraries on this # platform. diff --git a/tests/upvar.test b/tests/upvar.test index 9e44a79..170721f 100644 --- a/tests/upvar.test +++ b/tests/upvar.test @@ -17,7 +17,7 @@ if {"::tcltest" ni [namespace children]} { } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testupvar [llength [info commands testupvar]] diff --git a/tests/utf.test b/tests/utf.test index 935830c..eacff20 100644 --- a/tests/utf.test +++ b/tests/utf.test @@ -14,7 +14,7 @@ if {"::tcltest" ni [namespace children]} { } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint ucs2 [expr {[format %c 0x010000] eq "\uFFFD"}] testConstraint fullutf [expr {[format %c 0x010000] ne "\uFFFD"}] diff --git a/tests/util.test b/tests/util.test index d8e5507..9dadcb9 100644 --- a/tests/util.test +++ b/tests/util.test @@ -13,7 +13,7 @@ if {"::tcltest" ni [namespace children]} { } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint controversialNaN 1 testConstraint testbytestring [llength [info commands testbytestring]] diff --git a/tests/var.test b/tests/var.test index 72873b7..6d50a92 100644 --- a/tests/var.test +++ b/tests/var.test @@ -20,7 +20,7 @@ if {"::tcltest" ni [namespace children]} { } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testupvar [llength [info commands testupvar]] testConstraint testgetvarfullname [llength [info commands testgetvarfullname]] diff --git a/tests/winFCmd.test b/tests/winFCmd.test index ef62cec..7003f0a 100644 --- a/tests/winFCmd.test +++ b/tests/winFCmd.test @@ -16,7 +16,7 @@ if {"::tcltest" ni [namespace children]} { } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] # Initialise the test constraints diff --git a/tests/winFile.test b/tests/winFile.test index d8d1b7c..c18cdff 100644 --- a/tests/winFile.test +++ b/tests/winFile.test @@ -16,7 +16,7 @@ if {"::tcltest" ni [namespace children]} { } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testvolumetype [llength [info commands testvolumetype]] testConstraint notNTFS 0 diff --git a/tests/winNotify.test b/tests/winNotify.test index 0433b4a..05682b4 100644 --- a/tests/winNotify.test +++ b/tests/winNotify.test @@ -16,7 +16,7 @@ if {"::tcltest" ni [namespace children]} { } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testeventloop [expr {[info commands testeventloop] != {}}] diff --git a/tests/winPipe.test b/tests/winPipe.test index 0263823..1c53fc8 100644 --- a/tests/winPipe.test +++ b/tests/winPipe.test @@ -20,8 +20,8 @@ unset -nocomplain path catch { ::tcltest::loadTestedCommands - package require -exact Tcltest [info patchlevel] - set ::tcltestlib [lindex [package ifneeded Tcltest [info patchlevel]] 1] + package require -exact tcl::test [info patchlevel] + set ::tcltestlib [lindex [package ifneeded tcl::test [info patchlevel]] 1] } set org_pwd [pwd] diff --git a/tests/winTime.test b/tests/winTime.test index 19e4c58..c03e316 100644 --- a/tests/winTime.test +++ b/tests/winTime.test @@ -16,7 +16,7 @@ if {"::tcltest" ni [namespace children]} { } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testwinclock [llength [info commands testwinclock]] testConstraint knownMsvcBug [expr {![info exists ::env(TRAVIS_OS_NAME)] || ![string match windows $::env(TRAVIS_OS_NAME)]}] diff --git a/tools/makeHeader.tcl b/tools/makeHeader.tcl index dd2f199..6b5e31b 100644 --- a/tools/makeHeader.tcl +++ b/tools/makeHeader.tcl @@ -8,7 +8,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require Tcl 8.6 +package require Tcl 8.6- namespace eval makeHeader { diff --git a/win/Makefile.in b/win/Makefile.in index 07c1da3..dab6ac9 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -158,7 +158,7 @@ TEST_LIB_FILE = @LIBPREFIX@tcltest$(VER)${LIBSUFFIX} TEST_LOAD_PRMS = lappend ::auto_path {$(ROOT_DIR_WIN_NATIVE)/tests};\ package ifneeded dde 1.4.3 [list load [file normalize ${DDE_DLL_FILE}] dde];\ package ifneeded registry 1.3.5 [list load [file normalize ${REG_DLL_FILE}] registry] -TEST_LOAD_FACILITIES = package ifneeded Tcltest ${VERSION}@TCL_PATCH_LEVEL@ [list load [file normalize ${TEST_DLL_FILE}] Tcltest];\ +TEST_LOAD_FACILITIES = package ifneeded tcl::test ${VERSION}@TCL_PATCH_LEVEL@ [list load [file normalize ${TEST_DLL_FILE}] Tcltest];\ $(TEST_LOAD_PRMS) ZLIB_DLL_FILE = zlib1.dll TOMMATH_DLL_FILE = libtommath.dll -- cgit v0.12 From 9f5653ac08b3a5cae03a647291668cb9551afd64 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 3 Nov 2020 11:25:57 +0000 Subject: Fix clang++ build --- generic/tclLoad.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclLoad.c b/generic/tclLoad.c index dab4d64..6301036 100644 --- a/generic/tclLoad.c +++ b/generic/tclLoad.c @@ -369,7 +369,7 @@ Tcl_LoadObjCmd( while (strchr(Tcl_DStringValue(&pkgName), ':') != NULL) { char *r; p = Tcl_DStringValue(&pkgName); - r = strchr(p, ':'); + r = strchr((char *)p, ':'); if ((r != NULL) && (r[1] == ':')) { memmove(r, r+2, strlen(r+1)); } -- cgit v0.12 From e6def0aaaf6347bbe2346a9112efd3a2c59dc985 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 3 Nov 2020 12:14:25 +0000 Subject: Make everything work on Windows, using loaded tcl::test package --- generic/tclLoad.c | 49 +++++++++++++++---------------------------------- 1 file changed, 15 insertions(+), 34 deletions(-) diff --git a/generic/tclLoad.c b/generic/tclLoad.c index 6301036..efa2d95 100644 --- a/generic/tclLoad.c +++ b/generic/tclLoad.c @@ -226,14 +226,8 @@ Tcl_LoadObjCmd( Tcl_DStringAppend(&pkgName, packageName, -1); TclDStringClear(&tmp); Tcl_DStringAppend(&tmp, pkgPtr->packageName, -1); - Tcl_UtfToLower(Tcl_DStringValue(&pkgName)); - Tcl_UtfToLower(Tcl_DStringValue(&tmp)); - if (strcmp(Tcl_DStringValue(&tmp), + namesMatch = (strcmp(Tcl_DStringValue(&tmp), Tcl_DStringValue(&pkgName)) == 0) { - namesMatch = 1; - } else { - namesMatch = 0; - } } TclDStringClear(&pkgName); @@ -359,36 +353,29 @@ Tcl_LoadObjCmd( } /* - * Fix the capitalization in the package name so that the first - * character is in caps (or title case) but the others are all - * lower-case. + * Compute the names of the initialization functions, based on the + * package name. */ - Tcl_DStringSetLength(&pkgName, - Tcl_UtfToTitle(Tcl_DStringValue(&pkgName))); - while (strchr(Tcl_DStringValue(&pkgName), ':') != NULL) { + TclDStringAppendDString(&initName, &pkgName); + Tcl_DStringSetLength(&initName, + Tcl_UtfToTitle(Tcl_DStringValue(&initName))); + while (strchr(Tcl_DStringValue(&initName), ':') != NULL) { char *r; - p = Tcl_DStringValue(&pkgName); + p = Tcl_DStringValue(&initName); r = strchr((char *)p, ':'); if ((r != NULL) && (r[1] == ':')) { memmove(r, r+2, strlen(r+1)); } - Tcl_DStringSetLength(&pkgName, strlen(p)); + Tcl_DStringSetLength(&initName, strlen(p)); } - - /* - * Compute the names of the two initialization functions, based on the - * package name. - */ - - TclDStringAppendDString(&initName, &pkgName); - TclDStringAppendLiteral(&initName, "_Init"); - TclDStringAppendDString(&safeInitName, &pkgName); + TclDStringAppendDString(&safeInitName, &initName); TclDStringAppendLiteral(&safeInitName, "_SafeInit"); - TclDStringAppendDString(&unloadName, &pkgName); + TclDStringAppendDString(&unloadName, &initName); TclDStringAppendLiteral(&unloadName, "_Unload"); - TclDStringAppendDString(&safeUnloadName, &pkgName); + TclDStringAppendDString(&safeUnloadName, &initName); TclDStringAppendLiteral(&safeUnloadName, "_SafeUnload"); + TclDStringAppendLiteral(&initName, "_Init"); /* * Call platform-specific code to load the package and find the two @@ -672,14 +659,8 @@ Tcl_UnloadObjCmd( Tcl_DStringAppend(&pkgName, packageName, -1); TclDStringClear(&tmp); Tcl_DStringAppend(&tmp, pkgPtr->packageName, -1); - Tcl_UtfToLower(Tcl_DStringValue(&pkgName)); - Tcl_UtfToLower(Tcl_DStringValue(&tmp)); - if (strcmp(Tcl_DStringValue(&tmp), - Tcl_DStringValue(&pkgName)) == 0) { - namesMatch = 1; - } else { - namesMatch = 0; - } + namesMatch = (strcmp(Tcl_DStringValue(&tmp), + Tcl_DStringValue(&pkgName)) == 0) } TclDStringClear(&pkgName); -- cgit v0.12 From 9d07732ca0a2cffa898fcbcc3cd7036dbc0249a4 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 3 Nov 2020 14:24:32 +0000 Subject: Fix build/testcases on UNIX/Mac --- generic/tclLoad.c | 4 ++-- tests/load.test | 16 ++++++++-------- tests/unload.test | 18 +++++++++--------- 3 files changed, 19 insertions(+), 19 deletions(-) diff --git a/generic/tclLoad.c b/generic/tclLoad.c index efa2d95..bea07ed 100644 --- a/generic/tclLoad.c +++ b/generic/tclLoad.c @@ -227,7 +227,7 @@ Tcl_LoadObjCmd( TclDStringClear(&tmp); Tcl_DStringAppend(&tmp, pkgPtr->packageName, -1); namesMatch = (strcmp(Tcl_DStringValue(&tmp), - Tcl_DStringValue(&pkgName)) == 0) { + Tcl_DStringValue(&pkgName)) == 0); } TclDStringClear(&pkgName); @@ -660,7 +660,7 @@ Tcl_UnloadObjCmd( TclDStringClear(&tmp); Tcl_DStringAppend(&tmp, pkgPtr->packageName, -1); namesMatch = (strcmp(Tcl_DStringValue(&tmp), - Tcl_DStringValue(&pkgName)) == 0) + Tcl_DStringValue(&pkgName)) == 0); } TclDStringClear(&pkgName); diff --git a/tests/load.test b/tests/load.test index b188895..f6e68b9 100644 --- a/tests/load.test +++ b/tests/load.test @@ -78,7 +78,7 @@ test load-2.1 {basic loading, with guess for package name} \ interp create -safe child test load-2.2 {loading into a safe interpreter, with package name conversion} \ [list $dll $loaded] { - load -lazy [file join $testDir pkgb$ext] pKgB child + load -lazy [file join $testDir pkgb$ext] pkgb child list [child eval pkgb_sub 44 13] [catch {child eval pkgb_unsafe} msg] $msg \ [catch {pkgb_sub 12 10} msg2] $msg2 } {31 1 {invalid command name "pkgb_unsafe"} 1 {invalid command name "pkgb_sub"}} @@ -90,7 +90,7 @@ test load-2.3 {loading with no _Init procedure} -constraints [list $dll $loaded] {TCL LOOKUP LOAD_SYMBOL *Foo_Init}] test load-2.4 {loading with no _SafeInit procedure} [list $dll $loaded] { list [catch {load [file join $testDir pkga$ext] {} child} msg] $msg -} {1 {can't use package in a safe interpreter: no Pkga_SafeInit procedure}} +} {1 {can't use package in a safe interpreter: no pkga_SafeInit procedure}} test load-3.1 {error in _Init procedure, same interpreter} \ [list $dll $loaded] { @@ -128,7 +128,7 @@ test load-4.2 {reloading package into same interpreter} -setup { catch {load [file join $testDir pkga$ext] pkga} } -constraints [list $dll $loaded] -returnCodes error -body { load [file join $testDir pkga$ext] pkgb -} -result "file \"[file join $testDir pkga$ext]\" is already loaded for package \"Pkga\"" +} -result "file \"[file join $testDir pkga$ext]\" is already loaded for package \"pkga\"" test load-5.1 {file name not specified and no static package: pick default} -setup { catch {interp delete x} @@ -139,7 +139,7 @@ test load-5.1 {file name not specified and no static package: pick default} -set info loaded x } -cleanup { interp delete x -} -result [list [list [file join $testDir pkga$ext] Pkga]] +} -result [list [list [file join $testDir pkga$ext] pkga]] # On some platforms, like SunOS 4.1.3, these tests can't be run because # they cause the process to exit. @@ -174,7 +174,7 @@ test load-7.3 {Tcl_StaticPackage procedure} [list teststaticpkg] { catch {load [file join $testDir pkga$ext] pkga} catch {load [file join $testDir pkgb$ext] pkgb} catch {load [file join $testDir pkge$ext] pkge} -set currentRealPackages [list [list [file join $testDir pkge$ext] Pkge] [list [file join $testDir pkgb$ext] Pkgb] [list [file join $testDir pkga$ext] Pkga]] +set currentRealPackages [list [list [file join $testDir pkge$ext] pkge] [list [file join $testDir pkgb$ext] pkgb] [list [file join $testDir pkga$ext] pkga]] test load-7.4 {Tcl_StaticPackage procedure, redundant calls} -setup { teststaticpkg test 1 0 teststaticpkg another 0 0 @@ -204,14 +204,14 @@ test load-8.2 {TclGetLoadedPackages procedure} -constraints {teststaticpkg_8.x} } -returnCodes error -result {could not find interpreter "gorp"} test load-8.3a {TclGetLoadedPackages procedure} [list teststaticpkg_8.x $dll $loaded] { lsort -index 1 [info loaded {}] -} [lsort -index 1 [list {{} double} {{} more} {{} another} {{} test} [list [file join $testDir pkga$ext] Pkga] [list [file join $testDir pkgb$ext] Pkgb] {*}$alreadyLoaded]] +} [lsort -index 1 [list {{} double} {{} more} {{} another} {{} test} [list [file join $testDir pkga$ext] pkga] [list [file join $testDir pkgb$ext] pkgb] {*}$alreadyLoaded]] test load-8.3b {TclGetLoadedPackages procedure} [list teststaticpkg_8.x $dll $loaded] { lsort -index 1 [info loaded child] -} [lsort -index 1 [list {{} test} [list [file join $testDir pkgb$ext] Pkgb]]] +} [lsort -index 1 [list {{} test} [list [file join $testDir pkgb$ext] pkgb]]] test load-8.4 {TclGetLoadedPackages procedure} [list teststaticpkg_8.x $dll $loaded] { load [file join $testDir pkgb$ext] pkgb list [lsort -index 1 [info loaded {}]] [lsort [info commands pkgb_*]] -} [list [lsort -index 1 [concat [list [list [file join $testDir pkgb$ext] Pkgb] {{} double} {{} more} {{} another} {{} test} [list [file join $testDir pkga$ext] Pkga]] $alreadyLoaded]] {pkgb_demo pkgb_sub pkgb_unsafe}] +} [list [lsort -index 1 [concat [list [list [file join $testDir pkgb$ext] pkgb] {{} double} {{} more} {{} another} {{} test} [list [file join $testDir pkga$ext] pkga]] $alreadyLoaded]] {pkgb_demo pkgb_sub pkgb_unsafe}] interp delete child test load-9.1 {Tcl_StaticPackage, load already-loaded package into another interp} -setup { diff --git a/tests/unload.test b/tests/unload.test index 3ed4ac0..ca007ef 100644 --- a/tests/unload.test +++ b/tests/unload.test @@ -135,17 +135,17 @@ child eval { set pkgua_detached {} set pkgua_unloaded {} } -test unload-3.1 {basic loading of non-unloadable package in a safe interpreter, with package name conversion} \ +test unload-3.1 {basic loading of non-unloadable package in a safe interpreter} \ [list $dll $loaded] { catch {rename pkgb_sub {}} - load [file join $testDir pkgb$ext] pKgB child + load [file join $testDir pkgb$ext] pkgb child list [child eval pkgb_sub 44 13] [catch {child eval pkgb_unsafe} msg] $msg \ [catch {pkgb_sub 12 10} msg2] $msg2 } {31 1 {invalid command name "pkgb_unsafe"} 1 {invalid command name "pkgb_sub"}} -test unload-3.2 {basic loading of unloadable package in a safe interpreter, with package name conversion} \ +test unload-3.2 {basic loading of unloadable package in a safe interpreter} \ [list $dll $loaded] { list [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \ - [load [file join $testDir pkgua$ext] pKgUA child] \ + [load [file join $testDir pkgua$ext] pkgua child] \ [child eval pkgua_eq abc def] \ [lsort [child eval info commands pkgua_*]] \ [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] @@ -157,7 +157,7 @@ test unload-3.3 {unloading of a package that has never been loaded from a safe i } -result {file "*" has never been loaded in this interpreter} test unload-3.4 {basic unloading of a non-unloadable package from a safe interpreter, with guess for package name} -setup { if {[lsearch -index 1 [info loaded child] Pkgb] < 0} { - load [file join $testDir pkgb$ext] pKgB child + load [file join $testDir pkgb$ext] pkgb child } } -constraints [list $dll $loaded] -returnCodes error -match glob -body { unload [file join $testDir pkgb$ext] {} child @@ -218,7 +218,7 @@ test unload-4.1 {loading of unloadable package in trusted interpreter, with gues [list $pkgua_loaded $pkgua_detached $pkgua_unloaded] } -result {{{} {} {}} {} 0 {pkgua_eq pkgua_quote} {. {} {}}} ## Load package in child-safe interpreter... -test unload-4.2 {basic loading of unloadable package in a safe interpreter, with package name conversion} -setup { +test unload-4.2 {basic loading of unloadable package in a safe interpreter} -setup { child eval { set pkgua_loaded "" set pkgua_detached "" @@ -227,17 +227,17 @@ test unload-4.2 {basic loading of unloadable package in a safe interpreter, with incr load(C) } -constraints [list $dll $loaded] -body { list [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \ - [load [file join $testDir pkgua$ext] pKgUA child] \ + [load [file join $testDir pkgua$ext] pkgua child] \ [child eval pkgua_eq abc def] \ [lsort [child eval info commands pkgua_*]] \ [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] } -result {{{} {} {}} {} 0 {pkgua_eq pkgua_quote} {. {} {}}} ## Load package in child-trusted interpreter... -test unload-4.3 {basic loading of unloadable package in a second trusted interpreter, with package name conversion} -setup { +test unload-4.3 {basic loading of unloadable package in a second trusted interpreter} -setup { incr load(T) } -constraints [list $dll $loaded] -body { list [child-trusted eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \ - [load [file join $testDir pkgua$ext] pkguA child-trusted] \ + [load [file join $testDir pkgua$ext] pkgua child-trusted] \ [child-trusted eval pkgua_eq abc def] \ [lsort [child-trusted eval info commands pkgua_*]] \ [child-trusted eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] -- cgit v0.12 From a7eae9c060e94023dd4d8b89ed1014e4c3a57943 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 1 Feb 2021 15:38:20 +0000 Subject: Add build tags for objective-c/cplusplus --- generic/tclBasic.c | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 92fe321..4e233fb 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -1197,6 +1197,9 @@ Tcl_CreateInterp(void) #ifdef TCL_COMPILE_STATS ".compilestats" #endif +#if defined(__cplusplus) && !defined(__OBJC__) + ".cplusplus" +#endif #ifndef NDEBUG ".debug" #endif @@ -1225,6 +1228,12 @@ Tcl_CreateInterp(void) #ifndef TCL_CFG_OPTIMIZED ".no-optimize" #endif +#ifdef __OBJC__ + ".objective-c" +#if defined(__cplusplus) + "plusplus" +#endif +#endif #ifdef TCL_CFG_PROFILED ".profiled" #endif -- cgit v0.12 From d044132580d82d2fe3b6c6fa7ddcfee6627d718f Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 25 Feb 2021 11:54:10 +0000 Subject: Fix build with -DTCL_NO_DEPRECATED cflag --- generic/tclBasic.c | 6 ------ generic/tclEvent.c | 7 +++++++ unix/Makefile.in | 6 +++--- win/Makefile.in | 2 +- win/makefile.vc | 4 ++-- 5 files changed, 13 insertions(+), 12 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 956d9ce..612a6d8 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -21,7 +21,6 @@ #include "tclOOInt.h" #include "tclCompile.h" #include "tclTomMath.h" -#include "tclUuid.h" #include #include @@ -1173,11 +1172,6 @@ Tcl_CreateInterp(void) Tcl_SetVar2(interp, "tcl_platform", "threaded", "1", TCL_GLOBAL_ONLY); #endif -#ifndef STRINGIFY -# define STRINGIFY(x) STRINGIFY1(x) -# define STRINGIFY1(x) #x -#endif - /* * Register Tcl's version number. * TIP #268: Full patchlevel instead of just major.minor diff --git a/generic/tclEvent.c b/generic/tclEvent.c index ce48210..604bb78 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -14,6 +14,7 @@ */ #include "tclInt.h" +#include "tclUuid.h" /* * The data structure below is used to report background errors. One such @@ -1071,6 +1072,12 @@ Tcl_InitSubsystems(void) TclpInitUnlock(); } TclInitNotifier(); + +#ifndef STRINGIFY +# define STRINGIFY(x) STRINGIFY1(x) +# define STRINGIFY1(x) #x +#endif + return TCL_PATCH_LEVEL "+" STRINGIFY(TCL_VERSION_UUID) #if defined(__clang__) && defined(__clang_major__) ".clang-" STRINGIFY(__clang_major__) diff --git a/unix/Makefile.in b/unix/Makefile.in index 19fdd20..25c69ea 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -1256,7 +1256,7 @@ tclAssembly.o: $(GENERIC_DIR)/tclAssembly.c $(COMPILEHDR) tclAsync.o: $(GENERIC_DIR)/tclAsync.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclAsync.c -tclBasic.o: $(GENERIC_DIR)/tclBasic.c $(COMPILEHDR) $(MATHHDRS) $(NREHDR) tclUuid.h +tclBasic.o: $(GENERIC_DIR)/tclBasic.c $(COMPILEHDR) $(MATHHDRS) $(NREHDR) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclBasic.c tclUuid.h: $(TOP_DIR)/manifest.uuid @@ -1317,7 +1317,7 @@ tclEnsemble.o: $(GENERIC_DIR)/tclEnsemble.c $(COMPILEHDR) tclEnv.o: $(GENERIC_DIR)/tclEnv.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclEnv.c -tclEvent.o: $(GENERIC_DIR)/tclEvent.c +tclEvent.o: $(GENERIC_DIR)/tclEvent.c tclUuid.h $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclEvent.c tclExecute.o: $(GENERIC_DIR)/tclExecute.c $(COMPILEHDR) $(MATHHDRS) $(NREHDR) @@ -1530,7 +1530,7 @@ tclZipfs.o: $(GENERIC_DIR)/tclZipfs.c -I$(ZLIB_DIR) -I$(ZLIB_DIR)/contrib/minizip \ $(GENERIC_DIR)/tclZipfs.c -tclTest.o: $(GENERIC_DIR)/tclTest.c $(IOHDR) $(TCLREHDRS) +tclTest.o: $(GENERIC_DIR)/tclTest.c $(IOHDR) $(TCLREHDRS) tclUuid.h $(CC) -c $(APP_CC_SWITCHES) $(GENERIC_DIR)/tclTest.c tclTestObj.o: $(GENERIC_DIR)/tclTestObj.c $(MATHHDRS) diff --git a/win/Makefile.in b/win/Makefile.in index d3d049b..c05ebe9 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -673,7 +673,7 @@ tclPkgConfig.${OBJEXT}: tclPkgConfig.c -DBUILD_tcl \ @DEPARG@ $(CC_OBJNAME) -tclBasic.${OBJEXT}: tclBasic.c tclUuid.h +tclEvent.${OBJEXT}: tclEvent.c tclUuid.h $(TOP_DIR)/manifest.uuid: printf "git-" >$(TOP_DIR)/manifest.uuid diff --git a/win/makefile.vc b/win/makefile.vc index 0914654..e38c6e8 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -805,9 +805,9 @@ $(ROOT)\manifest.uuid: $(TMP_DIR)\tclUuid.h: $(ROOT)\manifest.uuid copy $(WIN_DIR)\tclUuid.h.in+$(ROOT)\manifest.uuid $(TMP_DIR)\tclUuid.h -$(TMP_DIR)\tclBasic.obj: $(GENERICDIR)\tclBasic.c $(TMP_DIR)\tclUuid.h +$(TMP_DIR)\tclEvent.obj: $(GENERICDIR)\tclEvent.c $(TMP_DIR)\tclUuid.h $(cc32) $(pkgcflags) -I$(TMP_DIR) \ - -Fo$@ $(GENERICDIR)\tclBasic.c + -Fo$@ $(GENERICDIR)\tclEvent.c $(TMP_DIR)\tclTest.obj: $(GENERICDIR)\tclTest.c $(TMP_DIR)\tclUuid.h $(cc32) $(appcflags) -I$(TMP_DIR) -Fo$@ $? -- cgit v0.12 From be928297ad4c42c8888db9ed25a137d162fef621 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 29 Apr 2021 11:13:42 +0000 Subject: Remove "testpurify" and "testdebug" test commands --- generic/tclPanic.c | 1 + generic/tclTest.c | 74 ------------------------------------------------------ tests/tcltests.tcl | 23 +++++++---------- tests/winDde.test | 2 +- 4 files changed, 11 insertions(+), 89 deletions(-) diff --git a/generic/tclPanic.c b/generic/tclPanic.c index 1fd922b..ba7e801 100644 --- a/generic/tclPanic.c +++ b/generic/tclPanic.c @@ -45,6 +45,7 @@ static TCL_NORETURN1 Tcl_PanicProc *panicProc = NULL; *---------------------------------------------------------------------- */ +#undef Tcl_SetPanicProc const char * Tcl_SetPanicProc( TCL_NORETURN1 Tcl_PanicProc *proc) diff --git a/generic/tclTest.c b/generic/tclTest.c index 54c0bbc..d32057b 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -228,7 +228,6 @@ static Tcl_CmdProc TestcreatecommandCmd; static Tcl_CmdProc TestdcallCmd; static Tcl_CmdProc TestdelCmd; static Tcl_CmdProc TestdelassocdataCmd; -static Tcl_ObjCmdProc TestdebugObjCmd; static Tcl_ObjCmdProc TestdoubledigitsObjCmd; static Tcl_CmdProc TestdstringCmd; static Tcl_ObjCmdProc TestencodingObjCmd; @@ -267,7 +266,6 @@ static Tcl_ObjCmdProc TestparsevarObjCmd; static Tcl_ObjCmdProc TestparsevarnameObjCmd; static Tcl_ObjCmdProc TestpreferstableObjCmd; static Tcl_ObjCmdProc TestprintObjCmd; -static Tcl_ObjCmdProc TestpurifyObjCmd; static Tcl_ObjCmdProc TestregexpObjCmd; static Tcl_ObjCmdProc TestreturnObjCmd; static void TestregexpXflags(const char *string, @@ -566,8 +564,6 @@ Tcltest_Init( Tcl_CreateCommand(interp, "testcreatecommand", TestcreatecommandCmd, NULL, NULL); Tcl_CreateCommand(interp, "testdcall", TestdcallCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testdebug", TestdebugObjCmd, - NULL, NULL); Tcl_CreateCommand(interp, "testdel", TestdelCmd, NULL, NULL); Tcl_CreateCommand(interp, "testdelassocdata", TestdelassocdataCmd, NULL, NULL); @@ -632,8 +628,6 @@ Tcltest_Init( NULL, NULL); Tcl_CreateObjCommand(interp, "testpreferstable", TestpreferstableObjCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testpurify", TestpurifyObjCmd, - NULL, NULL); Tcl_CreateObjCommand(interp, "testprint", TestprintObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testregexp", TestregexpObjCmd, @@ -3430,40 +3424,6 @@ TestlocaleCmd( /* *---------------------------------------------------------------------- * - * TestdebugObjCmd -- - * - * Implements the "testdebug" command, to detect whether Tcl was built with - * --enabble-symbols. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -TestdebugObjCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, /* Current interpreter. */ - TCL_UNUSED(int) /*objc*/, - TCL_UNUSED(Tcl_Obj *const *) /*objv*/) -{ - -#if defined(NDEBUG) && NDEBUG == 1 - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0)); -#else - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(1)); -#endif - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * * CleanupTestSetassocdataTests -- * * This function is called when an interpreter is deleted to clean @@ -3865,40 +3825,6 @@ TestprintObjCmd( /* *---------------------------------------------------------------------- * - * TestpurifyObjCmd -- - * - * Implements the "testpurify" command, to detect whether Tcl was built with - * -DPURIFY. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -TestpurifyObjCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, /* Current interpreter. */ - TCL_UNUSED(int) /*objc*/, - TCL_UNUSED(Tcl_Obj *const *) /*objv*/) -{ - -#ifdef PURIFY - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(1)); -#else - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0)); -#endif - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * * TestregexpObjCmd -- * * This procedure implements the "testregexp" command. It is used to give diff --git a/tests/tcltests.tcl b/tests/tcltests.tcl index 1ee37d3..b9d7cfd 100644 --- a/tests/tcltests.tcl +++ b/tests/tcltests.tcl @@ -3,22 +3,17 @@ package require tcltest 2.5 namespace import ::tcltest::* testConstraint exec [llength [info commands exec]] -if {[namespace which testdebug] ne {}} { - testConstraint debug [testdebug] - testConstraint purify [testpurify] - testConstraint debugpurify [ - expr { - ![testConstraint memory] - && - [testConstraint debug] - && - [testConstraint purify] - }] -} +testConstraint debug [expr {"debug" in [split [package provide tcl] .]}] +testConstraint purify [expr {"purify" in [split [package provide tcl] .]}] +testConstraint debugpurify [ + expr { + "memdebug" ni [split [package provide tcl] .] + && [testConstraint debug] + && [testConstraint purify] + }] testConstraint fcopy [llength [info commands fcopy]] testConstraint fileevent [llength [info commands fileevent]] -testConstraint thread [ - expr {0 == [catch {package require Thread 2.7-}]}] +testConstraint thread [expr {![catch {package require Thread 2.7-}]}] testConstraint notValgrind [expr {![testConstraint valgrind]}] diff --git a/tests/winDde.test b/tests/winDde.test index 72f3d92..dbadeb4 100644 --- a/tests/winDde.test +++ b/tests/winDde.test @@ -13,8 +13,8 @@ if {"::tcltest" ni [namespace children]} { package require tcltest 2.5 namespace import -force ::tcltest::* } +package require tcltests -testConstraint debug [expr {"debug" in [split [package provide tcl] .]}] testConstraint dde 0 if {[testConstraint win]} { if {![catch { -- cgit v0.12 From 15ba6741cfdbedfb264478ebef44ba013cf9fd97 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 29 Apr 2021 11:28:50 +0000 Subject: doc update --- doc/FindExec.3 | 3 +++ doc/InitSubSyst.3 | 5 ++++- doc/Panic.3 | 3 +++ doc/zipfs.3 | 3 ++- 4 files changed, 12 insertions(+), 2 deletions(-) diff --git a/doc/FindExec.3 b/doc/FindExec.3 index 60b2cec..7f8c8a4 100644 --- a/doc/FindExec.3 +++ b/doc/FindExec.3 @@ -35,6 +35,9 @@ Tcl. For example, it is needed on some platforms in the implementation of the \fBload\fR command. It is also returned by the \fBinfo nameofexecutable\fR command. .PP +The result of \fBTcl_FindExecutable\fR is the full Tcl version (e.g., +\fB8.7.0+abcdef...abcdef.gcc-1002.utf16\fR). +.PP On UNIX platforms this procedure is typically invoked as the very first thing in the application's main program; it must be passed \fIargv[0]\fR as its argument. It is important not to change the diff --git a/doc/InitSubSyst.3 b/doc/InitSubSyst.3 index 28e5f40..89f2b88 100644 --- a/doc/InitSubSyst.3 +++ b/doc/InitSubSyst.3 @@ -21,10 +21,13 @@ The \fBTcl_InitSubsystems\fR procedure initializes the Tcl library. This procedure is typically invoked as the very first thing in the application's main program. .PP +The result of \fBTcl_InitSubsystems\fR is the full Tcl version (e.g., +\fB8.7.0+abcdef...abcdef.gcc-1002.utf16\fR). +.PP \fBTcl_InitSubsystems\fR is very similar in use to \fBTcl_FindExecutable\fR. It can be used when Tcl is used as utility library, no other encodings than utf8, -iso8859-1 or unicode are used, and no interest exists in the +iso8859-1 or utf-16 are used, and no interest exists in the value of \fBinfo nameofexecutable\fR. The system encoding will not be extracted from the environment, but falls back to iso8859-1. .SH KEYWORDS diff --git a/doc/Panic.3 b/doc/Panic.3 index 881ed2e..bd019db 100644 --- a/doc/Panic.3 +++ b/doc/Panic.3 @@ -82,6 +82,9 @@ making calls into the Tcl library, or into other libraries that may call the Tcl library, since the original call to \fBTcl_Panic\fR indicates the Tcl library is not in a state of reliable operation. .PP +The result of \fBTcl_SetPanicProc\fR is the full Tcl version (e.g., +\fB8.7.0+abcdef...abcdef.gcc-1002.utf16\fR). +.PP The typical use of \fBTcl_SetPanicProc\fR arranges for the error message to be displayed or reported in a manner more suitable for the application or the platform. diff --git a/doc/zipfs.3 b/doc/zipfs.3 index cce6fb6..3b13cd9 100644 --- a/doc/zipfs.3 +++ b/doc/zipfs.3 @@ -87,7 +87,8 @@ it uses WCHAR instead of char. As a result, it requires your application to be compiled with the UNICODE preprocessor symbol defined (e.g., via the \fB-DUNICODE\fR compiler flag). .PP -The result of \fBTclZipfs_AppHook\fR is the Tcl version (e.g., \fB8.7.0\fR). +The result of \fBTclZipfs_AppHook\fR is the full Tcl version (e.g., +\fB8.7.0+abcdef...abcdef.gcc-1002.utf16\fR). The function \fImay\fR modify the variables pointed to by \fIargcPtr\fR and \fIargvPtr\fR to remove arguments; the current implementation does not do so, but callers \fIshould not\fR assume that this will be true in the future. -- cgit v0.12 From eb4a617c51ad59164b9c11fed904f74fde365702 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 29 Jun 2021 15:59:19 +0000 Subject: TCL_THREADS=0 means no threads too .... --- generic/tclEvent.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclEvent.c b/generic/tclEvent.c index 6096323..90fde75 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -1120,7 +1120,7 @@ Tcl_InitSubsystems(void) #ifdef TCL_NO_DEPRECATED ".no-deprecate" #endif -#ifndef TCL_THREADS +#if !TCL_THREADS ".no-thread" #endif #ifndef TCL_CFG_OPTIMIZED -- cgit v0.12 From 007417b8bea6960ebfd2cde0a69dbc82acc945a7 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 1 Jul 2021 10:35:46 +0000 Subject: "utf16" -> "utf-16" --- generic/tclEvent.c | 2 +- generic/tclTest.c | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclEvent.c b/generic/tclEvent.c index 90fde75..90396be 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -1139,7 +1139,7 @@ Tcl_InitSubsystems(void) ".static" #endif #if TCL_UTF_MAX < 4 - ".utf16" + ".utf-16" #endif ; } diff --git a/generic/tclTest.c b/generic/tclTest.c index 46e9d95..ab20f45 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -520,7 +520,7 @@ Tcltest_Init( ".static" #endif #if TCL_UTF_MAX < 4 - ".utf16" + ".utf-16" #endif , NULL) == TCL_ERROR) { return TCL_ERROR; -- cgit v0.12 From a545cd5b473a8b782ce7713699e12ed63ca7e5f1 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 2 Jul 2021 09:57:51 +0000 Subject: "profiled" -> "profile" --- generic/tclEvent.c | 107 ++++++++++++++++++++++++++++------------------------- 1 file changed, 57 insertions(+), 50 deletions(-) diff --git a/generic/tclEvent.c b/generic/tclEvent.c index 90396be..ca6855b 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -1025,60 +1025,18 @@ Tcl_Exit( *------------------------------------------------------------------------- */ -const char * -Tcl_InitSubsystems(void) -{ - if (inExit != 0) { - Tcl_Panic("Tcl_InitSubsystems called while exiting"); - } - - if (subsystemsInitialized == 0) { - /* - * Double check inside the mutex. There are definitly calls back into - * this routine from some of the functions below. - */ - - TclpInitLock(); - if (subsystemsInitialized == 0) { - - /* - * Initialize locks used by the memory allocators before anything - * interesting happens so we can use the allocators in the - * implementation of self-initializing locks. - */ - - TclInitThreadStorage(); /* Creates hash table for - * thread local storage */ -#if defined(USE_TCLALLOC) && USE_TCLALLOC - TclInitAlloc(); /* Process wide mutex init */ -#endif -#if TCL_THREADS && defined(USE_THREAD_ALLOC) - TclInitThreadAlloc(); /* Setup thread allocator caches */ -#endif -#ifdef TCL_MEM_DEBUG - TclInitDbCkalloc(); /* Process wide mutex init */ -#endif - - TclpInitPlatform(); /* Creates signal handler(s) */ - TclInitDoubleConversion(); /* Initializes constants for - * converting to/from double. */ - TclInitObjSubsystem(); /* Register obj types, create - * mutexes. */ - TclInitIOSubsystem(); /* Inits a tsd key (noop). */ - TclInitEncodingSubsystem(); /* Process wide encoding init. */ - TclInitNamespaceSubsystem();/* Register ns obj type (mutexed). */ - subsystemsInitialized = 1; - } - TclpInitUnlock(); - } - TclInitNotifier(); +MODULE_SCOPE const TclStubs tclStubs; #ifndef STRINGIFY # define STRINGIFY(x) STRINGIFY1(x) # define STRINGIFY1(x) #x #endif - return TCL_PATCH_LEVEL "+" STRINGIFY(TCL_VERSION_UUID) +static const struct { + const TclStubs *stubs; + const char version[]; +} stubInfo = { + &tclStubs, TCL_PATCH_LEVEL "+" STRINGIFY(TCL_VERSION_UUID) #if defined(__clang__) && defined(__clang_major__) ".clang-" STRINGIFY(__clang_major__) #if __clang_minor__ < 10 @@ -1133,7 +1091,7 @@ Tcl_InitSubsystems(void) #endif #endif #ifdef TCL_CFG_PROFILED - ".profiled" + ".profile" #endif #ifdef STATIC_BUILD ".static" @@ -1141,7 +1099,56 @@ Tcl_InitSubsystems(void) #if TCL_UTF_MAX < 4 ".utf-16" #endif - ; +}; + +const char * +Tcl_InitSubsystems(void) +{ + if (inExit != 0) { + Tcl_Panic("Tcl_InitSubsystems called while exiting"); + } + + if (subsystemsInitialized == 0) { + /* + * Double check inside the mutex. There are definitly calls back into + * this routine from some of the functions below. + */ + + TclpInitLock(); + if (subsystemsInitialized == 0) { + + /* + * Initialize locks used by the memory allocators before anything + * interesting happens so we can use the allocators in the + * implementation of self-initializing locks. + */ + + TclInitThreadStorage(); /* Creates hash table for + * thread local storage */ +#if defined(USE_TCLALLOC) && USE_TCLALLOC + TclInitAlloc(); /* Process wide mutex init */ +#endif +#if TCL_THREADS && defined(USE_THREAD_ALLOC) + TclInitThreadAlloc(); /* Setup thread allocator caches */ +#endif +#ifdef TCL_MEM_DEBUG + TclInitDbCkalloc(); /* Process wide mutex init */ +#endif + + TclpInitPlatform(); /* Creates signal handler(s) */ + TclInitDoubleConversion(); /* Initializes constants for + * converting to/from double. */ + TclInitObjSubsystem(); /* Register obj types, create + * mutexes. */ + TclInitIOSubsystem(); /* Inits a tsd key (noop). */ + TclInitEncodingSubsystem(); /* Process wide encoding init. */ + TclInitNamespaceSubsystem();/* Register ns obj type (mutexed). */ + subsystemsInitialized = 1; + } + TclpInitUnlock(); + } + TclInitNotifier(); + return stubInfo.version; } /* -- cgit v0.12 From 957da2bc571b08bd4d0ae7ab7c25adb20bac3b93 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 9 Jul 2021 22:11:03 +0000 Subject: Eliminate clang warning --- generic/tclEvent.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclEvent.c b/generic/tclEvent.c index ca6855b..341025c 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -1036,7 +1036,7 @@ static const struct { const TclStubs *stubs; const char version[]; } stubInfo = { - &tclStubs, TCL_PATCH_LEVEL "+" STRINGIFY(TCL_VERSION_UUID) + &tclStubs, {TCL_PATCH_LEVEL "+" STRINGIFY(TCL_VERSION_UUID) #if defined(__clang__) && defined(__clang_major__) ".clang-" STRINGIFY(__clang_major__) #if __clang_minor__ < 10 @@ -1099,7 +1099,7 @@ static const struct { #if TCL_UTF_MAX < 4 ".utf-16" #endif -}; +}}; const char * Tcl_InitSubsystems(void) -- cgit v0.12 From 582fceb34dd343fac786c86910817239227b81e7 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 13 Jul 2021 13:12:40 +0000 Subject: Remove tclPkg.c changes, instead implement new tcl::build-info command --- generic/tclBasic.c | 48 +++++++++++++++++++++++++++++++++++++++- generic/tclEvent.c | 3 +++ generic/tclPkg.c | 6 ++--- generic/tclTest.c | 64 ++---------------------------------------------------- tests/compile.test | 2 +- tests/tcltests.tcl | 6 ++--- 6 files changed, 59 insertions(+), 70 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 0a4d145..a7f89a4 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -607,6 +607,49 @@ TclFinalizeEvaluation(void) /* *---------------------------------------------------------------------- * + * buildInfoObjCmd -- + * + * Implements tcl::build-info command. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +buildInfoObjCmd( + void *clientData, + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + if (objc > 2) { + Tcl_WrongNumArgs(interp, 1, objv, "?option?"); + return TCL_ERROR; + } + if (objc == 2) { + const char *arg = Tcl_GetString(objv[1]); + const char *p = strstr((char *)clientData, arg); + size_t len = strlen(arg); + if ((p > (char *)clientData) && p[-1] == '.' + && ((p[len] == '.') || (p[len] == '\0'))) { + Tcl_AppendResult(interp, "1", NULL); + } else { + Tcl_AppendResult(interp, "0", NULL); + } + return TCL_OK; + } + Tcl_AppendResult(interp, (char *)clientData, NULL); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_CreateInterp -- * * Create a new TCL command interpreter. @@ -1179,7 +1222,10 @@ Tcl_CreateInterp(void) */ Tcl_PkgProvideEx(interp, "Tcl", TCL_PATCH_LEVEL, &tclStubs); - Tcl_PkgProvideEx(interp, "tcl", version, &tclStubs); + Tcl_PkgProvideEx(interp, "tcl", TCL_PATCH_LEVEL, &tclStubs); + Tcl_CreateObjCommand(interp, "::tcl::build-info", + buildInfoObjCmd, (void *)version, NULL); + if (TclTommath_Init(interp) != TCL_OK) { Tcl_Panic("%s", TclGetString(Tcl_GetObjResult(interp))); diff --git a/generic/tclEvent.c b/generic/tclEvent.c index 341025c..ceaa9bd 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -1093,6 +1093,9 @@ static const struct { #ifdef TCL_CFG_PROFILED ".profile" #endif +#ifdef PURIFY + ".purify" +#endif #ifdef STATIC_BUILD ".static" #endif diff --git a/generic/tclPkg.c b/generic/tclPkg.c index 3311f6a..c3f2f17 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -1696,7 +1696,7 @@ CheckVersionAndConvert( *ip++ = *p; - for (prevChar = *p, p++; (*p != 0) && (*p != '+'); p++) { + for (prevChar = *p, p++; *p != 0; p++) { if (!isdigit(UCHAR(*p)) && /* INTL: digit */ ((*p!='.' && *p!='a' && *p!='b') || ((hasunstable && (*p=='a' || *p=='b')) || @@ -2000,10 +2000,10 @@ CheckRequirement( char *dash = NULL, *buf; - dash = strchr(string, '+') ? NULL : (char *)strchr(string, '-'); + dash = (char *)strchr(string, '-'); if (dash == NULL) { /* - * '+' found or no dash found: has to be a simple version. + * No dash found, has to be a simple version. */ return CheckVersionAndConvert(interp, string, NULL, NULL); diff --git a/generic/tclTest.c b/generic/tclTest.c index ab20f45..39bd392 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -29,7 +29,6 @@ # include "tclTomMath.h" #endif #include "tclOO.h" -#include "tclUuid.h" #include /* @@ -440,11 +439,6 @@ static const Tcl_Filesystem simpleFilesystem = { *---------------------------------------------------------------------- */ -#ifndef STRINGIFY -# define STRINGIFY(x) STRINGIFY1(x) -# define STRINGIFY1(x) #x -#endif - int Tcltest_Init( Tcl_Interp *interp) /* Interpreter for application. */ @@ -468,65 +462,11 @@ Tcltest_Init( return TCL_ERROR; } /* TIP #268: Full patchlevel instead of just major.minor */ - /* TIP #???: Append build information "+......" */ - - if (Tcl_PkgProvideEx(interp, "tcl::test", TCL_PATCH_LEVEL - "+" STRINGIFY(TCL_VERSION_UUID) -#if defined(__clang__) && defined(__clang_major__) - ".clang-" STRINGIFY(__clang_major__) -#if __clang_minor__ < 10 - "0" -#endif - STRINGIFY(__clang_minor__) -#endif -#ifdef TCL_COMPILE_DEBUG - ".compiledebug" -#endif -#ifdef TCL_COMPILE_STATS - ".compilestats" -#endif -#ifndef NDEBUG - ".debug" -#endif -#if !defined(__clang__) && defined(__GNUC__) - ".gcc-" STRINGIFY(__GNUC__) -#if __GNUC_MINOR__ < 10 - "0" -#endif - STRINGIFY(__GNUC_MINOR__) -#endif -#ifdef TCL_MEM_DEBUG - ".memdebug" -#endif -#if defined(_MSC_VER) - ".msvc-" STRINGIFY(_MSC_VER) -#endif -#ifdef USE_NMAKE - ".nmake" -#endif -#ifdef TCL_NO_DEPRECATED - ".no-deprecate" -#endif -#if !TCL_THREADS - ".no-thread" -#endif -#ifndef TCL_CFG_OPTIMIZED - ".no-optimize" -#endif -#ifdef TCL_CFG_PROFILED - ".profiled" -#endif -#ifdef STATIC_BUILD - ".static" -#endif -#if TCL_UTF_MAX < 4 - ".utf-16" -#endif - , NULL) == TCL_ERROR) { + + if (Tcl_PkgProvideEx(interp, "tcl::test", TCL_PATCH_LEVEL, NULL) == TCL_ERROR) { return TCL_ERROR; } - /* * Create additional commands and math functions for testing Tcl. */ diff --git a/tests/compile.test b/tests/compile.test index be68b5b..9959da4 100644 --- a/tests/compile.test +++ b/tests/compile.test @@ -500,7 +500,7 @@ test compile-13.2 {TclCompileScript: testing expected nested scripts compilation # with 1500 (1000 in debug) nested scripts (bodies). If you get SO/SF exceptions on some low-stack # boxes or systems, please don't decrease it (either provide a constraint) ti eval {foreach cmd {eval "if 1" try catch} { - set c [gencode [expr {"debug" ni [split [package provide tcl] .] ? 1500 : 1000}] $cmd] + set c [gencode [expr {[tcl::build-info debug] ? 1500 : 1000}] $cmd] if 1 $c }} ti eval {set result} diff --git a/tests/tcltests.tcl b/tests/tcltests.tcl index b9d7cfd..a5d7044 100644 --- a/tests/tcltests.tcl +++ b/tests/tcltests.tcl @@ -3,11 +3,11 @@ package require tcltest 2.5 namespace import ::tcltest::* testConstraint exec [llength [info commands exec]] -testConstraint debug [expr {"debug" in [split [package provide tcl] .]}] -testConstraint purify [expr {"purify" in [split [package provide tcl] .]}] +testConstraint debug [tcl::build-info debug] +testConstraint purify [tcl::build-info purify] testConstraint debugpurify [ expr { - "memdebug" ni [split [package provide tcl] .] + ![tcl::build-info memdebug] && [testConstraint debug] && [testConstraint purify] }] -- cgit v0.12 From ce04bad35e4aa0a36a2d3d9ce604852a391184b6 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 13 Jul 2021 15:56:33 +0000 Subject: More advanced tcl::build-info string parsing --- generic/tclBasic.c | 72 ++++++++++++++++++++++++++++++++++++++++++++++++------ 1 file changed, 65 insertions(+), 7 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index a7f89a4..60160f7 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -632,15 +632,73 @@ buildInfoObjCmd( return TCL_ERROR; } if (objc == 2) { - const char *arg = Tcl_GetString(objv[1]); - const char *p = strstr((char *)clientData, arg); - size_t len = strlen(arg); - if ((p > (char *)clientData) && p[-1] == '.' - && ((p[len] == '.') || (p[len] == '\0'))) { - Tcl_AppendResult(interp, "1", NULL); - } else { + int len; + const char *arg = TclGetStringFromObj(objv[1], &len); + if (len == 7 && !strcmp(arg, "version")) { + char buf[80]; + const char *p = strchr((char *)clientData, '.'); + if (p) { + const char *q = strchr(p+1, '.'); + const char *r = strchr(p+1, '+'); + p = (q < r) ? q : r; + } + if (p) { + memcpy(buf, (char *)clientData, p - (char *)clientData); + buf[p - (char *)clientData] = '\0'; + Tcl_AppendResult(interp, buf, NULL); + } + return TCL_OK; + } else if (len == 11 && !strcmp(arg, "fullversion")) { + char buf[80]; + const char *p = strchr((char *)clientData, '+'); + if (p) { + memcpy(buf, (char *)clientData, p - (char *)clientData); + buf[p - (char *)clientData] = '\0'; + Tcl_AppendResult(interp, buf, NULL); + } + return TCL_OK; + } else if (len == 6 && !strcmp(arg, "commit")) { + const char *q, *p = strchr((char *)clientData, '+'); + if (p) { + if ((q = strchr(p, '.'))) { + char buf[80]; + memcpy(buf, p+1, q - p - 1); + buf[q - p - 1] = '\0'; + Tcl_AppendResult(interp, buf, NULL); + } else { + Tcl_AppendResult(interp, p+1, NULL); + } + } + return TCL_OK; + } else if (len == 8 && !strcmp(arg, "compiler")) { + const char *p = strchr((char *)clientData, '.'); + while (p) { + if (!strncmp(p+1, "clang-", 6) || !strncmp(p+1, "gcc-", 4) || !strncmp(p+1, "msvc-", 5)) { + const char *q = strchr(p+1, '.'); + if (q) { + char buf[16]; + memcpy(buf, p+1, q - p - 1); + buf[q - p - 1] = '\0'; + Tcl_AppendResult(interp, buf, NULL); + } else { + Tcl_AppendResult(interp, p+1, NULL); + } + return TCL_OK; + } + p = strchr(p+1, '.'); + } Tcl_AppendResult(interp, "0", NULL); + return TCL_OK; + } + const char *p = strchr((char *)clientData, '.'); + while (p) { + if (!strncmp(p+1, arg, len) && ((p[len+1] == '.') || (p[len+1] == '\0'))) { + Tcl_AppendResult(interp, "1", NULL); + return TCL_OK; + } + p = strchr(p+1, '.'); } + Tcl_AppendResult(interp, "0", NULL); return TCL_OK; } Tcl_AppendResult(interp, (char *)clientData, NULL); -- cgit v0.12 From bffdbce72e5072f634d40af47630eb7cacc1c33f Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 13 Jul 2021 16:14:35 +0000 Subject: fullversion -> patchlevel --- generic/tclBasic.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 60160f7..72eb960 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -648,7 +648,7 @@ buildInfoObjCmd( Tcl_AppendResult(interp, buf, NULL); } return TCL_OK; - } else if (len == 11 && !strcmp(arg, "fullversion")) { + } else if (len == 10 && !strcmp(arg, "patchlevel")) { char buf[80]; const char *p = strchr((char *)clientData, '+'); if (p) { -- cgit v0.12 From c39b5671ce09873e8b66edc4d83c2295c39e2ccf Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 14 Jul 2021 08:58:13 +0000 Subject: Add support for ICC --- generic/tclBasic.c | 5 +++-- generic/tclEvent.c | 5 ++++- 2 files changed, 7 insertions(+), 3 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 72eb960..438891a 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -673,7 +673,8 @@ buildInfoObjCmd( } else if (len == 8 && !strcmp(arg, "compiler")) { const char *p = strchr((char *)clientData, '.'); while (p) { - if (!strncmp(p+1, "clang-", 6) || !strncmp(p+1, "gcc-", 4) || !strncmp(p+1, "msvc-", 5)) { + if (!strncmp(p+1, "clang-", 6) || !strncmp(p+1, "gcc-", 4) + || !strncmp(p+1, "icc-", 4) || !strncmp(p+1, "msvc-", 5)) { const char *q = strchr(p+1, '.'); if (q) { char buf[16]; @@ -1276,7 +1277,7 @@ Tcl_CreateInterp(void) /* * Register Tcl's version number. * TIP #268: Full patchlevel instead of just major.minor - * TIP #???: Append build information "+......" + * TIP #599: Extended build information "+......" */ Tcl_PkgProvideEx(interp, "Tcl", TCL_PATCH_LEVEL, &tclStubs); diff --git a/generic/tclEvent.c b/generic/tclEvent.c index ceaa9bd..687dbcd 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -1056,13 +1056,16 @@ static const struct { #ifndef NDEBUG ".debug" #endif -#if !defined(__clang__) && defined(__GNUC__) +#if !defined(__clang__) && !defined(__INTEL_COMPILER) && defined(__GNUC__) ".gcc-" STRINGIFY(__GNUC__) #if __GNUC_MINOR__ < 10 "0" #endif STRINGIFY(__GNUC_MINOR__) #endif +#ifdef __INTEL_COMPILER + ".icc-" STRINGIFY(__INTEL_COMPILER) +#endif #if (defined(_WIN32) && !defined(_WIN64)) || (ULONG_MAX == 0xffffffffUL) ".ilp32" #endif -- cgit v0.12 From 35f79cbdbf21cc8c23c80bfb89a8c762eecb191f Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 30 Jul 2021 12:35:23 +0000 Subject: In "makefile.vc" add building new header-file tclUuid.h. Not used for anything yet. --- win/makefile.vc | 15 +++++++++++++-- win/tclUuid.h.in | 1 + 2 files changed, 14 insertions(+), 2 deletions(-) create mode 100755 win/tclUuid.h.in diff --git a/win/makefile.vc b/win/makefile.vc index b5bb1a0..f56feec 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -798,8 +798,19 @@ $(TMP_DIR)\tclMainW.obj: $(GENERICDIR)\tclMain.c $(cc32) $(pkgcflags) /DUNICODE /D_UNICODE \ -Fo$@ $? -$(TMP_DIR)\tclTest.obj: $(GENERICDIR)\tclTest.c - $(cc32) $(appcflags) -Fo$@ $? +$(ROOT)\manifest.uuid: + copy $(WIN_DIR)\gitmanifest.in $(ROOT)\manifest.uuid + git rev-parse HEAD >>$(ROOT)\manifest.uuid + +$(TMP_DIR)\tclUuid.h: $(ROOT)\manifest.uuid + copy $(WIN_DIR)\tclUuid.h.in+$(ROOT)\manifest.uuid $(TMP_DIR)\tclUuid.h + +$(TMP_DIR)\tclEvent.obj: $(GENERICDIR)\tclEvent.c $(TMP_DIR)\tclUuid.h + $(cc32) $(pkgcflags) -I$(TMP_DIR) \ + -Fo$@ $(GENERICDIR)\tclEvent.c + +$(TMP_DIR)\tclTest.obj: $(GENERICDIR)\tclTest.c $(TMP_DIR)\tclUuid.h + $(cc32) $(appcflags) -I$(TMP_DIR) -Fo$@ $? $(TMP_DIR)\tclTestObj.obj: $(GENERICDIR)\tclTestObj.c $(cc32) $(appcflags) -Fo$@ $? diff --git a/win/tclUuid.h.in b/win/tclUuid.h.in new file mode 100755 index 0000000..cbb83e4 --- /dev/null +++ b/win/tclUuid.h.in @@ -0,0 +1 @@ +#define TCL_VERSION_UUID \ -- cgit v0.12 From 92e1716af37f6c82bf39df1b5cea4195920ae02e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 30 Jul 2021 12:50:54 +0000 Subject: make it work for GIT too --- win/gitmanifest.in | 1 + 1 file changed, 1 insertion(+) create mode 100644 win/gitmanifest.in diff --git a/win/gitmanifest.in b/win/gitmanifest.in new file mode 100644 index 0000000..3e7de84 --- /dev/null +++ b/win/gitmanifest.in @@ -0,0 +1 @@ +git- \ No newline at end of file -- cgit v0.12 From 82ad00811c42b5b6dc996637aa2e46f890d63a16 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 2 Aug 2021 14:52:39 +0000 Subject: Bring over more from "build-info" branch --- doc/FindExec.3 | 5 ++++- doc/InitSubSyst.3 | 7 +++++-- doc/Panic.3 | 5 ++++- doc/zipfs.3 | 12 ++++++------ generic/tcl.decls | 12 ++++++------ generic/tcl.h | 6 +++--- generic/tclDecls.h | 8 ++++---- generic/tclEncoding.c | 5 +++-- generic/tclEvent.c | 3 ++- generic/tclPanic.c | 5 +++-- generic/tclZipfs.c | 11 ++++++----- unix/Makefile.in | 12 ++++++++---- win/Makefile.in | 10 ++++++++++ 13 files changed, 64 insertions(+), 37 deletions(-) diff --git a/doc/FindExec.3 b/doc/FindExec.3 index 149ef8a..7f8c8a4 100644 --- a/doc/FindExec.3 +++ b/doc/FindExec.3 @@ -13,7 +13,7 @@ Tcl_FindExecutable, Tcl_GetNameOfExecutable \- identify or return the name of th .nf \fB#include \fR .sp -void +const char * \fBTcl_FindExecutable\fR(\fIargv0\fR) .sp const char * @@ -35,6 +35,9 @@ Tcl. For example, it is needed on some platforms in the implementation of the \fBload\fR command. It is also returned by the \fBinfo nameofexecutable\fR command. .PP +The result of \fBTcl_FindExecutable\fR is the full Tcl version (e.g., +\fB8.7.0+abcdef...abcdef.gcc-1002.utf16\fR). +.PP On UNIX platforms this procedure is typically invoked as the very first thing in the application's main program; it must be passed \fIargv[0]\fR as its argument. It is important not to change the diff --git a/doc/InitSubSyst.3 b/doc/InitSubSyst.3 index 3c138a4..89f2b88 100644 --- a/doc/InitSubSyst.3 +++ b/doc/InitSubSyst.3 @@ -13,7 +13,7 @@ Tcl_InitSubsystems \- initialize the Tcl library. .nf \fB#include \fR .sp -void +const char * \fBTcl_InitSubsystems\fR(\fIvoid\fR) .SH DESCRIPTION .PP @@ -21,10 +21,13 @@ The \fBTcl_InitSubsystems\fR procedure initializes the Tcl library. This procedure is typically invoked as the very first thing in the application's main program. .PP +The result of \fBTcl_InitSubsystems\fR is the full Tcl version (e.g., +\fB8.7.0+abcdef...abcdef.gcc-1002.utf16\fR). +.PP \fBTcl_InitSubsystems\fR is very similar in use to \fBTcl_FindExecutable\fR. It can be used when Tcl is used as utility library, no other encodings than utf8, -iso8859-1 or unicode are used, and no interest exists in the +iso8859-1 or utf-16 are used, and no interest exists in the value of \fBinfo nameofexecutable\fR. The system encoding will not be extracted from the environment, but falls back to iso8859-1. .SH KEYWORDS diff --git a/doc/Panic.3 b/doc/Panic.3 index 53b84da..bd019db 100644 --- a/doc/Panic.3 +++ b/doc/Panic.3 @@ -18,7 +18,7 @@ void void \fBTcl_PanicVA\fR(\fIformat\fR, \fIargList\fR) .sp -void +const char * \fBTcl_SetPanicProc\fR(\fIpanicProc\fR) .sp void @@ -82,6 +82,9 @@ making calls into the Tcl library, or into other libraries that may call the Tcl library, since the original call to \fBTcl_Panic\fR indicates the Tcl library is not in a state of reliable operation. .PP +The result of \fBTcl_SetPanicProc\fR is the full Tcl version (e.g., +\fB8.7.0+abcdef...abcdef.gcc-1002.utf16\fR). +.PP The typical use of \fBTcl_SetPanicProc\fR arranges for the error message to be displayed or reported in a manner more suitable for the application or the platform. diff --git a/doc/zipfs.3 b/doc/zipfs.3 index 348557f..3b13cd9 100644 --- a/doc/zipfs.3 +++ b/doc/zipfs.3 @@ -13,7 +13,7 @@ TclZipfs_AppHook, Tclzipfs_Mount, TclZipfs_MountBuffer, Tclzipfs_Unmount \- handle ZIP files as Tcl virtual filesystems .SH SYNOPSIS .nf -int +const char * \fBTclZipfs_AppHook(\fIargcPtr, argvPtr\fR) .sp int @@ -87,11 +87,11 @@ it uses WCHAR instead of char. As a result, it requires your application to be compiled with the UNICODE preprocessor symbol defined (e.g., via the \fB-DUNICODE\fR compiler flag). .PP -The result of \fBTclZipfs_AppHook\fR is a Tcl result code (e.g., \fBTCL_OK\fR -when the function is successful). The function \fImay\fR modify the variables -pointed to by \fIargcPtr\fR and \fIargvPtr\fR to remove arguments; the -current implementation does not do so, but callers \fIshould not\fR assume -that this will be true in the future. +The result of \fBTclZipfs_AppHook\fR is the full Tcl version (e.g., +\fB8.7.0+abcdef...abcdef.gcc-1002.utf16\fR). +The function \fImay\fR modify the variables pointed to by \fIargcPtr\fR and +\fIargvPtr\fR to remove arguments; the current implementation does not do so, +but callers \fIshould not\fR assume that this will be true in the future. .PP \fBTclzipfs_Mount\fR mounts the ZIP archive \fIzipname\fR on the mount point given in \fImountpoint\fR using the optional ZIP password \fIpassword\fR. diff --git a/generic/tcl.decls b/generic/tcl.decls index 3dec972..62416b2 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -514,7 +514,7 @@ declare 143 { void Tcl_Finalize(void) } declare 144 {nostub {Don't use this function in a stub-enabled extension}} { - void Tcl_FindExecutable(const char *argv0) + const char *Tcl_FindExecutable(const char *argv0) } declare 145 { Tcl_HashEntry *Tcl_FirstHashEntry(Tcl_HashTable *tablePtr, @@ -813,7 +813,7 @@ declare 229 { void Tcl_SetMaxBlockTime(const Tcl_Time *timePtr) } declare 230 {nostub {Don't use this function in a stub-enabled extension}} { - void Tcl_SetPanicProc(TCL_NORETURN1 Tcl_PanicProc *panicProc) + const char *Tcl_SetPanicProc(TCL_NORETURN1 Tcl_PanicProc *panicProc) } declare 231 { int Tcl_SetRecursionLimit(Tcl_Interp *interp, int depth) @@ -2488,13 +2488,13 @@ export { Tcl_LibraryInitProc *initProc, Tcl_LibraryInitProc *safeInitProc) } export { - void Tcl_SetPanicProc(TCL_NORETURN1 Tcl_PanicProc *panicProc) + const char *Tcl_SetPanicProc(TCL_NORETURN1 Tcl_PanicProc *panicProc) } export { Tcl_ExitProc *Tcl_SetExitProc(TCL_NORETURN1 Tcl_ExitProc *proc) } export { - void Tcl_FindExecutable(const char *argv0) + const char *Tcl_FindExecutable(const char *argv0) } export { const char *Tcl_InitStubs(Tcl_Interp *interp, const char *version, @@ -2512,10 +2512,10 @@ export { void Tcl_GetMemoryInfo(Tcl_DString *dsPtr) } export { - void Tcl_InitSubsystems(void) + const char *Tcl_InitSubsystems(void) } export { - int TclZipfs_AppHook(int *argc, char ***argv) + const char *TclZipfs_AppHook(int *argc, char ***argv) } # Local Variables: diff --git a/generic/tcl.h b/generic/tcl.h index 2d529b7..4c774d8 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -2383,16 +2383,16 @@ EXTERN void Tcl_MainEx(int argc, char **argv, Tcl_AppInitProc *appInitProc, Tcl_Interp *interp); EXTERN const char * Tcl_PkgInitStubsCheck(Tcl_Interp *interp, const char *version, int exact); -EXTERN void Tcl_InitSubsystems(void); +EXTERN const char * Tcl_InitSubsystems(void); EXTERN void Tcl_GetMemoryInfo(Tcl_DString *dsPtr); EXTERN const char * Tcl_SetPreInitScript(const char *string); #ifndef TCL_NO_DEPRECATED # define Tcl_StaticPackage Tcl_StaticLibrary #endif #ifdef _WIN32 -EXTERN int TclZipfs_AppHook(int *argc, wchar_t ***argv); +EXTERN const char *TclZipfs_AppHook(int *argc, wchar_t ***argv); #else -EXTERN int TclZipfs_AppHook(int *argc, char ***argv); +EXTERN const char *TclZipfs_AppHook(int *argc, char ***argv); #endif /* diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 713f3e9..74121bf 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -471,7 +471,7 @@ EXTERN int Tcl_ExprString(Tcl_Interp *interp, const char *expr); /* 143 */ EXTERN void Tcl_Finalize(void); /* 144 */ -EXTERN void Tcl_FindExecutable(const char *argv0); +EXTERN const char * Tcl_FindExecutable(const char *argv0); /* 145 */ EXTERN Tcl_HashEntry * Tcl_FirstHashEntry(Tcl_HashTable *tablePtr, Tcl_HashSearch *searchPtr); @@ -710,7 +710,7 @@ EXTERN void Tcl_SetErrorCode(Tcl_Interp *interp, ...); /* 229 */ EXTERN void Tcl_SetMaxBlockTime(const Tcl_Time *timePtr); /* 230 */ -EXTERN void Tcl_SetPanicProc( +EXTERN const char * Tcl_SetPanicProc( TCL_NORETURN1 Tcl_PanicProc *panicProc); /* 231 */ EXTERN int Tcl_SetRecursionLimit(Tcl_Interp *interp, int depth); @@ -2110,7 +2110,7 @@ typedef struct TclStubs { int (*tcl_ExprObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Obj **resultPtrPtr); /* 141 */ int (*tcl_ExprString) (Tcl_Interp *interp, const char *expr); /* 142 */ void (*tcl_Finalize) (void); /* 143 */ - TCL_DEPRECATED_API("Don't use this function in a stub-enabled extension") void (*tcl_FindExecutable) (const char *argv0); /* 144 */ + TCL_DEPRECATED_API("Don't use this function in a stub-enabled extension") const char * (*tcl_FindExecutable) (const char *argv0); /* 144 */ Tcl_HashEntry * (*tcl_FirstHashEntry) (Tcl_HashTable *tablePtr, Tcl_HashSearch *searchPtr); /* 145 */ int (*tcl_Flush) (Tcl_Channel chan); /* 146 */ TCL_DEPRECATED_API("see TIP #559. Use Tcl_ResetResult") void (*tcl_FreeResult) (Tcl_Interp *interp); /* 147 */ @@ -2204,7 +2204,7 @@ typedef struct TclStubs { void (*tcl_SetErrno) (int err); /* 227 */ void (*tcl_SetErrorCode) (Tcl_Interp *interp, ...); /* 228 */ void (*tcl_SetMaxBlockTime) (const Tcl_Time *timePtr); /* 229 */ - TCL_DEPRECATED_API("Don't use this function in a stub-enabled extension") void (*tcl_SetPanicProc) (TCL_NORETURN1 Tcl_PanicProc *panicProc); /* 230 */ + TCL_DEPRECATED_API("Don't use this function in a stub-enabled extension") const char * (*tcl_SetPanicProc) (TCL_NORETURN1 Tcl_PanicProc *panicProc); /* 230 */ int (*tcl_SetRecursionLimit) (Tcl_Interp *interp, int depth); /* 231 */ void (*tcl_SetResult) (Tcl_Interp *interp, char *result, Tcl_FreeProc *freeProc); /* 232 */ int (*tcl_SetServiceMode) (int mode); /* 233 */ diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 9367863..e2fb51b 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -1467,14 +1467,15 @@ Tcl_UtfToExternal( *--------------------------------------------------------------------------- */ #undef Tcl_FindExecutable -void +const char * Tcl_FindExecutable( const char *argv0) /* The value of the application's argv[0] * (native). */ { - Tcl_InitSubsystems(); + const char *version = Tcl_InitSubsystems(); TclpSetInitialEncodings(); TclpFindExecutable(argv0); + return version; } /* diff --git a/generic/tclEvent.c b/generic/tclEvent.c index 52cd351..a0250d2 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -1024,7 +1024,7 @@ Tcl_Exit( *------------------------------------------------------------------------- */ -void +const char * Tcl_InitSubsystems(void) { if (inExit != 0) { @@ -1071,6 +1071,7 @@ Tcl_InitSubsystems(void) TclpInitUnlock(); } TclInitNotifier(); + return NULL; } /* diff --git a/generic/tclPanic.c b/generic/tclPanic.c index 394661f..ba7e801 100644 --- a/generic/tclPanic.c +++ b/generic/tclPanic.c @@ -45,7 +45,8 @@ static TCL_NORETURN1 Tcl_PanicProc *panicProc = NULL; *---------------------------------------------------------------------- */ -void +#undef Tcl_SetPanicProc +const char * Tcl_SetPanicProc( TCL_NORETURN1 Tcl_PanicProc *proc) { @@ -58,7 +59,7 @@ Tcl_SetPanicProc( else #endif panicProc = proc; - Tcl_InitSubsystems(); + return Tcl_InitSubsystems(); } /* diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c index c1ba395..b0392b1 100644 --- a/generic/tclZipfs.c +++ b/generic/tclZipfs.c @@ -5797,7 +5797,7 @@ ZipfsMountExitHandler( *------------------------------------------------------------------------- */ -int +const char * TclZipfs_AppHook( #ifdef SUPPORT_BUILTIN_ZIP_INSTALL int *argcPtr, /* Pointer to argc */ @@ -5811,6 +5811,7 @@ TclZipfs_AppHook( #endif /* _WIN32 */ { const char *archive; + const char *version = Tcl_InitSubsystems(); #ifdef _WIN32 Tcl_FindExecutable(NULL); @@ -5853,7 +5854,7 @@ TclZipfs_AppHook( Tcl_DecrRefCount(vfsInitScript); if (found == TCL_OK) { zipfs_literal_tcl_library = ZIPFS_APP_MOUNT "/tcl_library"; - return TCL_OK; + return version; } } #ifdef SUPPORT_BUILTIN_ZIP_INSTALL @@ -5886,7 +5887,7 @@ TclZipfs_AppHook( if (Tcl_FSAccess(vfsInitScript, F_OK) == 0) { Tcl_SetStartupScript(vfsInitScript, NULL); } - return TCL_OK; + return version; } else if (!TclZipfs_Mount(NULL, ZIPFS_APP_MOUNT, archive, NULL)) { int found; Tcl_Obj *vfsInitScript; @@ -5910,7 +5911,7 @@ TclZipfs_AppHook( Tcl_DecrRefCount(vfsInitScript); if (found == TCL_OK) { zipfs_literal_tcl_library = ZIPFS_APP_MOUNT "/tcl_library"; - return TCL_OK; + return version; } } #ifdef _WIN32 @@ -5918,7 +5919,7 @@ TclZipfs_AppHook( #endif /* _WIN32 */ #endif /* SUPPORT_BUILTIN_ZIP_INSTALL */ } - return TCL_OK; + return version; } #ifndef HAVE_ZLIB diff --git a/unix/Makefile.in b/unix/Makefile.in index 99b38a0..d5ba886 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -1259,6 +1259,10 @@ tclAsync.o: $(GENERIC_DIR)/tclAsync.c tclBasic.o: $(GENERIC_DIR)/tclBasic.c $(COMPILEHDR) $(MATHHDRS) $(NREHDR) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclBasic.c +tclUuid.h: $(TOP_DIR)/manifest.uuid + echo "#define TCL_VERSION_UUID \\" >$@ + cat $(TOP_DIR)/manifest.uuid >>$@ + tclBinary.o: $(GENERIC_DIR)/tclBinary.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclBinary.c @@ -1313,7 +1317,7 @@ tclEnsemble.o: $(GENERIC_DIR)/tclEnsemble.c $(COMPILEHDR) tclEnv.o: $(GENERIC_DIR)/tclEnv.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclEnv.c -tclEvent.o: $(GENERIC_DIR)/tclEvent.c +tclEvent.o: $(GENERIC_DIR)/tclEvent.c tclUuid.h $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclEvent.c tclExecute.o: $(GENERIC_DIR)/tclExecute.c $(COMPILEHDR) $(MATHHDRS) $(NREHDR) @@ -1526,7 +1530,7 @@ tclZipfs.o: $(GENERIC_DIR)/tclZipfs.c -I$(ZLIB_DIR) -I$(ZLIB_DIR)/contrib/minizip \ $(GENERIC_DIR)/tclZipfs.c -tclTest.o: $(GENERIC_DIR)/tclTest.c $(IOHDR) $(TCLREHDRS) +tclTest.o: $(GENERIC_DIR)/tclTest.c $(IOHDR) $(TCLREHDRS) tclUuid.h $(CC) -c $(APP_CC_SWITCHES) $(GENERIC_DIR)/tclTest.c tclTestObj.o: $(GENERIC_DIR)/tclTestObj.c $(MATHHDRS) @@ -2228,8 +2232,8 @@ $(UNIX_DIR)/tclConfig.h.in: $(MAC_OSX_DIR)/configure cd $(MAC_OSX_DIR); autoheader; touch $@ $(TOP_DIR)/manifest.uuid: - printf "git." >$(TOP_DIR)/manifest.uuid - git rev-parse HEAD >>$(TOP_DIR)/manifest.uuid + printf "git-" >$(TOP_DIR)/manifest.uuid + (cd $(TOP_DIR); git rev-parse HEAD >>$(TOP_DIR)/manifest.uuid) dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in $(UNIX_DIR)/tcl.pc.in genstubs \ $(MAC_OSX_DIR)/configure $(TOP_DIR)/manifest.uuid dist-packages ${NATIVE_TCLSH} diff --git a/win/Makefile.in b/win/Makefile.in index df94aa1..383b9c7 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -673,6 +673,16 @@ tclPkgConfig.${OBJEXT}: tclPkgConfig.c -DBUILD_tcl \ @DEPARG@ $(CC_OBJNAME) +tclEvent.${OBJEXT}: tclEvent.c tclUuid.h + +$(TOP_DIR)/manifest.uuid: + printf "git-" >$(TOP_DIR)/manifest.uuid + git rev-parse HEAD >>$(TOP_DIR)/manifest.uuid + +tclUuid.h: $(TOP_DIR)/manifest.uuid + echo "#define TCL_VERSION_UUID \\" >$@ + cat $(TOP_DIR)/manifest.uuid >>$@ + # The following objects are part of the stub library and should not be built # as DLL objects but none of the symbols should be exported -- cgit v0.12 From 7ac3bf24153c2b9bd93dc7b4974e7ad7df158242 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 3 Aug 2021 10:26:10 +0000 Subject: Found the problem with Visual Studio: somehow it doesn't handle empty brackets [] right .... --- generic/tclEvent.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclEvent.c b/generic/tclEvent.c index 687dbcd..812dbb0 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -1034,7 +1034,7 @@ MODULE_SCOPE const TclStubs tclStubs; static const struct { const TclStubs *stubs; - const char version[]; + const char version[256]; } stubInfo = { &tclStubs, {TCL_PATCH_LEVEL "+" STRINGIFY(TCL_VERSION_UUID) #if defined(__clang__) && defined(__clang_major__) -- cgit v0.12 From 74d70948ceeadf971baefeb94914732724d1cb9a Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 4 Aug 2021 14:52:32 +0000 Subject: Fix knownMsvcBug testConstraint --- tests/format.test | 4 ++-- tests/socket.test | 1 - tests/winFCmd.test | 2 +- 3 files changed, 3 insertions(+), 4 deletions(-) diff --git a/tests/format.test b/tests/format.test index f7e776d..0dd55f0 100644 --- a/tests/format.test +++ b/tests/format.test @@ -23,8 +23,8 @@ testConstraint pointerIs64bit [expr {$tcl_platform(pointerSize) >= 8}] # MSVC uses a broken libc that gets sprintf("%g") wrong. This is a pain # particularly in Continuous Integration, and there isn't anything much we can # do about it. -testConstraint knownMsvcBug [string match msvc-* [tcl::build-info compiler]] - +testConstraint knownMsvcBug [expr {![string match msvc-* [tcl::build-info compiler]]}] + test format-1.1 {integer formatting} { format "%*d %d %d %d" 6 34 16923 -12 -1 } { 34 16923 -12 -1} diff --git a/tests/socket.test b/tests/socket.test index 17a635b..4644e1d 100644 --- a/tests/socket.test +++ b/tests/socket.test @@ -79,7 +79,6 @@ testConstraint notWine [expr {![info exists ::env(CI_USING_WINE)]}] # Some tests require the Thread package or exec command testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}] testConstraint exec [llength [info commands exec]] -testConstraint knownMsvcBug [string match msvc-* [tcl::build-info compiler]] testConstraint notWinCI [expr { $tcl_platform(platform) ne "windows" || ![info exists ::env(CI)]}] diff --git a/tests/winFCmd.test b/tests/winFCmd.test index f4e3b2f..43c7ced 100644 --- a/tests/winFCmd.test +++ b/tests/winFCmd.test @@ -29,7 +29,7 @@ testConstraint longFileNames 0 # Some things fail under all Continuous Integration systems for subtle reasons # such as CI often running with elevated privileges in a container. testConstraint notInCIenv [expr {![info exists ::env(CI)]}] -testConstraint knownMsvcBug [string match msvc-* [tcl::build-info compiler]] +testConstraint knownMsvcBug [expr {![string match msvc-* [tcl::build-info compiler]]}] proc createfile {file {string a}} { set f [open $file w] -- cgit v0.12 From d9f0f7a35d71e67c3e7cd0032a3d2581f2d1fee3 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 18 Oct 2021 08:56:26 +0000 Subject: separate testConstraint nodep --- tests/info.test | 1 - tests/regexp.test | 1 - tests/regexpComp.test | 2 -- tests/string.test | 1 - tests/stringObj.test | 1 - tests/tcltests.tcl | 1 + 6 files changed, 1 insertion(+), 6 deletions(-) diff --git a/tests/info.test b/tests/info.test index ced4435..19151d8 100644 --- a/tests/info.test +++ b/tests/info.test @@ -22,7 +22,6 @@ if {{::tcltest} ni [namespace children]} { ::tcltest::loadTestedCommands catch [list package require -exact tcl::test [info patchlevel]] testConstraint zlib [llength [info commands zlib]] -testConstraint nodep [info exists tcl_precision] # Set up namespaces needed to test operation of "info args", "info body", # "info default", and "info procs" with imported procedures. diff --git a/tests/regexp.test b/tests/regexp.test index 6bed21e..bea530f 100644 --- a/tests/regexp.test +++ b/tests/regexp.test @@ -19,7 +19,6 @@ if {"::tcltest" ni [namespace children]} { unset -nocomplain foo testConstraint exec [llength [info commands exec]] -testConstraint nodep [info exists tcl_precision] # Used for constraining memory leak tests testConstraint memory [llength [info commands memory]] diff --git a/tests/regexpComp.test b/tests/regexpComp.test index 1587c72..39d7a4c 100644 --- a/tests/regexpComp.test +++ b/tests/regexpComp.test @@ -16,8 +16,6 @@ if {"::tcltest" ni [namespace children]} { namespace import -force ::tcltest::* } -testConstraint nodep [info exists tcl_precision] - # Procedure to evaluate a script within a proc, to test compilation # functionality diff --git a/tests/string.test b/tests/string.test index 822899c..ececc31 100644 --- a/tests/string.test +++ b/tests/string.test @@ -33,7 +33,6 @@ testConstraint testindexobj [expr {[info commands testindexobj] ne {}}] testConstraint testevalex [expr {[info commands testevalex] ne {}}] testConstraint utf16 [expr {[string length \U010000] == 2}] testConstraint testbytestring [llength [info commands testbytestring]] -testConstraint nodep [info exists tcl_precision] # Used for constraining memory leak tests testConstraint memory [llength [info commands memory]] diff --git a/tests/stringObj.test b/tests/stringObj.test index 135830c..51d1e9b 100644 --- a/tests/stringObj.test +++ b/tests/stringObj.test @@ -24,7 +24,6 @@ testConstraint testobj [llength [info commands testobj]] testConstraint testbytestring [llength [info commands testbytestring]] testConstraint testdstring [llength [info commands testdstring]] testConstraint tip389 [expr {[string length \U010000] == 2}] -testConstraint nodep [info exists tcl_precision] test stringObj-1.1 {string type registration} testobj { set t [testobj types] diff --git a/tests/tcltests.tcl b/tests/tcltests.tcl index a5d7044..cd9582e 100644 --- a/tests/tcltests.tcl +++ b/tests/tcltests.tcl @@ -3,6 +3,7 @@ package require tcltest 2.5 namespace import ::tcltest::* testConstraint exec [llength [info commands exec]] +testConstraint nodep [tcl::build-info no-deprecate] testConstraint debug [tcl::build-info debug] testConstraint purify [tcl::build-info purify] testConstraint debugpurify [ -- cgit v0.12 From 9e52c62db68eb5312db3378faa921f3dfaa35e41 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 23 Nov 2021 21:33:14 +0000 Subject: 2 minor improvements: Make sure tclUuid.h ends with newline; Fallback "unknown" if neither GIT, neither fossil is detected --- unix/Makefile.in | 3 ++- win/Makefile.in | 3 ++- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/unix/Makefile.in b/unix/Makefile.in index 6f51a0b..3447acb 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -1260,6 +1260,7 @@ tclBasic.o: $(GENERIC_DIR)/tclBasic.c $(COMPILEHDR) $(MATHHDRS) $(NREHDR) tclUuid.h: $(TOP_DIR)/manifest.uuid echo "#define TCL_VERSION_UUID \\" >$@ cat $(TOP_DIR)/manifest.uuid >>$@ + echo "" >>$@ tclBinary.o: $(GENERIC_DIR)/tclBinary.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclBinary.c @@ -2231,7 +2232,7 @@ $(UNIX_DIR)/tclConfig.h.in: $(MAC_OSX_DIR)/configure $(TOP_DIR)/manifest.uuid: printf "git-" >$(TOP_DIR)/manifest.uuid - (cd $(TOP_DIR); git rev-parse HEAD >>$(TOP_DIR)/manifest.uuid) + (cd $(TOP_DIR); git rev-parse HEAD >>$(TOP_DIR)/manifest.uuid || printf "unknown" >$(TOP_DIR)/manifest.uuid) dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in $(UNIX_DIR)/tcl.pc.in genstubs \ $(MAC_OSX_DIR)/configure $(TOP_DIR)/manifest.uuid dist-packages ${NATIVE_TCLSH} diff --git a/win/Makefile.in b/win/Makefile.in index c8b0bbe..7adb057 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -677,11 +677,12 @@ tclEvent.${OBJEXT}: tclEvent.c tclUuid.h $(TOP_DIR)/manifest.uuid: printf "git-" >$(TOP_DIR)/manifest.uuid - git rev-parse HEAD >>$(TOP_DIR)/manifest.uuid + (cd $(TOP_DIR); git rev-parse HEAD >>$(TOP_DIR)/manifest.uuid || printf "unknown" >$(TOP_DIR)/manifest.uuid) tclUuid.h: $(TOP_DIR)/manifest.uuid echo "#define TCL_VERSION_UUID \\" >$@ cat $(TOP_DIR)/manifest.uuid >>$@ + echo "" >>$@ # The following objects are part of the stub library and should not be built # as DLL objects but none of the symbols should be exported -- cgit v0.12 From 21b68e66bfedb1b5ef1c935435804178dee4acc4 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 24 Nov 2021 14:51:34 +0000 Subject: Add support for subversion too --- unix/Makefile.in | 5 ++++- win/Makefile.in | 5 ++++- 2 files changed, 8 insertions(+), 2 deletions(-) diff --git a/unix/Makefile.in b/unix/Makefile.in index 3447acb..2527abf 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -2232,7 +2232,10 @@ $(UNIX_DIR)/tclConfig.h.in: $(MAC_OSX_DIR)/configure $(TOP_DIR)/manifest.uuid: printf "git-" >$(TOP_DIR)/manifest.uuid - (cd $(TOP_DIR); git rev-parse HEAD >>$(TOP_DIR)/manifest.uuid || printf "unknown" >$(TOP_DIR)/manifest.uuid) + (cd $(TOP_DIR); git rev-parse HEAD >>$(TOP_DIR)/manifest.uuid || \ + (printf "svn-r" >$(TOP_DIR)/manifest.uuid ; \ + svn info --show-item last-changed-revision >>$(TOP_DIR)/manifest.uuid) || \ + printf "unknown" >$(TOP_DIR)/manifest.uuid) dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in $(UNIX_DIR)/tcl.pc.in genstubs \ $(MAC_OSX_DIR)/configure $(TOP_DIR)/manifest.uuid dist-packages ${NATIVE_TCLSH} diff --git a/win/Makefile.in b/win/Makefile.in index aa8cd54..35c4f21 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -677,7 +677,10 @@ tclEvent.${OBJEXT}: tclEvent.c tclUuid.h $(TOP_DIR)/manifest.uuid: printf "git-" >$(TOP_DIR)/manifest.uuid - (cd $(TOP_DIR); git rev-parse HEAD >>$(TOP_DIR)/manifest.uuid || printf "unknown" >$(TOP_DIR)/manifest.uuid) + (cd $(TOP_DIR); git rev-parse HEAD >>$(TOP_DIR)/manifest.uuid || \ + (printf "svn-r" >$(TOP_DIR)/manifest.uuid ; \ + svn info --show-item last-changed-revision >>$(TOP_DIR)/manifest.uuid) || \ + printf "unknown" >$(TOP_DIR)/manifest.uuid) tclUuid.h: $(TOP_DIR)/manifest.uuid echo "#define TCL_VERSION_UUID \\" >$@ -- cgit v0.12 From 99180fcdaaf8ba3beaedacc81c08af5bfe951b7e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 26 Nov 2021 15:47:49 +0000 Subject: Change TclInitSubsystems() signature, matching Tcl_InitSubsystems() in Tcl 8.7. Add more type-casts (better C++ compatibility) --- generic/tclBasic.c | 296 +++++++++++++++++++++++++++-------------------------- generic/tclEvent.c | 65 +++++++----- generic/tclInt.h | 2 +- 3 files changed, 190 insertions(+), 173 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index df86f8c..2928f37 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -471,8 +471,7 @@ Tcl_CreateInterp(void) #endif /* TCL_COMPILE_STATS */ char mathFuncName[32]; CallFrame *framePtr; - - TclInitSubsystems(); + const char *version = TclInitSubsystems(); /* * Panic if someone updated the CallFrame structure without also updating @@ -480,7 +479,6 @@ Tcl_CreateInterp(void) */ if (sizeof(Tcl_CallFrame) < sizeof(CallFrame)) { - /*NOTREACHED*/ Tcl_Panic("Tcl_CallFrame must not be smaller than CallFrame"); } @@ -493,7 +491,6 @@ Tcl_CreateInterp(void) */ if ((TclOffset(Tcl_StatBuf,st_atime) != 32) || (TclOffset(Tcl_StatBuf,st_ctime) != 40)) { - /*NOTREACHED*/ Tcl_Panic(" is not compatible with MSVC"); } #endif @@ -504,6 +501,7 @@ Tcl_CreateInterp(void) Tcl_InitHashTable(&cancelTable, TCL_ONE_WORD_KEYS); cancelTableInitialized = 1; } + Tcl_MutexUnlock(&cancelLock); } @@ -513,7 +511,7 @@ Tcl_CreateInterp(void) * object type table and other object management code. */ - iPtr = ckalloc(sizeof(Interp)); + iPtr = (Interp *)ckalloc(sizeof(Interp)); interp = (Tcl_Interp *) iPtr; iPtr->result = iPtr->resultSpace; @@ -540,10 +538,10 @@ Tcl_CreateInterp(void) */ iPtr->cmdFramePtr = NULL; - iPtr->linePBodyPtr = ckalloc(sizeof(Tcl_HashTable)); - iPtr->lineBCPtr = ckalloc(sizeof(Tcl_HashTable)); - iPtr->lineLAPtr = ckalloc(sizeof(Tcl_HashTable)); - iPtr->lineLABCPtr = ckalloc(sizeof(Tcl_HashTable)); + iPtr->linePBodyPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); + iPtr->lineBCPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); + iPtr->lineLAPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); + iPtr->lineLABCPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(iPtr->linePBodyPtr, TCL_ONE_WORD_KEYS); Tcl_InitHashTable(iPtr->lineBCPtr, TCL_ONE_WORD_KEYS); Tcl_InitHashTable(iPtr->lineLAPtr, TCL_ONE_WORD_KEYS); @@ -645,7 +643,7 @@ Tcl_CreateInterp(void) */ /* This is needed to satisfy GCC 3.3's strict aliasing rules */ - framePtr = ckalloc(sizeof(CallFrame)); + framePtr = (CallFrame *)ckalloc(sizeof(CallFrame)); (void) Tcl_PushCallFrame(interp, (Tcl_CallFrame *) framePtr, (Tcl_Namespace *) iPtr->globalNsPtr, /*isProcCallFrame*/ 0); framePtr->objc = 0; @@ -675,7 +673,7 @@ Tcl_CreateInterp(void) iPtr->asyncCancelMsg = Tcl_NewObj(); - cancelInfo = ckalloc(sizeof(CancelInfo)); + cancelInfo = (CancelInfo *)ckalloc(sizeof(CancelInfo)); cancelInfo->interp = interp; iPtr->asyncCancel = Tcl_AsyncCreate(CancelEvalProc, cancelInfo); @@ -745,7 +743,7 @@ Tcl_CreateInterp(void) */ #if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC) - iPtr->allocCache = TclpGetAllocCache(); + iPtr->allocCache = (AllocCache *)TclpGetAllocCache(); #else iPtr->allocCache = NULL; #endif @@ -774,7 +772,7 @@ Tcl_CreateInterp(void) hPtr = Tcl_CreateHashEntry(&iPtr->globalNsPtr->cmdTable, cmdInfoPtr->name, &isNew); if (isNew) { - cmdPtr = ckalloc(sizeof(Command)); + cmdPtr = (Command *)ckalloc(sizeof(Command)); cmdPtr->hPtr = hPtr; cmdPtr->nsPtr = iPtr->globalNsPtr; cmdPtr->refCount = 1; @@ -907,7 +905,7 @@ Tcl_CreateInterp(void) #define MATH_OP_PREFIX_LEN 15 /* == strlen("::tcl::mathop::") */ memcpy(mathFuncName, "::tcl::mathop::", MATH_OP_PREFIX_LEN); for (opcmdInfoPtr=mathOpCmds ; opcmdInfoPtr->name!=NULL ; opcmdInfoPtr++){ - TclOpCmdClientData *occdPtr = ckalloc(sizeof(TclOpCmdClientData)); + TclOpCmdClientData *occdPtr = (TclOpCmdClientData *)ckalloc(sizeof(TclOpCmdClientData)); occdPtr->op = opcmdInfoPtr->name; occdPtr->i.numArgs = opcmdInfoPtr->i.numArgs; @@ -1015,7 +1013,7 @@ static void DeleteOpCmdClientData( ClientData clientData) { - TclOpCmdClientData *occdPtr = clientData; + TclOpCmdClientData *occdPtr = (TclOpCmdClientData *)clientData; ckfree(occdPtr); } @@ -1086,17 +1084,17 @@ Tcl_CallWhenDeleted( Interp *iPtr = (Interp *) interp; static Tcl_ThreadDataKey assocDataCounterKey; int *assocDataCounterPtr = - Tcl_GetThreadData(&assocDataCounterKey, (int)sizeof(int)); + (int *)Tcl_GetThreadData(&assocDataCounterKey, sizeof(int)); int isNew; char buffer[32 + TCL_INTEGER_SPACE]; - AssocData *dPtr = ckalloc(sizeof(AssocData)); + AssocData *dPtr = (AssocData *)ckalloc(sizeof(AssocData)); Tcl_HashEntry *hPtr; sprintf(buffer, "Assoc Data Key #%d", *assocDataCounterPtr); (*assocDataCounterPtr)++; if (iPtr->assocData == NULL) { - iPtr->assocData = ckalloc(sizeof(Tcl_HashTable)); + iPtr->assocData = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS); } hPtr = Tcl_CreateHashEntry(iPtr->assocData, buffer, &isNew); @@ -1143,7 +1141,7 @@ Tcl_DontCallWhenDeleted( } for (hPtr = Tcl_FirstHashEntry(hTablePtr, &hSearch); hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) { - dPtr = Tcl_GetHashValue(hPtr); + dPtr = (AssocData *)Tcl_GetHashValue(hPtr); if ((dPtr->proc == proc) && (dPtr->clientData == clientData)) { ckfree(dPtr); Tcl_DeleteHashEntry(hPtr); @@ -1185,14 +1183,14 @@ Tcl_SetAssocData( int isNew; if (iPtr->assocData == NULL) { - iPtr->assocData = ckalloc(sizeof(Tcl_HashTable)); + iPtr->assocData = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS); } hPtr = Tcl_CreateHashEntry(iPtr->assocData, name, &isNew); if (isNew == 0) { - dPtr = Tcl_GetHashValue(hPtr); + dPtr = (AssocData *)Tcl_GetHashValue(hPtr); } else { - dPtr = ckalloc(sizeof(AssocData)); + dPtr = (AssocData *)ckalloc(sizeof(AssocData)); } dPtr->proc = proc; dPtr->clientData = clientData; @@ -1233,7 +1231,7 @@ Tcl_DeleteAssocData( if (hPtr == NULL) { return; } - dPtr = Tcl_GetHashValue(hPtr); + dPtr = (AssocData *)Tcl_GetHashValue(hPtr); if (dPtr->proc != NULL) { dPtr->proc(dPtr->clientData, interp); } @@ -1278,7 +1276,7 @@ Tcl_GetAssocData( if (hPtr == NULL) { return NULL; } - dPtr = Tcl_GetHashValue(hPtr); + dPtr = (AssocData *)Tcl_GetHashValue(hPtr); if (procPtr != NULL) { *procPtr = dPtr->proc; } @@ -1429,7 +1427,7 @@ DeleteInterpProc( Tcl_MutexLock(&cancelLock); hPtr = Tcl_FindHashEntry(&cancelTable, (char *) iPtr); if (hPtr != NULL) { - CancelInfo *cancelInfo = Tcl_GetHashValue(hPtr); + CancelInfo *cancelInfo = (CancelInfo *)Tcl_GetHashValue(hPtr); if (cancelInfo != NULL) { if (cancelInfo->result != NULL) { @@ -1487,7 +1485,7 @@ DeleteInterpProc( hPtr = Tcl_FirstHashEntry(hTablePtr, &search); for (; hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { - Tcl_DeleteCommandFromToken(interp, Tcl_GetHashValue(hPtr)); + Tcl_DeleteCommandFromToken(interp, (Tcl_Command)Tcl_GetHashValue(hPtr)); } Tcl_DeleteHashTable(hTablePtr); ckfree(hTablePtr); @@ -1506,7 +1504,7 @@ DeleteInterpProc( for (hPtr = Tcl_FirstHashEntry(hTablePtr, &search); hPtr != NULL; hPtr = Tcl_FirstHashEntry(hTablePtr, &search)) { - dPtr = Tcl_GetHashValue(hPtr); + dPtr = (AssocData *)Tcl_GetHashValue(hPtr); Tcl_DeleteHashEntry(hPtr); if (dPtr->proc != NULL) { dPtr->proc(dPtr->clientData, interp); @@ -1599,7 +1597,7 @@ DeleteInterpProc( for (hPtr = Tcl_FirstHashEntry(iPtr->linePBodyPtr, &search); hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { - CmdFrame *cfPtr = Tcl_GetHashValue(hPtr); + CmdFrame *cfPtr = (CmdFrame *)Tcl_GetHashValue(hPtr); Proc *procPtr = (Proc *) Tcl_GetHashKey(iPtr->linePBodyPtr, hPtr); procPtr->iPtr = NULL; @@ -1623,7 +1621,7 @@ DeleteInterpProc( for (hPtr = Tcl_FirstHashEntry(iPtr->lineBCPtr, &search); hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { - ExtCmdLoc *eclPtr = Tcl_GetHashValue(hPtr); + ExtCmdLoc *eclPtr = (ExtCmdLoc *)Tcl_GetHashValue(hPtr); if (eclPtr->type == TCL_LOCATION_SOURCE) { Tcl_DecrRefCount(eclPtr->path); @@ -1787,7 +1785,7 @@ Tcl_HideCommand( hiddenCmdTablePtr = iPtr->hiddenCmdTablePtr; if (hiddenCmdTablePtr == NULL) { - hiddenCmdTablePtr = ckalloc(sizeof(Tcl_HashTable)); + hiddenCmdTablePtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(hiddenCmdTablePtr, TCL_STRING_KEYS); iPtr->hiddenCmdTablePtr = hiddenCmdTablePtr; } @@ -1927,7 +1925,7 @@ Tcl_ExposeCommand( hiddenCmdToken, NULL); return TCL_ERROR; } - cmdPtr = Tcl_GetHashValue(hPtr); + cmdPtr = (Command *)Tcl_GetHashValue(hPtr); /* * Check that we have a true global namespace command (enforced by @@ -2123,7 +2121,7 @@ Tcl_CreateCommand( * An existing command conflicts. Try to delete it... */ - cmdPtr = Tcl_GetHashValue(hPtr); + cmdPtr = (Command *)Tcl_GetHashValue(hPtr); /* * Be careful to preserve any existing import links so we can restore @@ -2178,7 +2176,7 @@ Tcl_CreateCommand( TclInvalidateNsCmdLookup(nsPtr); TclInvalidateNsPath(nsPtr); } - cmdPtr = ckalloc(sizeof(Command)); + cmdPtr = (Command *)ckalloc(sizeof(Command)); Tcl_SetHashValue(hPtr, cmdPtr); cmdPtr->hPtr = hPtr; cmdPtr->nsPtr = nsPtr; @@ -2205,7 +2203,7 @@ Tcl_CreateCommand( cmdPtr->importRefPtr = oldRefPtr; while (oldRefPtr != NULL) { Command *refCmdPtr = oldRefPtr->importedCmdPtr; - dataPtr = refCmdPtr->objClientData; + dataPtr = (ImportedCmdData *)refCmdPtr->objClientData; dataPtr->realCmdPtr = cmdPtr; oldRefPtr = oldRefPtr->nextPtr; } @@ -2300,30 +2298,33 @@ Tcl_CreateObjCommand( } Tcl_Command -TclCreateObjCommandInNs ( +TclCreateObjCommandInNs( Tcl_Interp *interp, - const char *cmdName, /* Name of command, without any namespace components */ - Tcl_Namespace *namespace, /* The namespace to create the command in */ + const char *cmdName, /* Name of command, without any namespace + * components. */ + Tcl_Namespace *namesp, /* The namespace to create the command in */ Tcl_ObjCmdProc *proc, /* Object-based function to associate with * name. */ ClientData clientData, /* Arbitrary value to pass to object * function. */ - Tcl_CmdDeleteProc *deleteProc + Tcl_CmdDeleteProc *deleteProc) /* If not NULL, gives a function to call when * this command is deleted. */ -) { +{ int deleted = 0, isNew = 0; Command *cmdPtr; ImportRef *oldRefPtr = NULL; ImportedCmdData *dataPtr; Tcl_HashEntry *hPtr; - Namespace *nsPtr = (Namespace *) namespace; + Namespace *nsPtr = (Namespace *) namesp; + /* - * If the command name we seek to create already exists, we need to - * delete that first. That can be tricky in the presence of traces. - * Loop until we no longer find an existing command in the way, or - * until we've deleted one command and that didn't finish the job. + * If the command name we seek to create already exists, we need to delete + * that first. That can be tricky in the presence of traces. Loop until we + * no longer find an existing command in the way, or until we've deleted + * one command and that didn't finish the job. */ + while (1) { hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, cmdName, &isNew); @@ -2339,7 +2340,7 @@ TclCreateObjCommandInNs ( * An existing command conflicts. Try to delete it... */ - cmdPtr = Tcl_GetHashValue(hPtr); + cmdPtr = (Command *)Tcl_GetHashValue(hPtr); /* * [***] This is wrong. See Tcl Bug a16752c252. @@ -2378,7 +2379,7 @@ TclCreateObjCommandInNs ( Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr); nsPtr = (Namespace *) TclEnsureNamespace(interp, - (Tcl_Namespace *)cmdPtr->nsPtr); + (Tcl_Namespace *) cmdPtr->nsPtr); TclNsDecrRefCount(cmdPtr->nsPtr); if (cmdPtr->flags & CMD_REDEF_IN_PROGRESS) { @@ -2390,9 +2391,9 @@ TclCreateObjCommandInNs ( } if (!isNew) { /* - * If the deletion callback recreated the command, just throw away - * the new command (if we try to delete it again, we could get - * stuck in an infinite loop). + * If the deletion callback recreated the command, just throw away the + * new command (if we try to delete it again, we could get stuck in an + * infinite loop). */ ckfree(Tcl_GetHashValue(hPtr)); @@ -2420,7 +2421,7 @@ TclCreateObjCommandInNs ( TclInvalidateNsCmdLookup(nsPtr); TclInvalidateNsPath(nsPtr); } - cmdPtr = ckalloc(sizeof(Command)); + cmdPtr = (Command *)ckalloc(sizeof(Command)); Tcl_SetHashValue(hPtr, cmdPtr); cmdPtr->hPtr = hPtr; cmdPtr->nsPtr = nsPtr; @@ -2447,7 +2448,7 @@ TclCreateObjCommandInNs ( cmdPtr->importRefPtr = oldRefPtr; while (oldRefPtr != NULL) { Command *refCmdPtr = oldRefPtr->importedCmdPtr; - dataPtr = refCmdPtr->objClientData; + dataPtr = (ImportedCmdData*)refCmdPtr->objClientData; dataPtr->realCmdPtr = cmdPtr; oldRefPtr = oldRefPtr->nextPtr; } @@ -2492,10 +2493,10 @@ TclInvokeStringCommand( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Command *cmdPtr = clientData; + Command *cmdPtr = (Command *)clientData; int i, result; - const char **argv = - TclStackAlloc(interp, (unsigned)(objc + 1) * sizeof(char *)); + const char **argv = (const char **) + TclStackAlloc(interp, (objc + 1) * sizeof(char *)); for (i = 0; i < objc; i++) { argv[i] = Tcl_GetString(objv[i]); @@ -2524,7 +2525,7 @@ TclInvokeStringCommand( * in the Command structure. * * Results: - * A standard Tcl string result value. + * A standard Tcl result value. * * Side effects: * Besides those side effects of the called Tcl_ObjCmdProc, @@ -2540,11 +2541,11 @@ TclInvokeObjectCommand( int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ { - Command *cmdPtr = clientData; + Command *cmdPtr = ( Command *) clientData; Tcl_Obj *objPtr; int i, length, result; - Tcl_Obj **objv = - TclStackAlloc(interp, (unsigned)(argc * sizeof(Tcl_Obj *))); + Tcl_Obj **objv = (Tcl_Obj **) + TclStackAlloc(interp, (argc * sizeof(Tcl_Obj *))); for (i = 0; i < argc; i++) { length = strlen(argv[i]); @@ -2995,7 +2996,7 @@ Tcl_GetCommandName( return ""; } - return Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr); + return (const char *)Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr); } /* @@ -3045,7 +3046,7 @@ Tcl_GetCommandFullName( } } if (cmdPtr->hPtr != NULL) { - name = Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr); + name = (char *)Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr); Tcl_AppendToObj(objPtr, name, -1); } } @@ -3188,7 +3189,7 @@ Tcl_DeleteCommandFromToken( } /* - * The list of command exported from the namespace might have changed. + * The list of commands exported from the namespace might have changed. * However, we do not need to recompute this just yet; next time we need * the info will be soon enough. */ @@ -3209,11 +3210,11 @@ Tcl_DeleteCommandFromToken( iPtr->compileEpoch++; } - /* - * Delete any imports of this routine elsewhere before calling deleteProc - * to that traces on the imports don't reference deallocated storage. - */ if (!(cmdPtr->flags & CMD_REDEF_IN_PROGRESS)) { + /* + * Delete any imports of this routine before deleting this routine itself. + * See issue 688fcc7082fa. + */ for (refPtr = cmdPtr->importRefPtr; refPtr != NULL; refPtr = nextRefPtr) { nextRefPtr = refPtr->nextPtr; @@ -3251,6 +3252,13 @@ Tcl_DeleteCommandFromToken( if (cmdPtr->hPtr != NULL) { Tcl_DeleteHashEntry(cmdPtr->hPtr); cmdPtr->hPtr = NULL; + + /* + * Bump the command epoch counter. This will invalidate all cached + * references that point to this command. + */ + + cmdPtr->cmdEpoch++; } /* @@ -3419,7 +3427,7 @@ CancelEvalProc( Tcl_Interp *interp, /* Ignored */ int code) /* Current return code from command. */ { - CancelInfo *cancelInfo = clientData; + CancelInfo *cancelInfo = (CancelInfo *)clientData; Interp *iPtr; if (cancelInfo != NULL) { @@ -3496,8 +3504,7 @@ TclCleanupCommand( Command *cmdPtr) /* Points to the Command structure to * be freed. */ { - cmdPtr->refCount--; - if (cmdPtr->refCount <= 0) { + if (cmdPtr->refCount-- <= 1) { ckfree(cmdPtr); } } @@ -3539,11 +3546,11 @@ Tcl_CreateMathFunc( * function. */ { Tcl_DString bigName; - OldMathFuncData *data = ckalloc(sizeof(OldMathFuncData)); + OldMathFuncData *data = (OldMathFuncData *)ckalloc(sizeof(OldMathFuncData)); data->proc = proc; data->numArgs = numArgs; - data->argTypes = ckalloc(numArgs * sizeof(Tcl_ValueType)); + data->argTypes = (Tcl_ValueType *)ckalloc(numArgs * sizeof(Tcl_ValueType)); memcpy(data->argTypes, argTypes, numArgs * sizeof(Tcl_ValueType)); data->clientData = clientData; @@ -3574,14 +3581,14 @@ Tcl_CreateMathFunc( static int OldMathFuncProc( - ClientData clientData, /* Ponter to OldMathFuncData describing the + ClientData clientData, /* Pointer to OldMathFuncData describing the * function being called */ Tcl_Interp *interp, /* Tcl interpreter */ int objc, /* Actual parameter count */ Tcl_Obj *const *objv) /* Parameter vector */ { Tcl_Obj *valuePtr; - OldMathFuncData *dataPtr = clientData; + OldMathFuncData *dataPtr = (OldMathFuncData *)clientData; Tcl_Value funcResult, *args; int result; int j, k; @@ -3600,7 +3607,7 @@ OldMathFuncProc( * Convert arguments from Tcl_Obj's to Tcl_Value's. */ - args = ckalloc(dataPtr->numArgs * sizeof(Tcl_Value)); + args = (Tcl_Value *)ckalloc(dataPtr->numArgs * sizeof(Tcl_Value)); for (j = 1, k = 0; j < objc; ++j, ++k) { /* TODO: Convert to TclGetNumberFromObj? */ valuePtr = objv[j]; @@ -3718,7 +3725,7 @@ static void OldMathFuncDeleteProc( ClientData clientData) { - OldMathFuncData *dataPtr = clientData; + OldMathFuncData *dataPtr = (OldMathFuncData *)clientData; ckfree(dataPtr->argTypes); ckfree(dataPtr); @@ -3791,7 +3798,7 @@ Tcl_GetMathFuncInfo( */ if (cmdPtr->objProc == &OldMathFuncProc) { - OldMathFuncData *dataPtr = cmdPtr->clientData; + OldMathFuncData *dataPtr = (OldMathFuncData *)cmdPtr->clientData; *procPtr = dataPtr->proc; *numArgsPtr = dataPtr->numArgs; @@ -4127,7 +4134,7 @@ Tcl_CancelEval( goto done; } - cancelInfo = Tcl_GetHashValue(hPtr); + cancelInfo = (CancelInfo *)Tcl_GetHashValue(hPtr); /* * Populate information needed by the interpreter thread to fulfill the @@ -4139,7 +4146,7 @@ Tcl_CancelEval( if (resultObjPtr != NULL) { result = Tcl_GetStringFromObj(resultObjPtr, &cancelInfo->length); - cancelInfo->result = ckrealloc(cancelInfo->result,cancelInfo->length); + cancelInfo->result = (char *)ckrealloc(cancelInfo->result,cancelInfo->length); memcpy(cancelInfo->result, result, cancelInfo->length); TclDecrRefCount(resultObjPtr); /* Discard their result object. */ } else { @@ -4259,10 +4266,10 @@ EvalObjvCore( Tcl_Interp *interp, int result) { - Command *cmdPtr = NULL, *preCmdPtr = data[0]; + Command *cmdPtr = NULL, *preCmdPtr = (Command *)data[0]; int flags = PTR2INT(data[1]); int objc = PTR2INT(data[2]); - Tcl_Obj **objv = data[3]; + Tcl_Obj **objv = (Tcl_Obj **)data[3]; Interp *iPtr = (Interp *) interp; Namespace *lookupNsPtr = NULL; int enterTracesDone = 0; @@ -4419,10 +4426,10 @@ Dispatch( Tcl_Interp *interp, int result) { - Tcl_ObjCmdProc *objProc = data[0]; + Tcl_ObjCmdProc *objProc = (Tcl_ObjCmdProc *)data[0]; ClientData clientData = data[1]; int objc = PTR2INT(data[2]); - Tcl_Obj **objv = data[3]; + Tcl_Obj **objv = (Tcl_Obj **)data[3]; Interp *iPtr = (Interp *) interp; #ifdef USE_DTRACE @@ -4603,7 +4610,7 @@ TEOV_RestoreVarFrame( Tcl_Interp *interp, int result) { - ((Interp *) interp)->varFramePtr = data[0]; + ((Interp *) interp)->varFramePtr = (CallFrame *)data[0]; return result; } @@ -4647,9 +4654,9 @@ TEOV_Error( const char *cmdString; int cmdLen; int objc = PTR2INT(data[0]); - Tcl_Obj **objv = data[1]; + Tcl_Obj **objv = (Tcl_Obj **)data[1]; - if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)){ + if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { /* * If there was an error, a command string will be needed for the * error log: get it out of the itemPtr. The details depend on the @@ -4709,7 +4716,7 @@ TEOV_NotFound( Tcl_ListObjGetElements(NULL, currNsPtr->unknownHandlerPtr, &handlerObjc, &handlerObjv); newObjc = objc + handlerObjc; - newObjv = TclStackAlloc(interp, (int) sizeof(Tcl_Obj *) * newObjc); + newObjv = (Tcl_Obj **)TclStackAlloc(interp, sizeof(Tcl_Obj *) * newObjc); /* * Copy command prefix from unknown handler and add on the real command's @@ -4770,8 +4777,8 @@ TEOV_NotFoundCallback( { Interp *iPtr = (Interp *) interp; int objc = PTR2INT(data[0]); - Tcl_Obj **objv = data[1]; - Namespace *savedNsPtr = data[2]; + Tcl_Obj **objv = (Tcl_Obj **)data[1]; + Namespace *savedNsPtr = (Namespace *)data[2]; int i; @@ -4851,14 +4858,14 @@ TEOV_RunLeaveTraces( Interp *iPtr = (Interp *) interp; int traceCode = TCL_OK; int objc = PTR2INT(data[0]); - Tcl_Obj *commandPtr = data[1]; - Command *cmdPtr = data[2]; - Tcl_Obj **objv = data[3]; + Tcl_Obj *commandPtr = (Tcl_Obj *)data[1]; + Command *cmdPtr = (Command *)data[2]; + Tcl_Obj **objv = (Tcl_Obj **)data[3]; int length; const char *command = Tcl_GetStringFromObj(commandPtr, &length); if (!(cmdPtr->flags & CMD_IS_DELETED)) { - if (cmdPtr->flags & CMD_HAS_EXEC_TRACES){ + if (cmdPtr->flags & CMD_HAS_EXEC_TRACES) { traceCode = TclCheckExecutionTraces(interp, command, length, cmdPtr, result, TCL_TRACE_LEAVE_EXEC, objc, objv); } @@ -5074,12 +5081,12 @@ TclEvalEx( * state has been allocated while evaluating * the script, so that it can be freed * properly if an error occurs. */ - Tcl_Parse *parsePtr = TclStackAlloc(interp, sizeof(Tcl_Parse)); - CmdFrame *eeFramePtr = TclStackAlloc(interp, sizeof(CmdFrame)); - Tcl_Obj **stackObjArray = + Tcl_Parse *parsePtr = (Tcl_Parse *)TclStackAlloc(interp, sizeof(Tcl_Parse)); + CmdFrame *eeFramePtr = (CmdFrame *)TclStackAlloc(interp, sizeof(CmdFrame)); + Tcl_Obj **stackObjArray = (Tcl_Obj **) TclStackAlloc(interp, minObjs * sizeof(Tcl_Obj *)); - int *expandStack = TclStackAlloc(interp, minObjs * sizeof(int)); - int *linesStack = TclStackAlloc(interp, minObjs * sizeof(int)); + int *expandStack = (int *)TclStackAlloc(interp, minObjs * sizeof(int)); + int *linesStack = (int *)TclStackAlloc(interp, minObjs * sizeof(int)); /* TIP #280 Structures for tracking of command * locations. */ int *clNext = NULL; /* Pointer for the tracking of invisible @@ -5215,9 +5222,9 @@ TclEvalEx( */ if (numWords > minObjs) { - expand = ckalloc(numWords * sizeof(int)); - objvSpace = ckalloc(numWords * sizeof(Tcl_Obj *)); - lineSpace = ckalloc(numWords * sizeof(int)); + expand = (int *)ckalloc(numWords * sizeof(int)); + objvSpace = (Tcl_Obj **)ckalloc(numWords * sizeof(Tcl_Obj *)); + lineSpace = (int *)ckalloc(numWords * sizeof(int)); } expandRequested = 0; objv = objvSpace; @@ -5303,8 +5310,8 @@ TclEvalEx( if ((numWords > minObjs) || (objectsNeeded > minObjs)) { objv = objvSpace = - ckalloc(objectsNeeded * sizeof(Tcl_Obj *)); - lines = lineSpace = ckalloc(objectsNeeded * sizeof(int)); + (Tcl_Obj **)ckalloc(objectsNeeded * sizeof(Tcl_Obj *)); + lines = lineSpace = (int *)ckalloc(objectsNeeded * sizeof(int)); } objectsUsed = 0; @@ -5602,7 +5609,7 @@ TclArgumentEnter( CmdFrame *cfPtr) { Interp *iPtr = (Interp *) interp; - int new, i; + int isNew, i; Tcl_HashEntry *hPtr; CFWord *cfwPtr; @@ -5618,14 +5625,14 @@ TclArgumentEnter( if (cfPtr->line[i] < 0) { continue; } - hPtr = Tcl_CreateHashEntry(iPtr->lineLAPtr, objv[i], &new); - if (new) { + hPtr = Tcl_CreateHashEntry(iPtr->lineLAPtr, objv[i], &isNew); + if (isNew) { /* * The word is not on the stack yet, remember the current location * and initialize references. */ - cfwPtr = ckalloc(sizeof(CFWord)); + cfwPtr = (CFWord *)ckalloc(sizeof(CFWord)); cfwPtr->framePtr = cfPtr; cfwPtr->word = i; cfwPtr->refCount = 1; @@ -5636,7 +5643,7 @@ TclArgumentEnter( * relevant. Just remember the reference to prevent early removal. */ - cfwPtr = Tcl_GetHashValue(hPtr); + cfwPtr = (CFWord *)Tcl_GetHashValue(hPtr); cfwPtr->refCount++; } } @@ -5679,10 +5686,9 @@ TclArgumentRelease( if (!hPtr) { continue; } - cfwPtr = Tcl_GetHashValue(hPtr); + cfwPtr = (CFWord *)Tcl_GetHashValue(hPtr); - cfwPtr->refCount--; - if (cfwPtr->refCount > 0) { + if (cfwPtr->refCount-- > 1) { continue; } @@ -5732,7 +5738,7 @@ TclArgumentBCEnter( if (!hePtr) { return; } - eclPtr = Tcl_GetHashValue(hePtr); + eclPtr = (ExtCmdLoc *)Tcl_GetHashValue(hePtr); ePtr = &eclPtr->loc[cmd]; /* @@ -5765,10 +5771,10 @@ TclArgumentBCEnter( for (word = 1; word < objc; word++) { if (ePtr->line[word] >= 0) { - int isnew; + int isNew; Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(iPtr->lineLABCPtr, - objv[word], &isnew); - CFWordBC *cfwPtr = ckalloc(sizeof(CFWordBC)); + objv[word], &isNew); + CFWordBC *cfwPtr = (CFWordBC *)ckalloc(sizeof(CFWordBC)); cfwPtr->framePtr = cfPtr; cfwPtr->obj = objv[word]; @@ -5777,7 +5783,7 @@ TclArgumentBCEnter( cfwPtr->nextPtr = lastPtr; lastPtr = cfwPtr; - if (isnew) { + if (isNew) { /* * The word is not on the stack yet, remember the current * location and initialize references. @@ -5792,7 +5798,7 @@ TclArgumentBCEnter( * information in the new structure. */ - cfwPtr->prevPtr = Tcl_GetHashValue(hPtr); + cfwPtr->prevPtr = (CFWordBC *)Tcl_GetHashValue(hPtr); } Tcl_SetHashValue(hPtr, cfwPtr); @@ -5834,7 +5840,7 @@ TclArgumentBCRelease( CFWordBC *nextPtr = cfwPtr->nextPtr; Tcl_HashEntry *hPtr = Tcl_FindHashEntry(iPtr->lineLABCPtr, (char *) cfwPtr->obj); - CFWordBC *xPtr = Tcl_GetHashValue(hPtr); + CFWordBC *xPtr = (CFWordBC *)Tcl_GetHashValue(hPtr); if (xPtr != cfwPtr) { Tcl_Panic("TclArgumentBC Enter/Release Mismatch"); @@ -5900,7 +5906,7 @@ TclArgumentGet( hPtr = Tcl_FindHashEntry(iPtr->lineLAPtr, (char *) obj); if (hPtr) { - CFWord *cfwPtr = Tcl_GetHashValue(hPtr); + CFWord *cfwPtr = (CFWord *)Tcl_GetHashValue(hPtr); *wordPtr = cfwPtr->word; *cfPtrPtr = cfwPtr->framePtr; @@ -5914,7 +5920,7 @@ TclArgumentGet( hPtr = Tcl_FindHashEntry(iPtr->lineLABCPtr, (char *) obj); if (hPtr) { - CFWordBC *cfwPtr = Tcl_GetHashValue(hPtr); + CFWordBC *cfwPtr = (CFWordBC *)Tcl_GetHashValue(hPtr); framePtr = cfwPtr->framePtr; framePtr->data.tebc.pc = (char *) (((ByteCode *) @@ -6100,7 +6106,7 @@ TclNREvalObjEx( /* * Shimmer protection! Always pass an unshared obj. The caller could * incr the refCount of objPtr AFTER calling us! To be completely safe - * we always make a copy. The callback takes care od the refCounts for + * we always make a copy. The callback takes care of the refCounts for * both listPtr and objPtr. * * TODO: Create a test to demo this need, or eliminate it. @@ -6128,7 +6134,7 @@ TclNREvalObjEx( * should be pushed, as needed by alias and ensemble redirections. */ - eoFramePtr = TclStackAlloc(interp, sizeof(CmdFrame)); + eoFramePtr = (CmdFrame *)TclStackAlloc(interp, sizeof(CmdFrame)); eoFramePtr->nline = 0; eoFramePtr->line = NULL; @@ -6237,8 +6243,8 @@ TEOEx_ByteCodeCallback( int result) { Interp *iPtr = (Interp *) interp; - CallFrame *savedVarFramePtr = data[0]; - Tcl_Obj *objPtr = data[1]; + CallFrame *savedVarFramePtr = (CallFrame *)data[0]; + Tcl_Obj *objPtr = (Tcl_Obj *)data[1]; int allowExceptions = PTR2INT(data[2]); if (iPtr->numLevels == 0) { @@ -6283,9 +6289,9 @@ TEOEx_ListCallback( int result) { Interp *iPtr = (Interp *) interp; - Tcl_Obj *listPtr = data[0]; - CmdFrame *eoFramePtr = data[1]; - Tcl_Obj *objPtr = data[2]; + Tcl_Obj *listPtr = (Tcl_Obj *)data[0]; + CmdFrame *eoFramePtr = (CmdFrame *)data[1]; + Tcl_Obj *objPtr = (Tcl_Obj *)data[2]; /* * Remove the cmdFrame @@ -6693,7 +6699,7 @@ TclNRInvoke( NULL); return TCL_ERROR; } - cmdPtr = Tcl_GetHashValue(hPtr); + cmdPtr = (Command *)Tcl_GetHashValue(hPtr); /* * Avoid the exception-handling brain damage when numLevels == 0 @@ -6718,6 +6724,7 @@ NRPostInvoke( int result) { Interp *iPtr = (Interp *)interp; + iPtr->numLevels--; return result; } @@ -6975,7 +6982,6 @@ Tcl_VarEvalVA( * *---------------------------------------------------------------------- */ - /* ARGSUSED */ int Tcl_VarEval( Tcl_Interp *interp, @@ -8246,16 +8252,17 @@ Tcl_NRCreateCommand( } Tcl_Command -TclNRCreateCommandInNs ( +TclNRCreateCommandInNs( Tcl_Interp *interp, const char *cmdName, Tcl_Namespace *nsPtr, Tcl_ObjCmdProc *proc, Tcl_ObjCmdProc *nreProc, ClientData clientData, - Tcl_CmdDeleteProc *deleteProc) { + Tcl_CmdDeleteProc *deleteProc) +{ Command *cmdPtr = (Command *) - TclCreateObjCommandInNs(interp,cmdName,nsPtr,proc,clientData,deleteProc); + TclCreateObjCommandInNs(interp,cmdName,nsPtr,proc,clientData,deleteProc); cmdPtr->nreProc = nreProc; return (Tcl_Command) cmdPtr; @@ -8359,7 +8366,6 @@ TclPushTailcallPoint( TclNRAddCallback(interp, NRCommand, NULL, NULL, NULL, NULL); ((Interp *) interp)->numLevels++; } - /* *---------------------------------------------------------------------- @@ -8395,7 +8401,6 @@ TclSetTailcall( } runPtr->data[1] = listPtr; } - /* *---------------------------------------------------------------------- @@ -8467,7 +8472,6 @@ TclNRTailcallObjCmd( } return TCL_RETURN; } - /* *---------------------------------------------------------------------- @@ -8486,7 +8490,7 @@ TclNRTailcallEval( int result) { Interp *iPtr = (Interp *) interp; - Tcl_Obj *listPtr = data[0], *nsObjPtr; + Tcl_Obj *listPtr = (Tcl_Obj *)data[0], *nsObjPtr; Tcl_Namespace *nsPtr; int objc; Tcl_Obj **objv; @@ -8525,6 +8529,7 @@ TclNRReleaseValues( int result) { int i = 0; + while (i < 4) { if (data[i]) { Tcl_DecrRefCount((Tcl_Obj *) data[i]); @@ -8535,7 +8540,6 @@ TclNRReleaseValues( } return result; } - void Tcl_NRAddCallback( @@ -8690,7 +8694,7 @@ static void DeleteCoroutine( ClientData clientData) { - CoroutineData *corPtr = clientData; + CoroutineData *corPtr = (CoroutineData *)clientData; Tcl_Interp *interp = corPtr->eePtr->interp; NRE_callback *rootPtr = TOP_CB(interp); @@ -8705,7 +8709,7 @@ NRCoroutineCallerCallback( Tcl_Interp *interp, int result) { - CoroutineData *corPtr = data[0]; + CoroutineData *corPtr = (CoroutineData *)data[0]; Command *cmdPtr = corPtr->cmdPtr; /* @@ -8751,7 +8755,7 @@ NRCoroutineExitCallback( Tcl_Interp *interp, int result) { - CoroutineData *corPtr = data[0]; + CoroutineData *corPtr = (CoroutineData *)data[0]; Command *cmdPtr = corPtr->cmdPtr; /* @@ -8814,9 +8818,9 @@ int TclNRCoroutineActivateCallback( ClientData data[], Tcl_Interp *interp, - int result) + int result /*result*/) { - CoroutineData *corPtr = data[0]; + CoroutineData *corPtr = (CoroutineData *)data[0]; int type = PTR2INT(data[1]); int numLevels, unused; int *stackLevel = &unused; @@ -8893,11 +8897,11 @@ static int TclNREvalList( ClientData data[], Tcl_Interp *interp, - int result) + int result /*result*/) { int objc; Tcl_Obj **objv; - Tcl_Obj *listPtr = data[0]; + Tcl_Obj *listPtr = (Tcl_Obj *)data[0]; Tcl_IncrRefCount(listPtr); @@ -8950,7 +8954,7 @@ CoroTypeObjCmd( * future. */ - corPtr = cmdPtr->objClientData; + corPtr = (CoroutineData *)cmdPtr->objClientData; if (!COR_IS_SUSPENDED(corPtr)) { Tcl_SetObjResult(interp, Tcl_NewStringObj("active", -1)); return TCL_OK; @@ -9044,7 +9048,7 @@ TclNRInterpCoroutine( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - CoroutineData *corPtr = clientData; + CoroutineData *corPtr = (CoroutineData *)clientData; if (!COR_IS_SUSPENDED(corPtr)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -9144,7 +9148,7 @@ TclNRCoroutineObjCmd( * struct and create the corresponding command. */ - corPtr = ckalloc(sizeof(CoroutineData)); + corPtr = (CoroutineData *)ckalloc(sizeof(CoroutineData)); cmdPtr = (Command *) TclNRCreateCommandInNs(interp, simpleName, (Tcl_Namespace *)nsPtr, /*objProc*/ NULL, TclNRInterpCoroutine, @@ -9166,7 +9170,7 @@ TclNRCoroutineObjCmd( Tcl_HashSearch hSearch; Tcl_HashEntry *hePtr; - corPtr->lineLABCPtr = ckalloc(sizeof(Tcl_HashTable)); + corPtr->lineLABCPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(corPtr->lineLABCPtr, TCL_ONE_WORD_KEYS); for (hePtr = Tcl_FirstHashEntry(iPtr->lineLABCPtr,&hSearch); diff --git a/generic/tclEvent.c b/generic/tclEvent.c index d8f5119..7abd33c 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -37,7 +37,7 @@ typedef struct BgError { * pending background errors for the interpreter. */ -typedef struct ErrAssocData { +typedef struct { Tcl_Interp *interp; /* Interpreter in which error occurred. */ Tcl_Obj *cmdPrefix; /* First word(s) of the handler command */ BgError *firstBgPtr; /* First in list of all background errors @@ -160,7 +160,7 @@ Tcl_BackgroundException( return; } - errPtr = ckalloc(sizeof(BgError)); + errPtr = (BgError*)ckalloc(sizeof(BgError)); errPtr->errorMsg = Tcl_GetObjResult(interp); Tcl_IncrRefCount(errPtr->errorMsg); errPtr->returnOpts = Tcl_GetReturnOptions(interp, code); @@ -168,7 +168,7 @@ Tcl_BackgroundException( errPtr->nextPtr = NULL; (void) TclGetBgErrorHandler(interp); - assocPtr = Tcl_GetAssocData(interp, "tclBgError", NULL); + assocPtr = (ErrAssocData *)Tcl_GetAssocData(interp, "tclBgError", NULL); if (assocPtr->firstBgPtr == NULL) { assocPtr->firstBgPtr = errPtr; Tcl_DoWhenIdle(HandleBgErrors, assocPtr); @@ -200,7 +200,7 @@ static void HandleBgErrors( ClientData clientData) /* Pointer to ErrAssocData structure. */ { - ErrAssocData *assocPtr = clientData; + ErrAssocData *assocPtr = (ErrAssocData *)clientData; Tcl_Interp *interp = assocPtr->interp; BgError *errPtr; @@ -227,7 +227,7 @@ HandleBgErrors( errPtr = assocPtr->firstBgPtr; Tcl_ListObjGetElements(NULL, copyObj, &prefixObjc, &prefixObjv); - tempObjv = ckalloc((prefixObjc+2) * sizeof(Tcl_Obj *)); + tempObjv = (Tcl_Obj**)ckalloc((prefixObjc+2) * sizeof(Tcl_Obj *)); memcpy(tempObjv, prefixObjv, prefixObjc*sizeof(Tcl_Obj *)); tempObjv[prefixObjc] = errPtr->errorMsg; tempObjv[prefixObjc+1] = errPtr->returnOpts; @@ -515,7 +515,7 @@ TclSetBgErrorHandler( Tcl_Interp *interp, Tcl_Obj *cmdPrefix) { - ErrAssocData *assocPtr = Tcl_GetAssocData(interp, "tclBgError", NULL); + ErrAssocData *assocPtr = (ErrAssocData *)Tcl_GetAssocData(interp, "tclBgError", NULL); if (cmdPrefix == NULL) { Tcl_Panic("TclSetBgErrorHandler: NULL cmdPrefix argument"); @@ -525,7 +525,7 @@ TclSetBgErrorHandler( * First access: initialize. */ - assocPtr = ckalloc(sizeof(ErrAssocData)); + assocPtr = (ErrAssocData*)ckalloc(sizeof(ErrAssocData)); assocPtr->interp = interp; assocPtr->cmdPrefix = NULL; assocPtr->firstBgPtr = NULL; @@ -560,14 +560,14 @@ Tcl_Obj * TclGetBgErrorHandler( Tcl_Interp *interp) { - ErrAssocData *assocPtr = Tcl_GetAssocData(interp, "tclBgError", NULL); + ErrAssocData *assocPtr = (ErrAssocData *)Tcl_GetAssocData(interp, "tclBgError", NULL); if (assocPtr == NULL) { Tcl_Obj *bgerrorObj; TclNewLiteralStringObj(bgerrorObj, "::tcl::Bgerror"); TclSetBgErrorHandler(interp, bgerrorObj); - assocPtr = Tcl_GetAssocData(interp, "tclBgError", NULL); + assocPtr = (ErrAssocData *)Tcl_GetAssocData(interp, "tclBgError", NULL); } return assocPtr->cmdPrefix; } @@ -596,7 +596,7 @@ BgErrorDeleteProc( ClientData clientData, /* Pointer to ErrAssocData structure. */ Tcl_Interp *interp) /* Interpreter being deleted. */ { - ErrAssocData *assocPtr = clientData; + ErrAssocData *assocPtr = (ErrAssocData *)clientData; BgError *errPtr; while (assocPtr->firstBgPtr != NULL) { @@ -634,7 +634,7 @@ Tcl_CreateExitHandler( Tcl_ExitProc *proc, /* Function to invoke. */ ClientData clientData) /* Arbitrary value to pass to proc. */ { - ExitHandler *exitPtr = ckalloc(sizeof(ExitHandler)); + ExitHandler *exitPtr = (ExitHandler*)ckalloc(sizeof(ExitHandler)); exitPtr->proc = proc; exitPtr->clientData = clientData; @@ -667,7 +667,7 @@ TclCreateLateExitHandler( Tcl_ExitProc *proc, /* Function to invoke. */ ClientData clientData) /* Arbitrary value to pass to proc. */ { - ExitHandler *exitPtr = ckalloc(sizeof(ExitHandler)); + ExitHandler *exitPtr = (ExitHandler*)ckalloc(sizeof(ExitHandler)); exitPtr->proc = proc; exitPtr->clientData = clientData; @@ -789,7 +789,7 @@ Tcl_CreateThreadExitHandler( ExitHandler *exitPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - exitPtr = ckalloc(sizeof(ExitHandler)); + exitPtr = (ExitHandler*)ckalloc(sizeof(ExitHandler)); exitPtr->proc = proc; exitPtr->clientData = clientData; exitPtr->nextPtr = tsdPtr->firstExitPtr; @@ -1013,7 +1013,7 @@ Tcl_Exit( * down another. * * Results: - * None. + * The full Tcl version. * * Side effects: * Varied, see the respective initialization routines. @@ -1021,7 +1021,16 @@ Tcl_Exit( *------------------------------------------------------------------------- */ -void +MODULE_SCOPE const TclStubs tclStubs; + +static const struct { + const TclStubs *stubs; + const char version[256]; +} stubInfo = { + &tclStubs, {TCL_PATCH_LEVEL} +} + +const char * TclInitSubsystems(void) { if (inExit != 0) { @@ -1065,6 +1074,7 @@ TclInitSubsystems(void) TclpInitUnlock(); } TclInitNotifier(); + return stubInfo.version; } /* @@ -1290,7 +1300,7 @@ FinalizeThread( * initialized already. */ - tsdPtr = TclThreadDataKeyGet(&dataKey); + tsdPtr = (ThreadSpecificData*)TclThreadDataKeyGet(&dataKey); if (tsdPtr != NULL) { tsdPtr->inExit = 1; @@ -1365,7 +1375,7 @@ TclInExit(void) int TclInThreadExit(void) { - ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); + ThreadSpecificData *tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey); if (tsdPtr == NULL) { return 0; @@ -1390,7 +1400,6 @@ TclInThreadExit(void) *---------------------------------------------------------------------- */ - /* ARGSUSED */ int Tcl_VwaitObjCmd( ClientData clientData, /* Not used. */ @@ -1454,7 +1463,6 @@ Tcl_VwaitObjCmd( return TCL_OK; } - /* ARGSUSED */ static char * VwaitVarProc( ClientData clientData, /* Pointer to integer to set to 1. */ @@ -1463,10 +1471,10 @@ VwaitVarProc( const char *name2, /* Second part of variable name. */ int flags) /* Information about what happened. */ { - int *donePtr = clientData; + int *donePtr = (int *)clientData; *donePtr = 1; - Tcl_UntraceVar(interp, name1, TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + Tcl_UntraceVar2(interp, name1, name2, TCL_TRACE_WRITES|TCL_TRACE_UNSETS, VwaitVarProc, clientData); return NULL; } @@ -1488,7 +1496,6 @@ VwaitVarProc( *---------------------------------------------------------------------- */ - /* ARGSUSED */ int Tcl_UpdateObjCmd( ClientData clientData, /* Not used. */ @@ -1499,7 +1506,7 @@ Tcl_UpdateObjCmd( int optionIndex; int flags = 0; /* Initialized to avoid compiler warning. */ static const char *const updateOptions[] = {"idletasks", NULL}; - enum updateOptions {OPT_IDLETASKS}; + enum updateOptionsEnum {OPT_IDLETASKS}; if (objc == 1) { flags = TCL_ALL_EVENTS|TCL_DONT_WAIT; @@ -1508,7 +1515,7 @@ Tcl_UpdateObjCmd( "option", 0, &optionIndex) != TCL_OK) { return TCL_ERROR; } - switch ((enum updateOptions) optionIndex) { + switch ((enum updateOptionsEnum) optionIndex) { case OPT_IDLETASKS: flags = TCL_WINDOW_EVENTS|TCL_IDLE_EVENTS|TCL_DONT_WAIT; break; @@ -1561,7 +1568,7 @@ static Tcl_ThreadCreateType NewThreadProc( ClientData clientData) { - ThreadClientData *cdPtr = clientData; + ThreadClientData *cdPtr = (ThreadClientData *)clientData; ClientData threadClientData; Tcl_ThreadCreateProc *threadProc; @@ -1604,7 +1611,7 @@ Tcl_CreateThread( * thread. */ { #ifdef TCL_THREADS - ThreadClientData *cdPtr = ckalloc(sizeof(ThreadClientData)); + ThreadClientData *cdPtr = (ThreadClientData *)ckalloc(sizeof(ThreadClientData)); int result; cdPtr->proc = proc; @@ -1615,6 +1622,12 @@ Tcl_CreateThread( } return result; #else + (void)idPtr; + (void)proc; + (void)clientData; + (void)stackSize; + (void)flags; + return TCL_ERROR; #endif /* TCL_THREADS */ } diff --git a/generic/tclInt.h b/generic/tclInt.h index 949672b..491abe6 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3031,7 +3031,7 @@ MODULE_SCOPE void TclInitLimitSupport(Tcl_Interp *interp); MODULE_SCOPE void TclInitNamespaceSubsystem(void); MODULE_SCOPE void TclInitNotifier(void); MODULE_SCOPE void TclInitObjSubsystem(void); -MODULE_SCOPE void TclInitSubsystems(void); +MODULE_SCOPE const char *TclInitSubsystems(void); MODULE_SCOPE int TclInterpReady(Tcl_Interp *interp); MODULE_SCOPE int TclIsBareword(int byte); MODULE_SCOPE Tcl_Obj * TclJoinPath(int elements, Tcl_Obj * const objv[], -- cgit v0.12 From 274e64c4635a378836c4c9c35d7f4010c8849f5d Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 26 Nov 2021 15:54:37 +0000 Subject: Unbreak build --- generic/tclBasic.c | 2 +- generic/tclEvent.c | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 2928f37..fb85241 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -984,7 +984,7 @@ Tcl_CreateInterp(void) * TIP #268: Full patchlevel instead of just major.minor */ - Tcl_PkgProvideEx(interp, "Tcl", TCL_PATCH_LEVEL, &tclStubs); + Tcl_PkgProvideEx(interp, "Tcl", version, &tclStubs); if (TclTommath_Init(interp) != TCL_OK) { Tcl_Panic("%s", Tcl_GetString(Tcl_GetObjResult(interp))); diff --git a/generic/tclEvent.c b/generic/tclEvent.c index 7abd33c..e9d760c 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -1028,7 +1028,7 @@ static const struct { const char version[256]; } stubInfo = { &tclStubs, {TCL_PATCH_LEVEL} -} +}; const char * TclInitSubsystems(void) -- cgit v0.12 From 43b8bf64301dcc8edaad610a7d8a2a21091171be Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 26 Nov 2021 15:56:46 +0000 Subject: Add (missing) win/svnmanifest.in win/tclUuid.h.in (not really used yet) --- win/svnmanifest.in | 1 + win/tclUuid.h.in | 1 + 2 files changed, 2 insertions(+) create mode 100644 win/svnmanifest.in create mode 100644 win/tclUuid.h.in diff --git a/win/svnmanifest.in b/win/svnmanifest.in new file mode 100644 index 0000000..18d2cad --- /dev/null +++ b/win/svnmanifest.in @@ -0,0 +1 @@ +svn-r \ No newline at end of file diff --git a/win/tclUuid.h.in b/win/tclUuid.h.in new file mode 100644 index 0000000..cbb83e4 --- /dev/null +++ b/win/tclUuid.h.in @@ -0,0 +1 @@ +#define TCL_VERSION_UUID \ -- cgit v0.12