From a8e3213d433c2cb886e1abc7b985c7fa362d3a3d Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 18 Mar 2020 21:03:06 +0000 Subject: TIP 568 proposes new public routine Tcl_GetBytesFromObj. --- generic/tcl.decls | 6 ++++++ generic/tclBinary.c | 6 +++--- generic/tclDecls.h | 6 ++++++ generic/tclInt.h | 2 -- generic/tclStubInit.c | 1 + 5 files changed, 16 insertions(+), 5 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index 2575de1..5d6f6be 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2402,6 +2402,12 @@ declare 648 { int length, Tcl_DString *dsPtr) } +# TIP #568 +declare 649 { + unsigned char *Tcl_GetBytesFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, + int *lengthPtr) +} + # ----- BASELINE -- FOR -- 8.7.0 ----- # ############################################################################## diff --git a/generic/tclBinary.c b/generic/tclBinary.c index a050122..0adacfc 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -440,7 +440,7 @@ Tcl_SetByteArrayObj( /* *---------------------------------------------------------------------- * - * TclGetBytesFromObj -- + * Tcl_GetBytesFromObj -- * * Attempt to extract the value from objPtr in the representation * of a byte sequence. On success return the extracted byte sequence. @@ -455,7 +455,7 @@ Tcl_SetByteArrayObj( */ unsigned char * -TclGetBytesFromObj( +Tcl_GetBytesFromObj( Tcl_Interp *interp, /* For error reporting */ Tcl_Obj *objPtr, /* Value to extract from */ int *lengthPtr) /* If non-NULL, filled with length of the @@ -519,7 +519,7 @@ Tcl_GetByteArrayFromObj( { ByteArray *baPtr; const Tcl_ObjIntRep *irPtr; - unsigned char *result = TclGetBytesFromObj(NULL, objPtr, lengthPtr); + unsigned char *result = Tcl_GetBytesFromObj(NULL, objPtr, lengthPtr); if (result) { return result; diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 890114a..69d98d9 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1921,6 +1921,9 @@ EXTERN char * Tcl_UniCharToUtfDString(const int *uniStr, /* 648 */ EXTERN int * Tcl_UtfToUniCharDString(const char *src, int length, Tcl_DString *dsPtr); +/* 649 */ +EXTERN unsigned char * Tcl_GetBytesFromObj(Tcl_Interp *interp, + Tcl_Obj *objPtr, int *lengthPtr); typedef struct { const struct TclPlatStubs *tclPlatStubs; @@ -2605,6 +2608,7 @@ typedef struct TclStubs { int (*tcl_UtfToUniChar) (const char *src, int *chPtr); /* 646 */ char * (*tcl_UniCharToUtfDString) (const int *uniStr, int uniLength, Tcl_DString *dsPtr); /* 647 */ int * (*tcl_UtfToUniCharDString) (const char *src, int length, Tcl_DString *dsPtr); /* 648 */ + unsigned char * (*tcl_GetBytesFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int *lengthPtr); /* 649 */ } TclStubs; extern const TclStubs *tclStubsPtr; @@ -3933,6 +3937,8 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_UniCharToUtfDString) /* 647 */ #define Tcl_UtfToUniCharDString \ (tclStubsPtr->tcl_UtfToUniCharDString) /* 648 */ +#define Tcl_GetBytesFromObj \ + (tclStubsPtr->tcl_GetBytesFromObj) /* 649 */ #endif /* defined(USE_TCL_STUBS) */ diff --git a/generic/tclInt.h b/generic/tclInt.h index be6f26e..56009c2 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3026,8 +3026,6 @@ MODULE_SCOPE int TclNREvalFile(Tcl_Interp *interp, Tcl_Obj *pathPtr, MODULE_SCOPE void TclFSUnloadTempFile(Tcl_LoadHandle loadHandle); MODULE_SCOPE int * TclGetAsyncReadyPtr(void); MODULE_SCOPE Tcl_Obj * TclGetBgErrorHandler(Tcl_Interp *interp); -MODULE_SCOPE unsigned char * TclGetBytesFromObj(Tcl_Interp *interp, - Tcl_Obj *objPtr, int *lengthPtr); MODULE_SCOPE int TclGetChannelFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Channel *chanPtr, int *modePtr, int flags); diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index fbbac6d..6e70938 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -1865,6 +1865,7 @@ const TclStubs tclStubs = { Tcl_UtfToUniChar, /* 646 */ Tcl_UniCharToUtfDString, /* 647 */ Tcl_UtfToUniCharDString, /* 648 */ + Tcl_GetBytesFromObj, /* 649 */ }; /* !END!: Do not edit above this line. */ -- cgit v0.12 From f0082ebb735bf9dbb9edb45a2f3c952a1e7f10c6 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 1 Apr 2020 13:40:27 +0000 Subject: Remove variable "properByteArrayType" from tclTest.c, because it isn't used any more. --- generic/tclTest.c | 6 ------ 1 file changed, 6 deletions(-) diff --git a/generic/tclTest.c b/generic/tclTest.c index 3e1eff3..867cf39 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -47,7 +47,6 @@ DLLEXPORT int Tcltest_SafeInit(Tcl_Interp *interp); static Tcl_DString delString; static Tcl_Interp *delInterp; -static const Tcl_ObjType *properByteArrayType; /* * One of the following structures exists for each asynchronous handler @@ -457,11 +456,6 @@ Tcltest_Init( return TCL_ERROR; } - objPtr = Tcl_NewStringObj("abc", 3); - (void)Tcl_GetByteArrayFromObj(objPtr, &index); - properByteArrayType = objPtr->typePtr; - Tcl_DecrRefCount(objPtr); - /* * Create additional commands and math functions for testing Tcl. */ -- cgit v0.12 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 3c0c59407f61fb9c78ced15b50d084b3670ca7b8 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 19 Oct 2020 11:29:22 +0000 Subject: Fix warning on MSVC: warning C4307: '+': integral constant overflow --- generic/tclInt.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index 2e88348..c536aee 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4851,7 +4851,7 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit; (objPtr) = Tcl_NewWideIntObj(w) #define TclNewIndexObj(objPtr, w) \ - (objPtr) = Tcl_NewWideIntObj((Tcl_WideInt)((w) + 1) - 1) + (objPtr) = (w == TCL_INDEX_NONE) ? Tcl_NewWideIntObj(-1) : Tcl_NewWideIntObj(w) #define TclNewDoubleObj(objPtr, d) \ (objPtr) = Tcl_NewDoubleObj(d) -- cgit v0.12 From 8ac4aee0fc7e4d4020c874ab41fecad788d1c848 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 20 Oct 2020 10:31:34 +0000 Subject: One more attempt to fix the MSVC++ warning for Debug builds --- generic/tclInt.h | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index c536aee..2a0dfa6 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4816,11 +4816,12 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit; #define TclNewIndexObj(objPtr, w) \ do { \ + size_t _w = (w); \ TclIncrObjsAllocated(); \ TclAllocObjStorage(objPtr); \ (objPtr)->refCount = 0; \ (objPtr)->bytes = NULL; \ - (objPtr)->internalRep.wideValue = (Tcl_WideInt)((w) + 1) - 1; \ + (objPtr)->internalRep.wideValue = ((_w) == TCL_INDEX_NONE) ? -1 : (Tcl_WideInt)(_w); \ (objPtr)->typePtr = &tclIntType; \ TCL_DTRACE_OBJ_CREATE(objPtr); \ } while (0) @@ -4851,7 +4852,7 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit; (objPtr) = Tcl_NewWideIntObj(w) #define TclNewIndexObj(objPtr, w) \ - (objPtr) = (w == TCL_INDEX_NONE) ? Tcl_NewWideIntObj(-1) : Tcl_NewWideIntObj(w) + (objPtr) = ((w) == TCL_INDEX_NONE) ? Tcl_NewWideIntObj(-1) : Tcl_NewWideIntObj(w) #define TclNewDoubleObj(objPtr, d) \ (objPtr) = Tcl_NewDoubleObj(d) -- cgit v0.12 -- 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 da7ec341ce01a8f3499ecb556c739ef4dfa9c6e4 Mon Sep 17 00:00:00 2001 From: bch Date: Thu, 26 Nov 2020 00:30:43 +0000 Subject: grammar --- doc/Tcl.n | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/Tcl.n b/doc/Tcl.n index 48a3488..0f46f73 100644 --- a/doc/Tcl.n +++ b/doc/Tcl.n @@ -224,7 +224,7 @@ is reached. The upper bits of the Unicode character will be 0. .RS .PP The range U+00D800\(enU+00DFFF is reserved for surrogates, which -are illegal on its own. Therefore, such sequences will result in +are illegal on their own. Therefore, such sequences will result in the replacement character U+FFFD. Surrogate pairs should be encoded as single \e\fBU\fIhhhhhhhh\fR character. .RE -- cgit v0.12 From e6d3b1557cc89901800f050c7a8fcc5fe20c99ab Mon Sep 17 00:00:00 2001 From: bch Date: Thu, 26 Nov 2020 00:38:21 +0000 Subject: silence warning re: sign-compare --- generic/tclInt.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index 3a759ca..92945ca 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4854,7 +4854,7 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit; (objPtr) = Tcl_NewWideIntObj(w) #define TclNewIndexObj(objPtr, w) \ - (objPtr) = ((w) == TCL_INDEX_NONE) ? Tcl_NewWideIntObj(-1) : Tcl_NewWideIntObj(w) + (objPtr) = (((size_t)w) == TCL_INDEX_NONE) ? Tcl_NewWideIntObj(-1) : Tcl_NewWideIntObj(w) #define TclNewDoubleObj(objPtr, d) \ (objPtr) = Tcl_NewDoubleObj(d) -- cgit v0.12 From 888a59788321731a3060797cac7db475eb6d9028 Mon Sep 17 00:00:00 2001 From: bch Date: Thu, 26 Nov 2020 03:26:05 +0000 Subject: use new TIP 494 64bit/#define in code comment to be consistent w/ code --- generic/tclStringObj.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 9f46b9d..1ac0aeb 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -1162,7 +1162,7 @@ Tcl_AppendToObj( const char *bytes, /* Points to the bytes to append to the * object. */ size_t length) /* The number of bytes to append from "bytes". - * If -1, then append all bytes up to NUL + * If TCL_INDEX_NONE, then append all bytes up to NUL * byte. */ { Tcl_AppendLimitedToObj(objPtr, bytes, length, TCL_INDEX_NONE, NULL); -- cgit v0.12 From 5e62e86d4c48da0f90984d1d69a7ecc8160659d7 Mon Sep 17 00:00:00 2001 From: bch Date: Thu, 26 Nov 2020 03:27:15 +0000 Subject: squelch -Wunused warning --- generic/tclExecute.c | 1 + 1 file changed, 1 insertion(+) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 60f8928..05c1ceb 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -9336,6 +9336,7 @@ EvalStatsCmd( char *litTableStats; LiteralEntry *entryPtr; Tcl_Obj *objPtr; + (void)unused; #define Percent(a,b) ((a) * 100.0 / (b)) -- cgit v0.12 From 4a6876c53700885e4b6c5b9613d59784387c0b82 Mon Sep 17 00:00:00 2001 From: bch Date: Thu, 26 Nov 2020 03:34:47 +0000 Subject: squelch warning by using proper(?) format specifiers; intent needs TBD, so committing to branch for review --- generic/tclExecute.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 05c1ceb..466e89e 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -5356,14 +5356,14 @@ TEBCresume( case INST_STR_FIND: objResultPtr = TclStringFirst(OBJ_UNDER_TOS, OBJ_AT_TOS, 0); - TRACE(("%.20s %.20s => %d\n", + TRACE(("%.20s %.20s => %p\n", O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); case INST_STR_FIND_LAST: objResultPtr = TclStringLast(OBJ_UNDER_TOS, OBJ_AT_TOS, INT_MAX - 1); - TRACE(("%.20s %.20s => %d\n", + TRACE(("%.20s %.20s => %p\n", O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); -- cgit v0.12 From c53412abcf8c4ce4eb65bde9e5c72d5d5611b5ad Mon Sep 17 00:00:00 2001 From: bch Date: Thu, 26 Nov 2020 03:49:18 +0000 Subject: adjust for() loop controls to squelch sign-compare warning, move maxSizeDecade assignment to maintain identical functionality --- generic/tclExecute.c | 21 ++++++++++++--------- 1 file changed, 12 insertions(+), 9 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 466e89e..91bcb91 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -9612,12 +9612,13 @@ EvalStatsCmd( break; } } - for (i = 31; i >= 0; i--) { + for (i = 31; i; i--) { if (statsPtr->srcCount[i] > 0) { - maxSizeDecade = i; - break; + break; /* maxSizeDecade to consume 'i' value + * below... */ } } + maxSizeDecade = i; sum = 0; for (i = minSizeDecade; i <= maxSizeDecade; i++) { decadeHigh = (1 << (i+1)) - 1; @@ -9635,12 +9636,13 @@ EvalStatsCmd( break; } } - for (i = 31; i >= 0; i--) { + for (i = 31; i; i--) { if (statsPtr->byteCodeCount[i] > 0) { - maxSizeDecade = i; - break; + break; /* maxSizeDecade to consume 'i' value + * below... */ } } + maxSizeDecade = i; sum = 0; for (i = minSizeDecade; i <= maxSizeDecade; i++) { decadeHigh = (1 << (i+1)) - 1; @@ -9658,12 +9660,13 @@ EvalStatsCmd( break; } } - for (i = 31; i >= 0; i--) { + for (i = 31; i; i--) { if (statsPtr->lifetimeCount[i] > 0) { - maxSizeDecade = i; - break; + break; /* maxSizeDecade to consume 'i' value + * below... */ } } + maxSizeDecade = i; sum = 0; for (i = minSizeDecade; i <= maxSizeDecade; i++) { decadeHigh = (1 << (i+1)) - 1; -- cgit v0.12 From 42b1424fc5d7d2f09ff77fa4b4a30da726e45627 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 27 Nov 2020 11:28:03 +0000 Subject: Fix compilation error --- generic/tclExecute.c | 1 - 1 file changed, 1 deletion(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 32d6458..910a751 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -9336,7 +9336,6 @@ EvalStatsCmd( char *litTableStats; LiteralEntry *entryPtr; Tcl_Obj *objPtr; - (void)unused; #define Percent(a,b) ((a) * 100.0 / (b)) -- cgit v0.12 From c9c1696a2d8c2c3d094e54b96defd269c0687692 Mon Sep 17 00:00:00 2001 From: bch Date: Sun, 6 Dec 2020 18:39:21 +0000 Subject: allow NULL for indexPtr to say "am not interested in index, just membership in set of possibilities" for Tcl_GetIndexFromObj() --- doc/GetIndex.3 | 8 ++++---- generic/tclIndexObj.c | 31 ++++++++++++++++++------------- 2 files changed, 22 insertions(+), 17 deletions(-) diff --git a/doc/GetIndex.3 b/doc/GetIndex.3 index 8591c56..111ae62 100644 --- a/doc/GetIndex.3 +++ b/doc/GetIndex.3 @@ -56,8 +56,8 @@ OR-ed combination of bits providing additional information for operation. The only bits that are currently defined are \fBTCL_EXACT\fR and \fBTCL_INDEX_TEMP_TABLE\fR. .AP int *indexPtr out -The index of the string in \fItablePtr\fR that matches the value of -\fIobjPtr\fR is returned here. +If not NULL, the index of the string in \fItablePtr\fR that matches +the value of \fIobjPtr\fR is returned here. .BE .SH DESCRIPTION .PP @@ -70,8 +70,8 @@ the strings in \fItablePtr\fR to find a match. A match occurs if \fItablePtr\fR, or if it is a non-empty unique abbreviation for exactly one of the strings in \fItablePtr\fR and the \fBTCL_EXACT\fR flag was not specified; in either case -the index of the matching entry is stored at \fI*indexPtr\fR -and \fBTCL_OK\fR is returned. +\fBTCL_OK\fR is returned. If \fI*indexPtr\fR is not NULL the index +of the matching entry is stored there. .PP If there is no matching entry, \fBTCL_ERROR\fR is returned and an error message is left in \fIinterp\fR's diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index 89582b7..c3092c9 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -166,11 +166,12 @@ GetIndexFromObjList( * Results: * If the value of objPtr is identical to or a unique abbreviation for * one of the entries in tablePtr, then the return value is TCL_OK and - * the index of the matching entry is stored at *indexPtr. If there isn't - * a proper match, then TCL_ERROR is returned and an error message is - * left in interp's result (unless interp is NULL). The msg argument is - * used in the error message; for example, if msg has the value "option" - * then the error message will say something like 'bad option "foo": must + * the index of the matching entry is stored at *indexPtr + * (unless indexPtr is NULL). If there isn't a proper match, then + * TCL_ERROR is returned and an error message is left in interp's + * result (unless interp is NULL). The msg argument is used in the + * error message; for example, if msg has the value "option" then + * the error message will say something like 'bad option "foo": must * be ...' * * Side effects: @@ -212,15 +213,17 @@ Tcl_GetIndexFromObjStruct( */ if (!(flags & TCL_INDEX_TEMP_TABLE)) { - irPtr = TclFetchIntRep(objPtr, &indexType); - if (irPtr) { - indexRep = (IndexRep *)irPtr->twoPtrValue.ptr1; - if (indexRep->tablePtr==tablePtr && indexRep->offset==offset) { - *indexPtr = indexRep->index; - return TCL_OK; + irPtr = TclFetchIntRep (objPtr, &indexType); + if (irPtr) { + indexRep = (IndexRep *) irPtr->twoPtrValue.ptr1; + if (indexRep->tablePtr == tablePtr && indexRep->offset == offset) { + if (indexPtr != NULL) { + *indexPtr = indexRep->index; + } + return TCL_OK; + } } } - } /* * Lookup the value of the object in the table. Accept unique @@ -291,7 +294,9 @@ Tcl_GetIndexFromObjStruct( indexRep->index = index; } - *indexPtr = index; + if(indexPtr != NULL) { + *indexPtr = index; + } return TCL_OK; error: -- cgit v0.12 From 902547c2b25bc92a576879d666aaf79c6e635aab Mon Sep 17 00:00:00 2001 From: bch Date: Sun, 6 Dec 2020 20:57:32 +0000 Subject: comment grammar --- generic/tcl.decls | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index dc57324..eacfb28 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -24,8 +24,8 @@ hooks {tclPlat tclInt tclIntPlat} scspec EXTERN # Declare each of the functions in the public Tcl interface. Note that -# the an index should never be reused for a different function in order -# to preserve backwards compatibility. +# in order to preserve backwards compatibility an index should +# never be reused for a different function declare 0 { int Tcl_PkgProvideEx(Tcl_Interp *interp, const char *name, -- cgit v0.12 From 933584b14430d2c9df09702eb344ff261bd40776 Mon Sep 17 00:00:00 2001 From: bch Date: Sun, 6 Dec 2020 20:58:21 +0000 Subject: Period. --- generic/tcl.decls | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index eacfb28..4362c4c 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -25,7 +25,7 @@ scspec EXTERN # Declare each of the functions in the public Tcl interface. Note that # in order to preserve backwards compatibility an index should -# never be reused for a different function +# never be reused for a different function. declare 0 { int Tcl_PkgProvideEx(Tcl_Interp *interp, const char *name, -- cgit v0.12 From 56938ac247374b9d6770ed3eb41cff5f96fa52e1 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 18 Jan 2021 15:59:11 +0000 Subject: Make Tcl_GetBytesFromObj work with size_t length parameter (just as Tcl_GetByteArrayFromObj in TIP #481. Add documentation for the new function --- doc/ByteArrObj.3 | 15 +++++++++++--- generic/tcl.decls | 6 +++++- generic/tclBinary.c | 55 +++++++++++++++++++++++++++++++++++++++++++-------- generic/tclDecls.h | 20 +++++++++++++------ generic/tclIO.c | 2 +- generic/tclStubInit.c | 4 ++-- generic/tclZipfs.c | 2 +- generic/tclZlib.c | 26 ++++++++++++------------ 8 files changed, 95 insertions(+), 35 deletions(-) diff --git a/doc/ByteArrObj.3 b/doc/ByteArrObj.3 index ff0b4e1..ecc51b0 100644 --- a/doc/ByteArrObj.3 +++ b/doc/ByteArrObj.3 @@ -8,7 +8,7 @@ .so man.macros .BS .SH NAME -Tcl_NewByteArrayObj, Tcl_SetByteArrayObj, Tcl_GetByteArrayFromObj, Tcl_SetByteArrayLength \- manipulate Tcl values as a arrays of bytes +Tcl_NewByteArrayObj, Tcl_SetByteArrayObj, Tcl_GetByteArrayFromObj, Tcl_GetBytesFromObj, Tcl_SetByteArrayLength \- manipulate Tcl values as a arrays of bytes .SH SYNOPSIS .nf \fB#include \fR @@ -23,9 +23,14 @@ unsigned char * \fBTcl_GetByteArrayFromObj\fR(\fIobjPtr, lengthPtr\fR) .sp unsigned char * +\fBTcl_GetBytesFromObj\fR(\fIinterp, objPtr, lengthPtr\fR) +.sp +unsigned char * \fBTcl_SetByteArrayLength\fR(\fIobjPtr, length\fR) .SH ARGUMENTS .AS "const unsigned char" *lengthPtr in/out +.AP Tcl_Interp *interp in +Interpreter to use for error reporting. .AP "const unsigned char" *bytes in The array of bytes used to initialize or set a byte-array value. May be NULL even if \fIlength\fR is non-zero. @@ -33,11 +38,11 @@ even if \fIlength\fR is non-zero. The length of the array of bytes. It must be >= 0. .AP Tcl_Obj *objPtr in/out For \fBTcl_SetByteArrayObj\fR, this points to the value to be converted to -byte-array type. For \fBTcl_GetByteArrayFromObj\fR and +byte-array type. For \fBTcl_GetByteArrayFromObj\fR, \fBTcl_GetBytesFromObj\fR and \fBTcl_SetByteArrayLength\fR, this points to the value from which to get the byte-array value; if \fIobjPtr\fR does not already point to a byte-array value, it will be converted to one. -.AP int *lengthPtr out +.AP size_t | int *lengthPtr out If non-NULL, filled with the length of the array of bytes in the value. .BE @@ -75,6 +80,10 @@ the value and should not be freed. The contents of the array may be modified by the caller only if the value is not shared and the caller invalidates the string representation. .PP +\fBTcl_GetBytesFromObj\fR does almost the same as \fBTcl_GetByteArrayFromObj\fR, +the difference is that this function can error if the object contains +characters > 255. If \fBinterp\fR is not NULL, an error-message will be left there. +.PP \fBTcl_SetByteArrayLength\fR converts the Tcl value to byte-array type and changes the length of the value's internal representation as an array of bytes. If \fIlength\fR is greater than the space currently diff --git a/generic/tcl.decls b/generic/tcl.decls index 0324af8..b0de918 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2404,9 +2404,13 @@ declare 648 { # TIP #568 declare 649 { - unsigned char *Tcl_GetBytesFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, + unsigned char *TclGetBytesFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int *lengthPtr) } +declare 650 { + unsigned char *Tcl_GetBytesFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, + size_t *lengthPtr) +} # TIP #481 declare 651 { diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 3924549..7fbfbaf 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -440,7 +440,7 @@ Tcl_SetByteArrayObj( /* *---------------------------------------------------------------------- * - * Tcl_GetBytesFromObj -- + * Tcl_GetBytesFromObj/TclGetBytesFromObj -- * * Attempt to extract the value from objPtr in the representation * of a byte sequence. On success return the extracted byte sequence. @@ -455,7 +455,7 @@ Tcl_SetByteArrayObj( */ unsigned char * -Tcl_GetBytesFromObj( +TclGetBytesFromObj( Tcl_Interp *interp, /* For error reporting */ Tcl_Obj *objPtr, /* Value to extract from */ int *lengthPtr) /* If non-NULL, filled with length of the @@ -492,6 +492,45 @@ Tcl_GetBytesFromObj( } return baPtr->bytes; } +#undef Tcl_GetBytesFromObj +unsigned char * +Tcl_GetBytesFromObj( + Tcl_Interp *interp, /* For error reporting */ + Tcl_Obj *objPtr, /* Value to extract from */ + size_t *lengthPtr) /* If non-NULL, filled with length of the + * array of bytes in the ByteArray object. */ +{ + ByteArray *baPtr; + const Tcl_ObjIntRep *irPtr = TclFetchIntRep(objPtr, &properByteArrayType); + + if (irPtr == NULL) { + SetByteArrayFromAny(NULL, objPtr); + irPtr = TclFetchIntRep(objPtr, &properByteArrayType); + if (irPtr == NULL) { + if (interp) { + const char *nonbyte; + int ucs4; + + irPtr = TclFetchIntRep(objPtr, &tclByteArrayType); + baPtr = GET_BYTEARRAY(irPtr); + nonbyte = Tcl_UtfAtIndex(Tcl_GetString(objPtr), baPtr->bad); + TclUtfToUCS4(nonbyte, &ucs4); + + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "expected byte sequence but character %d " + "was '%1s' (U+%06X)", baPtr->bad, nonbyte, ucs4)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "BYTES", NULL); + } + return NULL; + } + } + baPtr = GET_BYTEARRAY(irPtr); + + if (lengthPtr != NULL) { + *lengthPtr = baPtr->used; + } + return baPtr->bytes; +} /* *---------------------------------------------------------------------- @@ -520,7 +559,7 @@ Tcl_GetByteArrayFromObj( { ByteArray *baPtr; const Tcl_ObjIntRep *irPtr; - unsigned char *result = Tcl_GetBytesFromObj(NULL, objPtr, lengthPtr); + unsigned char *result = TclGetBytesFromObj(NULL, objPtr, lengthPtr); if (result) { return result; @@ -545,7 +584,7 @@ TclGetByteArrayFromObj( { ByteArray *baPtr; const Tcl_ObjIntRep *irPtr; - unsigned char *result = Tcl_GetBytesFromObj(NULL, objPtr, (int *)NULL); + unsigned char *result = TclGetBytesFromObj(NULL, objPtr, (int *)NULL); if (result) { return result; @@ -2656,7 +2695,7 @@ BinaryDecodeHex( } TclNewObj(resultObj); - data = Tcl_GetBytesFromObj(NULL, objv[objc - 1], &count); + data = TclGetBytesFromObj(NULL, objv[objc - 1], &count); if (data == NULL) { pure = 0; data = (unsigned char *) TclGetStringFromObj(objv[objc - 1], &count); @@ -2788,7 +2827,7 @@ BinaryEncode64( } break; case OPT_WRAPCHAR: - wrapchar = (const char *)Tcl_GetBytesFromObj(NULL, + wrapchar = (const char *)TclGetBytesFromObj(NULL, objv[i + 1], &wrapcharlen); if (wrapchar == NULL) { purewrap = 0; @@ -3051,7 +3090,7 @@ BinaryDecodeUu( } TclNewObj(resultObj); - data = Tcl_GetBytesFromObj(NULL, objv[objc - 1], &count); + data = TclGetBytesFromObj(NULL, objv[objc - 1], &count); if (data == NULL) { pure = 0; data = (unsigned char *) TclGetStringFromObj(objv[objc - 1], &count); @@ -3225,7 +3264,7 @@ BinaryDecode64( } TclNewObj(resultObj); - data = Tcl_GetBytesFromObj(NULL, objv[objc - 1], &count); + data = TclGetBytesFromObj(NULL, objv[objc - 1], &count); if (data == NULL) { pure = 0; data = (unsigned char *) TclGetStringFromObj(objv[objc - 1], &count); diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 4e7f3f8b..9279e2d 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1921,9 +1921,11 @@ EXTERN char * Tcl_UniCharToUtfDString(const int *uniStr, EXTERN int * Tcl_UtfToUniCharDString(const char *src, int length, Tcl_DString *dsPtr); /* 649 */ -EXTERN unsigned char * Tcl_GetBytesFromObj(Tcl_Interp *interp, +EXTERN unsigned char * TclGetBytesFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int *lengthPtr); -/* Slot 650 is reserved */ +/* 650 */ +EXTERN unsigned char * Tcl_GetBytesFromObj(Tcl_Interp *interp, + Tcl_Obj *objPtr, size_t *lengthPtr); /* 651 */ EXTERN char * TclGetStringFromObj(Tcl_Obj *objPtr, size_t *lengthPtr); @@ -2617,8 +2619,8 @@ typedef struct TclStubs { int (*tcl_UtfToUniChar) (const char *src, int *chPtr); /* 646 */ char * (*tcl_UniCharToUtfDString) (const int *uniStr, int uniLength, Tcl_DString *dsPtr); /* 647 */ int * (*tcl_UtfToUniCharDString) (const char *src, int length, Tcl_DString *dsPtr); /* 648 */ - unsigned char * (*tcl_GetBytesFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int *lengthPtr); /* 649 */ - void (*reserved650)(void); + unsigned char * (*tclGetBytesFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int *lengthPtr); /* 649 */ + unsigned char * (*tcl_GetBytesFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, size_t *lengthPtr); /* 650 */ char * (*tclGetStringFromObj) (Tcl_Obj *objPtr, size_t *lengthPtr); /* 651 */ Tcl_UniChar * (*tclGetUnicodeFromObj) (Tcl_Obj *objPtr, size_t *lengthPtr); /* 652 */ unsigned char * (*tclGetByteArrayFromObj) (Tcl_Obj *objPtr, size_t *lengthPtr); /* 653 */ @@ -3950,9 +3952,10 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_UniCharToUtfDString) /* 647 */ #define Tcl_UtfToUniCharDString \ (tclStubsPtr->tcl_UtfToUniCharDString) /* 648 */ +#define TclGetBytesFromObj \ + (tclStubsPtr->tclGetBytesFromObj) /* 649 */ #define Tcl_GetBytesFromObj \ - (tclStubsPtr->tcl_GetBytesFromObj) /* 649 */ -/* Slot 650 is reserved */ + (tclStubsPtr->tcl_GetBytesFromObj) /* 650 */ #define TclGetStringFromObj \ (tclStubsPtr->tclGetStringFromObj) /* 651 */ #define TclGetUnicodeFromObj \ @@ -4142,12 +4145,15 @@ extern const TclStubs *tclStubsPtr; #endif #undef Tcl_GetStringFromObj +#undef Tcl_GetBytesFromObj #undef Tcl_GetUnicodeFromObj #undef Tcl_GetByteArrayFromObj #undef Tcl_GetUnicode #if defined(USE_TCL_STUBS) #define Tcl_GetStringFromObj(objPtr, sizePtr) \ (sizeof(*sizePtr) <= sizeof(int) ? tclStubsPtr->tcl_GetStringFromObj(objPtr, (int *)sizePtr) : tclStubsPtr->tclGetStringFromObj(objPtr, (size_t *)sizePtr)) +#define Tcl_GetBytesFromObj(interp, objPtr, sizePtr) \ + (sizeof(*sizePtr) <= sizeof(int) ? tclStubsPtr->tclGetBytesFromObj(interp, objPtr, (int *)sizePtr) : tclStubsPtr->tcl_GetBytesFromObj(interp, objPtr, (size_t *)sizePtr)) #define Tcl_GetByteArrayFromObj(objPtr, sizePtr) \ (sizeof(*sizePtr) <= sizeof(int) ? tclStubsPtr->tcl_GetByteArrayFromObj(objPtr, (int *)sizePtr) : tclStubsPtr->tclGetByteArrayFromObj(objPtr, (size_t *)sizePtr)) #define Tcl_GetUnicodeFromObj(objPtr, sizePtr) \ @@ -4157,6 +4163,8 @@ extern const TclStubs *tclStubsPtr; #else #define Tcl_GetStringFromObj(objPtr, sizePtr) \ (sizeof(*sizePtr) <= sizeof(int) ? (Tcl_GetStringFromObj)(objPtr, (int *)sizePtr) : (TclGetStringFromObj)(objPtr, (size_t *)sizePtr)) +#define Tcl_GetBytesFromObj(interp, objPtr, sizePtr) \ + (sizeof(*sizePtr) <= sizeof(int) ? (TclGetBytesFromObj)(interp, objPtr, (int *)sizePtr) : (Tcl_GetBytesFromObj)(interp, objPtr, (size_t *)sizePtr)) #define Tcl_GetByteArrayFromObj(objPtr, sizePtr) \ (sizeof(*sizePtr) <= sizeof(int) ? (Tcl_GetByteArrayFromObj)(objPtr, (int *)sizePtr) : TclGetByteArrayFromObj(objPtr, (size_t *)sizePtr)) #define Tcl_GetUnicodeFromObj(objPtr, sizePtr) \ diff --git a/generic/tclIO.c b/generic/tclIO.c index 2232d8d..9cace8c 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -5863,7 +5863,7 @@ DoReadChars( && (statePtr->inEofChar == '\0'); if (appendFlag) { - if (binaryMode && (NULL == Tcl_GetBytesFromObj(NULL, objPtr, NULL))) { + if (binaryMode && (NULL == TclGetBytesFromObj(NULL, objPtr, NULL))) { binaryMode = 0; } } else { diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index e29330b..f5d16b1 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -1894,8 +1894,8 @@ const TclStubs tclStubs = { Tcl_UtfToUniChar, /* 646 */ Tcl_UniCharToUtfDString, /* 647 */ Tcl_UtfToUniCharDString, /* 648 */ - Tcl_GetBytesFromObj, /* 649 */ - 0, /* 650 */ + TclGetBytesFromObj, /* 649 */ + Tcl_GetBytesFromObj, /* 650 */ TclGetStringFromObj, /* 651 */ TclGetUnicodeFromObj, /* 652 */ TclGetByteArrayFromObj, /* 653 */ diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c index a5a40b4..fc7be6f 100644 --- a/generic/tclZipfs.c +++ b/generic/tclZipfs.c @@ -1896,7 +1896,7 @@ ZipFSMountBufferObjCmd( return TCL_OK; } - data = Tcl_GetBytesFromObj(interp, objv[2], &length); + data = TclGetBytesFromObj(interp, objv[2], &length); if (data == NULL) { return TCL_ERROR; } diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 6960294..d257ea1 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -1153,8 +1153,8 @@ Tcl_ZlibStreamSetCompressionDictionary( { ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zshandle; - if (compressionDictionaryObj && (NULL == Tcl_GetBytesFromObj(NULL, - compressionDictionaryObj, NULL))) { + if (compressionDictionaryObj && (NULL == TclGetBytesFromObj(NULL, + compressionDictionaryObj, (int *)NULL))) { /* Missing or invalid compression dictionary */ compressionDictionaryObj = NULL; } @@ -1208,7 +1208,7 @@ Tcl_ZlibStreamPut( return TCL_ERROR; } - bytes = Tcl_GetBytesFromObj(zshPtr->interp, data, &size); + bytes = TclGetBytesFromObj(zshPtr->interp, data, &size); if (bytes == NULL) { return TCL_ERROR; } @@ -1338,7 +1338,7 @@ Tcl_ZlibStreamGet( return TCL_OK; } - if (NULL == Tcl_GetBytesFromObj(zshPtr->interp, data, &existing)) { + if (NULL == TclGetBytesFromObj(zshPtr->interp, data, &existing)) { return TCL_ERROR; } @@ -1592,7 +1592,7 @@ Tcl_ZlibDeflate( * to the deflate command. */ - inData = Tcl_GetBytesFromObj(interp, data, &inLen); + inData = TclGetBytesFromObj(interp, data, &inLen); if (inData == NULL) { return TCL_ERROR; } @@ -1741,7 +1741,7 @@ Tcl_ZlibInflate( return TCL_ERROR; } - inData = Tcl_GetBytesFromObj(interp, data, &inLen); + inData = TclGetBytesFromObj(interp, data, &inLen); if (inData == NULL) { return TCL_ERROR; } @@ -1978,7 +1978,7 @@ ZlibCmd( Tcl_WrongNumArgs(interp, 2, objv, "data ?startValue?"); return TCL_ERROR; } - data = Tcl_GetBytesFromObj(interp, objv[2], &dlen); + data = TclGetBytesFromObj(interp, objv[2], &dlen); if (data == NULL) { return TCL_ERROR; } @@ -1998,7 +1998,7 @@ ZlibCmd( Tcl_WrongNumArgs(interp, 2, objv, "data ?startValue?"); return TCL_ERROR; } - data = Tcl_GetBytesFromObj(interp, objv[2], &dlen); + data = TclGetBytesFromObj(interp, objv[2], &dlen); if (data == NULL) { return TCL_ERROR; } @@ -2342,7 +2342,7 @@ ZlibStreamSubcmd( } if (compDictObj) { - if (NULL == Tcl_GetBytesFromObj(interp, compDictObj, NULL)) { + if (NULL == TclGetBytesFromObj(interp, compDictObj, NULL)) { return TCL_ERROR; } } @@ -2524,7 +2524,7 @@ ZlibPushSubcmd( } } - if (compDictObj && (NULL == Tcl_GetBytesFromObj(interp, compDictObj, NULL))) { + if (compDictObj && (NULL == TclGetBytesFromObj(interp, compDictObj, NULL))) { return TCL_ERROR; } @@ -2773,7 +2773,7 @@ ZlibStreamAddCmd( if (compDictObj != NULL) { int len; - if (NULL == Tcl_GetBytesFromObj(interp, compDictObj, &len)) { + if (NULL == TclGetBytesFromObj(interp, compDictObj, &len)) { return TCL_ERROR; } @@ -2880,7 +2880,7 @@ ZlibStreamPutCmd( if (compDictObj != NULL) { int len; - if (NULL == Tcl_GetBytesFromObj(interp, compDictObj, &len)) { + if (NULL == TclGetBytesFromObj(interp, compDictObj, &len)) { return TCL_ERROR; } if (len == 0) { @@ -3318,7 +3318,7 @@ ZlibTransformSetOption( /* not used */ TclNewStringObj(compDictObj, value, strlen(value)); Tcl_IncrRefCount(compDictObj); - if (NULL == Tcl_GetBytesFromObj(interp, compDictObj, NULL)) { + if (NULL == TclGetBytesFromObj(interp, compDictObj, NULL)) { Tcl_DecrRefCount(compDictObj); return TCL_ERROR; } -- cgit v0.12 From b373f35cc26b885600e10f64cb5f85d64f64dff2 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 26 Jan 2021 11:13:11 +0000 Subject: Make Tcl_GetBytesFromObj usable without TCL_NO_DEPRECATED too. Fix "testbytestring" test command, prevent stack smash (seen in github action build) --- generic/tclDecls.h | 10 +++++----- generic/tclTest.c | 2 +- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/generic/tclDecls.h b/generic/tclDecls.h index aee81e7..7232eac 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -4150,29 +4150,29 @@ extern const TclStubs *tclStubsPtr; Tcl_GetStringFromObj(objPtr, (int *)NULL) #define Tcl_GetUnicode(objPtr) \ Tcl_GetUnicodeFromObj(objPtr, (int *)NULL) +#undef Tcl_GetBytesFromObj #ifdef TCL_NO_DEPRECATED #undef Tcl_GetStringFromObj -#undef Tcl_GetBytesFromObj #undef Tcl_GetUnicodeFromObj #undef Tcl_GetByteArrayFromObj #endif #if defined(USE_TCL_STUBS) +#define Tcl_GetBytesFromObj(interp, objPtr, sizePtr) \ + (sizeof(*sizePtr) <= sizeof(int) ? tclStubsPtr->tclGetBytesFromObj(interp, objPtr, (int *)sizePtr) : tclStubsPtr->tcl_GetBytesFromObj(interp, objPtr, (size_t *)sizePtr)) #ifdef TCL_NO_DEPRECATED #define Tcl_GetStringFromObj(objPtr, sizePtr) \ (sizeof(*sizePtr) <= sizeof(int) ? tclStubsPtr->tcl_GetStringFromObj(objPtr, (int *)sizePtr) : tclStubsPtr->tclGetStringFromObj(objPtr, (size_t *)sizePtr)) -#define Tcl_GetBytesFromObj(interp, objPtr, sizePtr) \ - (sizeof(*sizePtr) <= sizeof(int) ? tclStubsPtr->tclGetBytesFromObj(interp, objPtr, (int *)sizePtr) : tclStubsPtr->tcl_GetBytesFromObj(interp, objPtr, (size_t *)sizePtr)) #define Tcl_GetByteArrayFromObj(objPtr, sizePtr) \ (sizeof(*sizePtr) <= sizeof(int) ? tclStubsPtr->tcl_GetByteArrayFromObj(objPtr, (int *)sizePtr) : tclStubsPtr->tclGetByteArrayFromObj(objPtr, (size_t *)sizePtr)) #define Tcl_GetUnicodeFromObj(objPtr, sizePtr) \ (sizeof(*sizePtr) <= sizeof(int) ? tclStubsPtr->tcl_GetUnicodeFromObj(objPtr, (int *)sizePtr) : tclStubsPtr->tclGetUnicodeFromObj(objPtr, (size_t *)sizePtr)) #endif #else +#define Tcl_GetBytesFromObj(interp, objPtr, sizePtr) \ + (sizeof(*sizePtr) <= sizeof(int) ? (TclGetBytesFromObj)(interp, objPtr, (int *)sizePtr) : (Tcl_GetBytesFromObj)(interp, objPtr, (size_t *)sizePtr)) #ifdef TCL_NO_DEPRECATED #define Tcl_GetStringFromObj(objPtr, sizePtr) \ (sizeof(*sizePtr) <= sizeof(int) ? (Tcl_GetStringFromObj)(objPtr, (int *)sizePtr) : (TclGetStringFromObj)(objPtr, (size_t *)sizePtr)) -#define Tcl_GetBytesFromObj(interp, objPtr, sizePtr) \ - (sizeof(*sizePtr) <= sizeof(int) ? (TclGetBytesFromObj)(interp, objPtr, (int *)sizePtr) : (Tcl_GetBytesFromObj)(interp, objPtr, (size_t *)sizePtr)) #define Tcl_GetByteArrayFromObj(objPtr, sizePtr) \ (sizeof(*sizePtr) <= sizeof(int) ? (Tcl_GetByteArrayFromObj)(objPtr, (int *)sizePtr) : TclGetByteArrayFromObj(objPtr, (size_t *)sizePtr)) #define Tcl_GetUnicodeFromObj(objPtr, sizePtr) \ diff --git a/generic/tclTest.c b/generic/tclTest.c index f016995..3c7bdb8 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -5069,7 +5069,7 @@ TestbytestringObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ { - int n = 0; + size_t n = 0; const char *p; if (objc != 2) { -- 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 fa1e5ce70ab2eb900b31b03f0fddf2cc8c5243e8 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 23 Mar 2021 20:35:29 +0000 Subject: New Tcl_ExternalToUtfDStringEx/Tcl_UtfToExternalDStringEx functions. Not used yet --- generic/tcl.decls | 10 ++++++++++ generic/tclDecls.h | 14 ++++++++++++++ generic/tclEncoding.c | 53 ++++++++++++++++++++++++++++++++++++++++----------- generic/tclStubInit.c | 2 ++ 4 files changed, 68 insertions(+), 11 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index c39847b..c2a4abd 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2424,6 +2424,16 @@ declare 656 { const char *Tcl_UtfPrev(const char *src, const char *start) } +declare 657 { + int Tcl_ExternalToUtfDStringEx(Tcl_Encoding encoding, + const char *src, int srcLen, Tcl_DString *dsPtr, int flags) +} +declare 658 { + int Tcl_UtfToExternalDStringEx(Tcl_Encoding encoding, + const char *src, int srcLen, Tcl_DString *dsPtr, int flags) +} + + # ----- BASELINE -- FOR -- 8.7.0 ----- # ############################################################################## diff --git a/generic/tclDecls.h b/generic/tclDecls.h index e509c2b..6ba39d5 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1937,6 +1937,14 @@ EXTERN int Tcl_UtfCharComplete(const char *src, int length); EXTERN const char * Tcl_UtfNext(const char *src); /* 656 */ EXTERN const char * Tcl_UtfPrev(const char *src, const char *start); +/* 657 */ +EXTERN int Tcl_ExternalToUtfDStringEx(Tcl_Encoding encoding, + const char *src, int srcLen, + Tcl_DString *dsPtr, int flags); +/* 658 */ +EXTERN int Tcl_UtfToExternalDStringEx(Tcl_Encoding encoding, + const char *src, int srcLen, + Tcl_DString *dsPtr, int flags); typedef struct { const struct TclPlatStubs *tclPlatStubs; @@ -2629,6 +2637,8 @@ typedef struct TclStubs { int (*tcl_UtfCharComplete) (const char *src, int length); /* 654 */ const char * (*tcl_UtfNext) (const char *src); /* 655 */ const char * (*tcl_UtfPrev) (const char *src, const char *start); /* 656 */ + int (*tcl_ExternalToUtfDStringEx) (Tcl_Encoding encoding, const char *src, int srcLen, Tcl_DString *dsPtr, int flags); /* 657 */ + int (*tcl_UtfToExternalDStringEx) (Tcl_Encoding encoding, const char *src, int srcLen, Tcl_DString *dsPtr, int flags); /* 658 */ } TclStubs; extern const TclStubs *tclStubsPtr; @@ -3971,6 +3981,10 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_UtfNext) /* 655 */ #define Tcl_UtfPrev \ (tclStubsPtr->tcl_UtfPrev) /* 656 */ +#define Tcl_ExternalToUtfDStringEx \ + (tclStubsPtr->tcl_ExternalToUtfDStringEx) /* 657 */ +#define Tcl_UtfToExternalDStringEx \ + (tclStubsPtr->tcl_UtfToExternalDStringEx) /* 658 */ #endif /* defined(USE_TCL_STUBS) */ diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 4eabbda..fd5c52b 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -1089,7 +1089,7 @@ Tcl_CreateEncoding( /* *------------------------------------------------------------------------- * - * Tcl_ExternalToUtfDString -- + * Tcl_ExternalToUtfDString/Tcl_ExternalToUtfDStringEx -- * * Convert a source buffer from the specified encoding into UTF-8. If any * of the bytes in the source buffer are invalid or cannot be represented @@ -1099,7 +1099,7 @@ Tcl_CreateEncoding( * Results: * The converted bytes are stored in the DString, which is then NULL * terminated. The return value is a pointer to the value stored in the - * DString. + * DString resp. an error code. * * Side effects: * None. @@ -1117,10 +1117,26 @@ Tcl_ExternalToUtfDString( Tcl_DString *dstPtr) /* Uninitialized or free DString in which the * converted string is stored. */ { + Tcl_ExternalToUtfDStringEx(encoding, src, srcLen, dstPtr, 0); + return Tcl_DStringValue(dstPtr); +} + + +int +Tcl_ExternalToUtfDStringEx( + Tcl_Encoding encoding, /* The encoding for the source string, or NULL + * for the default system encoding. */ + const char *src, /* Source string in specified encoding. */ + int srcLen, /* Source string length in bytes, or < 0 for + * encoding-specific string length. */ + Tcl_DString *dstPtr, /* Uninitialized or free DString in which the + * converted string is stored. */ + int flags) /* Conversion control flags. */ +{ char *dst; Tcl_EncodingState state; const Encoding *encodingPtr; - int flags, dstLen, result, soFar, srcRead, dstWrote, dstChars; + int dstLen, result, soFar, srcRead, dstWrote, dstChars; Tcl_DStringInit(dstPtr); dst = Tcl_DStringValue(dstPtr); @@ -1137,7 +1153,7 @@ Tcl_ExternalToUtfDString( srcLen = encodingPtr->lengthProc(src); } - flags = TCL_ENCODING_START | TCL_ENCODING_END; + flags |= TCL_ENCODING_START | TCL_ENCODING_END; while (1) { result = encodingPtr->toUtfProc(encodingPtr->clientData, src, srcLen, @@ -1146,7 +1162,7 @@ Tcl_ExternalToUtfDString( if (result != TCL_CONVERT_NOSPACE) { Tcl_DStringSetLength(dstPtr, soFar); - return Tcl_DStringValue(dstPtr); + return result; } flags &= ~TCL_ENCODING_START; @@ -1279,7 +1295,7 @@ Tcl_ExternalToUtf( /* *------------------------------------------------------------------------- * - * Tcl_UtfToExternalDString -- + * Tcl_UtfToExternalDString/Tcl_UtfToExternalDStringEx -- * * Convert a source buffer from UTF-8 to the specified encoding. If any * of the bytes in the source buffer are invalid or cannot be represented @@ -1288,7 +1304,7 @@ Tcl_ExternalToUtf( * Results: * The converted bytes are stored in the DString, which is then NULL * terminated in an encoding-specific manner. The return value is a - * pointer to the value stored in the DString. + * pointer to the value stored in the DString resp. an error code. * * Side effects: * None. @@ -1306,10 +1322,25 @@ Tcl_UtfToExternalDString( Tcl_DString *dstPtr) /* Uninitialized or free DString in which the * converted string is stored. */ { + Tcl_UtfToExternalDStringEx(encoding, src, srcLen, dstPtr, 0); + return Tcl_DStringValue(dstPtr); +} + +int +Tcl_UtfToExternalDStringEx( + Tcl_Encoding encoding, /* The encoding for the converted string, or + * NULL for the default system encoding. */ + const char *src, /* Source string in UTF-8. */ + int srcLen, /* Source string length in bytes, or < 0 for + * strlen(). */ + Tcl_DString *dstPtr, /* Uninitialized or free DString in which the + * converted string is stored. */ + int flags) /* Conversion control flags. */ +{ char *dst; Tcl_EncodingState state; const Encoding *encodingPtr; - int flags, dstLen, result, soFar, srcRead, dstWrote, dstChars; + int dstLen, result, soFar, srcRead, dstWrote, dstChars; Tcl_DStringInit(dstPtr); dst = Tcl_DStringValue(dstPtr); @@ -1325,10 +1356,10 @@ Tcl_UtfToExternalDString( } else if (srcLen < 0) { srcLen = strlen(src); } - flags = TCL_ENCODING_START | TCL_ENCODING_END; + flags |= TCL_ENCODING_START | TCL_ENCODING_END | TCL_ENCODING_EXTERNAL; while (1) { result = encodingPtr->fromUtfProc(encodingPtr->clientData, src, - srcLen, flags | TCL_ENCODING_EXTERNAL, &state, dst, dstLen, + srcLen, flags, &state, dst, dstLen, &srcRead, &dstWrote, &dstChars); soFar = dst + dstWrote - Tcl_DStringValue(dstPtr); @@ -1337,7 +1368,7 @@ Tcl_UtfToExternalDString( Tcl_DStringSetLength(dstPtr, soFar + 1); } Tcl_DStringSetLength(dstPtr, soFar); - return Tcl_DStringValue(dstPtr); + return result; } flags &= ~TCL_ENCODING_START; diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index b66af58..0473bb1 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -1932,6 +1932,8 @@ const TclStubs tclStubs = { Tcl_UtfCharComplete, /* 654 */ Tcl_UtfNext, /* 655 */ Tcl_UtfPrev, /* 656 */ + Tcl_ExternalToUtfDStringEx, /* 657 */ + Tcl_UtfToExternalDStringEx, /* 658 */ }; /* !END!: Do not edit above this line. */ -- cgit v0.12 From 9fb8027cf65024e499873614e710122af9044cf0 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 26 Mar 2021 16:47:51 +0000 Subject: More WIP: Add -stoponerror flag to "encoding convertfrom/converto" --- generic/tclCmdAH.c | 48 ++++++++++++++++++++++++++++++++++++++++-------- tests/cmdAH.test | 4 ++-- tests/encoding.test | 15 +++++++++++++++ tests/safe.test | 8 ++++---- 4 files changed, 61 insertions(+), 14 deletions(-) diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index c09ad95..ee329ec 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -513,8 +513,8 @@ TclInitEncodingCmd( Tcl_Interp* interp) /* Tcl interpreter */ { static const EnsembleImplMap encodingImplMap[] = { - {"convertfrom", EncodingConvertfromObjCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, - {"convertto", EncodingConverttoObjCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, + {"convertfrom", EncodingConvertfromObjCmd, TclCompileBasic1To3ArgCmd, NULL, NULL, 0}, + {"convertto", EncodingConverttoObjCmd, TclCompileBasic1To3ArgCmd, NULL, NULL, 0}, {"dirs", EncodingDirsObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1}, {"names", EncodingNamesObjCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, {"system", EncodingSystemObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1}, @@ -550,17 +550,27 @@ EncodingConvertfromObjCmd( Tcl_Encoding encoding; /* Encoding to use */ int length; /* Length of the byte array being converted */ const char *bytesPtr; /* Pointer to the first byte of the array */ + const char *stopOnError = NULL; + int result; if (objc == 2) { encoding = Tcl_GetEncoding(interp, NULL); data = objv[1]; - } else if (objc == 3) { + } else if ((unsigned)(objc - 3) < 2) { if (Tcl_GetEncodingFromObj(interp, objv[1], &encoding) != TCL_OK) { return TCL_ERROR; } data = objv[2]; + if (objc > 3) { + stopOnError = Tcl_GetString(objv[3]); + if (stopOnError[0] != '-' || stopOnError[1] != 's' + || strncmp(stopOnError, "-stoponerror", strlen(stopOnError))) { + goto encConvFromError; + } + } } else { - Tcl_WrongNumArgs(interp, 1, objv, "?encoding? data"); + encConvFromError: + Tcl_WrongNumArgs(interp, 1, objv, "?encoding? data ?-stoponerror?"); return TCL_ERROR; } @@ -568,7 +578,13 @@ EncodingConvertfromObjCmd( * Convert the string into a byte array in 'ds' */ bytesPtr = (char *) Tcl_GetByteArrayFromObj(data, &length); - Tcl_ExternalToUtfDString(encoding, bytesPtr, length, &ds); + result = Tcl_ExternalToUtfDStringEx(encoding, bytesPtr, length, &ds, + stopOnError ? TCL_ENCODING_STOPONERROR : 0); + if (stopOnError && (result != TCL_OK)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf("encoding error after producing %d characters", Tcl_DStringLength(&ds))); + Tcl_DStringFree(&ds); + return TCL_ERROR; + } /* * Note that we cannot use Tcl_DStringResult here because it will @@ -612,19 +628,29 @@ EncodingConverttoObjCmd( Tcl_Encoding encoding; /* Encoding to use */ int length; /* Length of the string being converted */ const char *stringPtr; /* Pointer to the first byte of the string */ + int result; + const char *stopOnError = NULL; /* TODO - ADJUST OBJ INDICES WHEN ENSEMBLIFYING THIS */ if (objc == 2) { encoding = Tcl_GetEncoding(interp, NULL); data = objv[1]; - } else if (objc == 3) { + } else if ((unsigned)(objc - 3) < 2) { if (Tcl_GetEncodingFromObj(interp, objv[1], &encoding) != TCL_OK) { return TCL_ERROR; } data = objv[2]; + if (objc > 3) { + stopOnError = Tcl_GetString(objv[3]); + if (stopOnError[0] != '-' || stopOnError[1] != 's' + || strncmp(stopOnError, "-stoponerror", strlen(stopOnError))) { + goto encConvToError; + } + } } else { - Tcl_WrongNumArgs(interp, 1, objv, "?encoding? data"); + encConvToError: + Tcl_WrongNumArgs(interp, 1, objv, "?encoding? data ?-stoponerror?"); return TCL_ERROR; } @@ -633,7 +659,13 @@ EncodingConverttoObjCmd( */ stringPtr = TclGetStringFromObj(data, &length); - Tcl_UtfToExternalDString(encoding, stringPtr, length, &ds); + result = Tcl_UtfToExternalDStringEx(encoding, stringPtr, length, &ds, + stopOnError ? TCL_ENCODING_STOPONERROR : 0); + if (stopOnError && (result != TCL_OK)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf("encoding error after producing %d bytes", Tcl_DStringLength(&ds))); + Tcl_DStringFree(&ds); + return TCL_ERROR; + } Tcl_SetObjResult(interp, Tcl_NewByteArrayObj((unsigned char*) Tcl_DStringValue(&ds), Tcl_DStringLength(&ds))); diff --git a/tests/cmdAH.test b/tests/cmdAH.test index baa148e..29adeae 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -178,7 +178,7 @@ test cmdAH-4.2 {Tcl_EncodingObjCmd} -returnCodes error -body { } -result {unknown or ambiguous subcommand "foo": must be convertfrom, convertto, dirs, names, or system} test cmdAH-4.3 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding convertto -} -result {wrong # args: should be "encoding convertto ?encoding? data"} +} -result {wrong # args: should be "encoding convertto ?encoding? data ?-stoponerror?"} test cmdAH-4.4 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding convertto foo bar } -result {unknown encoding "foo"} @@ -200,7 +200,7 @@ test cmdAH-4.6 {Tcl_EncodingObjCmd} -setup { } -result 8C test cmdAH-4.7 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding convertfrom -} -result {wrong # args: should be "encoding convertfrom ?encoding? data"} +} -result {wrong # args: should be "encoding convertfrom ?encoding? data ?-stoponerror?"} test cmdAH-4.8 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding convertfrom foo bar } -result {unknown encoding "foo"} diff --git a/tests/encoding.test b/tests/encoding.test index b1150c6..f881d4f 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -580,6 +580,21 @@ test encoding-24.10 {Parse valid or invalid utf-8} { test encoding-24.11 {Parse valid or invalid utf-8} { string length [encoding convertfrom utf-8 "\xEF\xBF\xBF"] } 1 +test encoding-24.12 {Parse valid or invalid utf-8} { + string length [encoding convertfrom utf-8 "\xC0\x80" -stoponerror] +} 1 +test encoding-24.13 {Parse valid or invalid utf-8} -body { + encoding convertfrom utf-8 "\xC0\x81" -stoponerror +} -returnCodes 1 -result {encoding error after producing 0 characters} +test encoding-24.14 {Parse valid or invalid utf-8} -body { + encoding convertfrom utf-8 "\xC1\xBF" -stoponerror +} -returnCodes 1 -result {encoding error after producing 0 characters} +test encoding-24.15 {Parse valid or invalid utf-8} { + string length [encoding convertfrom utf-8 "\xC2\x80" -stoponerror] +} 1 +test encoding-24.16 {Parse valid or invalid utf-8} -body { + encoding convertfrom utf-8 "Z\xE0\x80" -stoponerror +} -returnCodes 1 -result {encoding error after producing 1 characters} file delete [file join [temporaryDirectory] iso2022.txt] diff --git a/tests/safe.test b/tests/safe.test index 8fca594..e2a9b83 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -1267,7 +1267,7 @@ test safe-11.7 {testing safe encoding} -setup { interp eval $i encoding convertfrom } -returnCodes error -cleanup { safe::interpDelete $i -} -result {wrong # args: should be "encoding convertfrom ?encoding? data"} +} -result {wrong # args: should be "encoding convertfrom ?encoding? data ?-stoponerror?"} test safe-11.7.1 {testing safe encoding} -setup { set i [safe::interpCreate] } -body { @@ -1276,7 +1276,7 @@ test safe-11.7.1 {testing safe encoding} -setup { } -returnCodes ok -match glob -cleanup { unset -nocomplain m o safe::interpDelete $i -} -result {wrong # args: should be "encoding convertfrom ?encoding? data" +} -result {wrong # args: should be "encoding convertfrom ?encoding? data ?-stoponerror?" while executing "encoding convertfrom" invoked from within @@ -1289,7 +1289,7 @@ test safe-11.8 {testing safe encoding} -setup { interp eval $i encoding convertto } -returnCodes error -cleanup { safe::interpDelete $i -} -result {wrong # args: should be "encoding convertto ?encoding? data"} +} -result {wrong # args: should be "encoding convertto ?encoding? data ?-stoponerror?"} test safe-11.8.1 {testing safe encoding} -setup { set i [safe::interpCreate] } -body { @@ -1298,7 +1298,7 @@ test safe-11.8.1 {testing safe encoding} -setup { } -returnCodes ok -match glob -cleanup { unset -nocomplain m o safe::interpDelete $i -} -result {wrong # args: should be "encoding convertto ?encoding? data" +} -result {wrong # args: should be "encoding convertto ?encoding? data ?-stoponerror?" while executing "encoding convertto" invoked from within -- cgit v0.12 From 664b7500abd51bfa6257c7e3e8fc5846d18d522b Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 30 Mar 2021 11:26:36 +0000 Subject: Add documentation. Do a better job of counting exactly which byte/character caused the encoding/decoding error --- doc/Encoding.3 | 20 +++++++++++++++++++- generic/tcl.decls | 8 ++++---- generic/tcl.h | 5 +++++ generic/tclCmdAH.c | 31 +++++++++++++++++++------------ generic/tclDecls.h | 16 ++++++++-------- generic/tclEncoding.c | 30 +++++++++++++++--------------- tests/encoding.test | 6 +++--- 7 files changed, 73 insertions(+), 43 deletions(-) diff --git a/doc/Encoding.3 b/doc/Encoding.3 index 2d2461e..c33878a 100644 --- a/doc/Encoding.3 +++ b/doc/Encoding.3 @@ -26,8 +26,14 @@ char * \fBTcl_ExternalToUtfDString\fR(\fIencoding, src, srcLen, dstPtr\fR) .sp char * +\fBTcl_ExternalToUtfDStringEx\fR(\fIencoding, src, srcLen, flags, dstPtr\fR) +.sp +char * \fBTcl_UtfToExternalDString\fR(\fIencoding, src, srcLen, dstPtr\fR) .sp +char * +\fBTcl_UtfToExternalDStringEx\fR(\fIencoding, src, srcLen, flags, dstPtr\fR) +.sp int \fBTcl_ExternalToUtf\fR(\fIinterp, encoding, src, srcLen, flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr, dstCharsPtr\fR) @@ -108,7 +114,9 @@ byte is converted and then to reset to an initial state. \fBTCL_ENCODING_STOPONERROR\fR signifies that the conversion routine should return immediately upon reading a source character that does not exist in the target encoding; otherwise a default fallback character will -automatically be substituted. +automatically be substituted. The flag \fBTCL_ENCODING_MODIFIED\fR makes +\fBTcl_UtfToExternalDStringEx\fR and \fBTcl_UtfToExternal\fR produce the +byte sequence \exC0\ex80 in stead of \ex00, for the utf-8/wtf-8/cesu-8 encoders. .AP Tcl_EncodingState *statePtr in/out Used when converting a (generally long or indefinite length) byte stream in a piece-by-piece fashion. The conversion routine stores its current @@ -208,6 +216,11 @@ When converting, if any of the characters in the source buffer cannot be represented in the target encoding, a default fallback character will be used. The return value is a pointer to the value stored in the DString. .PP +\fBTcl_ExternalToUtfDStringEx\fR is the same as \fBTcl_ExternalToUtfDString\fR, +but it has an additional flags parameter. The return value is the index of +the first byte in the input string causing a conversion error. +Or (size_t)-1 if all is OK. +.PP \fBTcl_ExternalToUtf\fR converts a source buffer \fIsrc\fR from the specified \fIencoding\fR into UTF-8. Up to \fIsrcLen\fR bytes are converted from the source buffer and up to \fIdstLen\fR converted bytes are stored in \fIdst\fR. @@ -246,6 +259,11 @@ characters in the source buffer cannot be represented in the target encoding, a default fallback character will be used. The return value is a pointer to the value stored in the DString. .PP +\fBTcl_UtfToExternalDStringEx\fR is the same as \fBTcl_UtfToExternalDString\fR, +but it has an additional flags parameter. The return value is the index of +the first byte in the input string causing a conversion error. +Or (size_t)-1 if all is OK. +.PP \fBTcl_UtfToExternal\fR converts a source buffer \fIsrc\fR from UTF-8 into the specified \fIencoding\fR. Up to \fIsrcLen\fR bytes are converted from the source buffer and up to \fIdstLen\fR converted bytes are stored in diff --git a/generic/tcl.decls b/generic/tcl.decls index c2a4abd..8cd5bc9 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2425,12 +2425,12 @@ declare 656 { } declare 657 { - int Tcl_ExternalToUtfDStringEx(Tcl_Encoding encoding, - const char *src, int srcLen, Tcl_DString *dsPtr, int flags) + size_t Tcl_ExternalToUtfDStringEx(Tcl_Encoding encoding, + const char *src, int srcLen, int flags, Tcl_DString *dsPtr) } declare 658 { - int Tcl_UtfToExternalDStringEx(Tcl_Encoding encoding, - const char *src, int srcLen, Tcl_DString *dsPtr, int flags) + size_t Tcl_UtfToExternalDStringEx(Tcl_Encoding encoding, + const char *src, int srcLen, int flags, Tcl_DString *dsPtr) } diff --git a/generic/tcl.h b/generic/tcl.h index 38dda28..f783f4f 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -2069,6 +2069,10 @@ typedef struct Tcl_EncodingType { * content. Otherwise, the number of chars * produced is controlled only by other limiting * factors. + * TCL_ENCODING_MODIFIED - Convert NULL bytes to \xC0\x80 in stead of + * 0x00. Only valid for "utf-8", "wtf-8 and "cesu-8". + * This flag is implicit for external -> internal conversions, + * optional for internal -> external conversions. */ #define TCL_ENCODING_START 0x01 @@ -2076,6 +2080,7 @@ typedef struct Tcl_EncodingType { #define TCL_ENCODING_STOPONERROR 0x04 #define TCL_ENCODING_NO_TERMINATE 0x08 #define TCL_ENCODING_CHAR_LIMIT 0x10 +#define TCL_ENCODING_MODIFIED 0x20 /* * The following definitions are the error codes returned by the conversion diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index ee329ec..cd77e06 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -551,7 +551,7 @@ EncodingConvertfromObjCmd( int length; /* Length of the byte array being converted */ const char *bytesPtr; /* Pointer to the first byte of the array */ const char *stopOnError = NULL; - int result; + size_t result; if (objc == 2) { encoding = Tcl_GetEncoding(interp, NULL); @@ -563,7 +563,9 @@ EncodingConvertfromObjCmd( data = objv[2]; if (objc > 3) { stopOnError = Tcl_GetString(objv[3]); - if (stopOnError[0] != '-' || stopOnError[1] != 's' + if (!stopOnError[0]) { + stopOnError = NULL; + } else if (stopOnError[0] != '-' || stopOnError[1] != 's' || strncmp(stopOnError, "-stoponerror", strlen(stopOnError))) { goto encConvFromError; } @@ -578,10 +580,11 @@ EncodingConvertfromObjCmd( * Convert the string into a byte array in 'ds' */ bytesPtr = (char *) Tcl_GetByteArrayFromObj(data, &length); - result = Tcl_ExternalToUtfDStringEx(encoding, bytesPtr, length, &ds, - stopOnError ? TCL_ENCODING_STOPONERROR : 0); - if (stopOnError && (result != TCL_OK)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf("encoding error after producing %d characters", Tcl_DStringLength(&ds))); + result = Tcl_ExternalToUtfDStringEx(encoding, bytesPtr, length, + stopOnError ? TCL_ENCODING_STOPONERROR : 0, &ds); + if (stopOnError && (result != (size_t)-1)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf("encoding error after reading %" + TCL_LL_MODIFIER "u byte%s", (long long)result, (result != 1)?"s":"")); Tcl_DStringFree(&ds); return TCL_ERROR; } @@ -628,7 +631,7 @@ EncodingConverttoObjCmd( Tcl_Encoding encoding; /* Encoding to use */ int length; /* Length of the string being converted */ const char *stringPtr; /* Pointer to the first byte of the string */ - int result; + size_t result; const char *stopOnError = NULL; /* TODO - ADJUST OBJ INDICES WHEN ENSEMBLIFYING THIS */ @@ -643,7 +646,9 @@ EncodingConverttoObjCmd( data = objv[2]; if (objc > 3) { stopOnError = Tcl_GetString(objv[3]); - if (stopOnError[0] != '-' || stopOnError[1] != 's' + if (!stopOnError[0]) { + stopOnError = NULL; + } else if (stopOnError[0] != '-' || stopOnError[1] != 's' || strncmp(stopOnError, "-stoponerror", strlen(stopOnError))) { goto encConvToError; } @@ -659,10 +664,12 @@ EncodingConverttoObjCmd( */ stringPtr = TclGetStringFromObj(data, &length); - result = Tcl_UtfToExternalDStringEx(encoding, stringPtr, length, &ds, - stopOnError ? TCL_ENCODING_STOPONERROR : 0); - if (stopOnError && (result != TCL_OK)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf("encoding error after producing %d bytes", Tcl_DStringLength(&ds))); + result = Tcl_UtfToExternalDStringEx(encoding, stringPtr, length, + stopOnError ? TCL_ENCODING_STOPONERROR : 0, &ds); + if (stopOnError && (result != (size_t)-1)) { + result = Tcl_NumUtfChars(stringPtr, result); + Tcl_SetObjResult(interp, Tcl_ObjPrintf("encoding error after reading %" + TCL_LL_MODIFIER "u character%s", (long long)result, (result != 1)?"s":"")); Tcl_DStringFree(&ds); return TCL_ERROR; } diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 6ba39d5..24760f9 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1938,13 +1938,13 @@ EXTERN const char * Tcl_UtfNext(const char *src); /* 656 */ EXTERN const char * Tcl_UtfPrev(const char *src, const char *start); /* 657 */ -EXTERN int Tcl_ExternalToUtfDStringEx(Tcl_Encoding encoding, - const char *src, int srcLen, - Tcl_DString *dsPtr, int flags); +EXTERN size_t Tcl_ExternalToUtfDStringEx(Tcl_Encoding encoding, + const char *src, int srcLen, int flags, + Tcl_DString *dsPtr); /* 658 */ -EXTERN int Tcl_UtfToExternalDStringEx(Tcl_Encoding encoding, - const char *src, int srcLen, - Tcl_DString *dsPtr, int flags); +EXTERN size_t Tcl_UtfToExternalDStringEx(Tcl_Encoding encoding, + const char *src, int srcLen, int flags, + Tcl_DString *dsPtr); typedef struct { const struct TclPlatStubs *tclPlatStubs; @@ -2637,8 +2637,8 @@ typedef struct TclStubs { int (*tcl_UtfCharComplete) (const char *src, int length); /* 654 */ const char * (*tcl_UtfNext) (const char *src); /* 655 */ const char * (*tcl_UtfPrev) (const char *src, const char *start); /* 656 */ - int (*tcl_ExternalToUtfDStringEx) (Tcl_Encoding encoding, const char *src, int srcLen, Tcl_DString *dsPtr, int flags); /* 657 */ - int (*tcl_UtfToExternalDStringEx) (Tcl_Encoding encoding, const char *src, int srcLen, Tcl_DString *dsPtr, int flags); /* 658 */ + size_t (*tcl_ExternalToUtfDStringEx) (Tcl_Encoding encoding, const char *src, int srcLen, int flags, Tcl_DString *dsPtr); /* 657 */ + size_t (*tcl_UtfToExternalDStringEx) (Tcl_Encoding encoding, const char *src, int srcLen, int flags, Tcl_DString *dsPtr); /* 658 */ } TclStubs; extern const TclStubs *tclStubsPtr; diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 72f7690..0bce51b 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -511,7 +511,6 @@ FillEncodingFileMap(void) */ /* Those flags must not conflict with other TCL_ENCODING_* flags in tcl.h */ -#define TCL_ENCODING_MODIFIED 0x20 /* Converting NULL bytes to 0xC0 0x80 */ #define TCL_ENCODING_LE 0x80 /* Little-endian encoding, for ucs-2/utf-16 only */ void @@ -1117,26 +1116,27 @@ Tcl_ExternalToUtfDString( Tcl_DString *dstPtr) /* Uninitialized or free DString in which the * converted string is stored. */ { - Tcl_ExternalToUtfDStringEx(encoding, src, srcLen, dstPtr, 0); + Tcl_ExternalToUtfDStringEx(encoding, src, srcLen, 0, dstPtr); return Tcl_DStringValue(dstPtr); } -int +size_t Tcl_ExternalToUtfDStringEx( Tcl_Encoding encoding, /* The encoding for the source string, or NULL * for the default system encoding. */ const char *src, /* Source string in specified encoding. */ int srcLen, /* Source string length in bytes, or < 0 for * encoding-specific string length. */ - Tcl_DString *dstPtr, /* Uninitialized or free DString in which the + int flags, /* Conversion control flags. */ + Tcl_DString *dstPtr) /* Uninitialized or free DString in which the * converted string is stored. */ - int flags) /* Conversion control flags. */ { char *dst; Tcl_EncodingState state; const Encoding *encodingPtr; int dstLen, result, soFar, srcRead, dstWrote, dstChars; + const char *srcStart = src; Tcl_DStringInit(dstPtr); dst = Tcl_DStringValue(dstPtr); @@ -1160,13 +1160,12 @@ Tcl_ExternalToUtfDStringEx( flags, &state, dst, dstLen, &srcRead, &dstWrote, &dstChars); soFar = dst + dstWrote - Tcl_DStringValue(dstPtr); + src += srcRead; if (result != TCL_CONVERT_NOSPACE) { Tcl_DStringSetLength(dstPtr, soFar); - return result; + return (result == TCL_OK) ? (size_t)-1 : (size_t)(src - srcStart); } - flags &= ~TCL_ENCODING_START; - src += srcRead; srcLen -= srcRead; if (Tcl_DStringLength(dstPtr) == 0) { Tcl_DStringSetLength(dstPtr, dstLen); @@ -1321,25 +1320,26 @@ Tcl_UtfToExternalDString( Tcl_DString *dstPtr) /* Uninitialized or free DString in which the * converted string is stored. */ { - Tcl_UtfToExternalDStringEx(encoding, src, srcLen, dstPtr, 0); + Tcl_UtfToExternalDStringEx(encoding, src, srcLen, 0, dstPtr); return Tcl_DStringValue(dstPtr); } -int +size_t Tcl_UtfToExternalDStringEx( Tcl_Encoding encoding, /* The encoding for the converted string, or * NULL for the default system encoding. */ const char *src, /* Source string in UTF-8. */ int srcLen, /* Source string length in bytes, or < 0 for * strlen(). */ - Tcl_DString *dstPtr, /* Uninitialized or free DString in which the + int flags, /* Conversion control flags. */ + Tcl_DString *dstPtr) /* Uninitialized or free DString in which the * converted string is stored. */ - int flags) /* Conversion control flags. */ { char *dst; Tcl_EncodingState state; const Encoding *encodingPtr; int dstLen, result, soFar, srcRead, dstWrote, dstChars; + const char *srcStart = src; Tcl_DStringInit(dstPtr); dst = Tcl_DStringValue(dstPtr); @@ -1355,23 +1355,23 @@ Tcl_UtfToExternalDStringEx( } else if (srcLen < 0) { srcLen = strlen(src); } - flags |= TCL_ENCODING_START | TCL_ENCODING_END | TCL_ENCODING_EXTERNAL; + flags |= TCL_ENCODING_START | TCL_ENCODING_END; while (1) { result = encodingPtr->fromUtfProc(encodingPtr->clientData, src, srcLen, flags, &state, dst, dstLen, &srcRead, &dstWrote, &dstChars); soFar = dst + dstWrote - Tcl_DStringValue(dstPtr); + src += srcRead; if (result != TCL_CONVERT_NOSPACE) { if (encodingPtr->nullSize == 2) { Tcl_DStringSetLength(dstPtr, soFar + 1); } Tcl_DStringSetLength(dstPtr, soFar); - return result; + return (result == TCL_OK) ? (size_t)-1 : (size_t)(src - srcStart); } flags &= ~TCL_ENCODING_START; - src += srcRead; srcLen -= srcRead; if (Tcl_DStringLength(dstPtr) == 0) { Tcl_DStringSetLength(dstPtr, dstLen); diff --git a/tests/encoding.test b/tests/encoding.test index 76e2ca4..63f0fa6 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -585,16 +585,16 @@ test encoding-24.12 {Parse valid or invalid utf-8} { } 1 test encoding-24.13 {Parse valid or invalid utf-8} -body { encoding convertfrom utf-8 "\xC0\x81" -stoponerror -} -returnCodes 1 -result {encoding error after producing 0 characters} +} -returnCodes 1 -result {encoding error after reading 0 bytes} test encoding-24.14 {Parse valid or invalid utf-8} -body { encoding convertfrom utf-8 "\xC1\xBF" -stoponerror -} -returnCodes 1 -result {encoding error after producing 0 characters} +} -returnCodes 1 -result {encoding error after reading 0 bytes} test encoding-24.15 {Parse valid or invalid utf-8} { string length [encoding convertfrom utf-8 "\xC2\x80" -stoponerror] } 1 test encoding-24.16 {Parse valid or invalid utf-8} -body { encoding convertfrom utf-8 "Z\xE0\x80" -stoponerror -} -returnCodes 1 -result {encoding error after producing 1 characters} +} -returnCodes 1 -result {encoding error after reading 1 byte} file delete [file join [temporaryDirectory] iso2022.txt] -- cgit v0.12 From 41533dc84a21444a1885476d2b4ac780b6581a44 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 30 Mar 2021 11:54:50 +0000 Subject: add testcase for "encoding convertto". Move stub table one positions --- generic/tcl.decls | 4 ++-- generic/tcl.h | 2 +- generic/tclCmdAH.c | 2 +- generic/tclDecls.h | 15 +++++++++------ generic/tclStubInit.c | 5 +++-- tests/encoding.test | 9 ++++++--- 6 files changed, 22 insertions(+), 15 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index 8cd5bc9..0dfa415 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2424,11 +2424,11 @@ declare 656 { const char *Tcl_UtfPrev(const char *src, const char *start) } -declare 657 { +declare 658 { size_t Tcl_ExternalToUtfDStringEx(Tcl_Encoding encoding, const char *src, int srcLen, int flags, Tcl_DString *dsPtr) } -declare 658 { +declare 659 { size_t Tcl_UtfToExternalDStringEx(Tcl_Encoding encoding, const char *src, int srcLen, int flags, Tcl_DString *dsPtr) } diff --git a/generic/tcl.h b/generic/tcl.h index f783f4f..e1b6066 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -2080,7 +2080,7 @@ typedef struct Tcl_EncodingType { #define TCL_ENCODING_STOPONERROR 0x04 #define TCL_ENCODING_NO_TERMINATE 0x08 #define TCL_ENCODING_CHAR_LIMIT 0x10 -#define TCL_ENCODING_MODIFIED 0x20 +#define TCL_ENCODING_MODIFIED 0x20 /* * The following definitions are the error codes returned by the conversion diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index cd77e06..df80d3c 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -583,7 +583,7 @@ EncodingConvertfromObjCmd( result = Tcl_ExternalToUtfDStringEx(encoding, bytesPtr, length, stopOnError ? TCL_ENCODING_STOPONERROR : 0, &ds); if (stopOnError && (result != (size_t)-1)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf("encoding error after reading %" + Tcl_SetObjResult(interp, Tcl_ObjPrintf("decoding error after reading %" TCL_LL_MODIFIER "u byte%s", (long long)result, (result != 1)?"s":"")); Tcl_DStringFree(&ds); return TCL_ERROR; diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 24760f9..6ee645d 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1937,11 +1937,12 @@ EXTERN int Tcl_UtfCharComplete(const char *src, int length); EXTERN const char * Tcl_UtfNext(const char *src); /* 656 */ EXTERN const char * Tcl_UtfPrev(const char *src, const char *start); -/* 657 */ +/* Slot 657 is reserved */ +/* 658 */ EXTERN size_t Tcl_ExternalToUtfDStringEx(Tcl_Encoding encoding, const char *src, int srcLen, int flags, Tcl_DString *dsPtr); -/* 658 */ +/* 659 */ EXTERN size_t Tcl_UtfToExternalDStringEx(Tcl_Encoding encoding, const char *src, int srcLen, int flags, Tcl_DString *dsPtr); @@ -2637,8 +2638,9 @@ typedef struct TclStubs { int (*tcl_UtfCharComplete) (const char *src, int length); /* 654 */ const char * (*tcl_UtfNext) (const char *src); /* 655 */ const char * (*tcl_UtfPrev) (const char *src, const char *start); /* 656 */ - size_t (*tcl_ExternalToUtfDStringEx) (Tcl_Encoding encoding, const char *src, int srcLen, int flags, Tcl_DString *dsPtr); /* 657 */ - size_t (*tcl_UtfToExternalDStringEx) (Tcl_Encoding encoding, const char *src, int srcLen, int flags, Tcl_DString *dsPtr); /* 658 */ + void (*reserved657)(void); + size_t (*tcl_ExternalToUtfDStringEx) (Tcl_Encoding encoding, const char *src, int srcLen, int flags, Tcl_DString *dsPtr); /* 658 */ + size_t (*tcl_UtfToExternalDStringEx) (Tcl_Encoding encoding, const char *src, int srcLen, int flags, Tcl_DString *dsPtr); /* 659 */ } TclStubs; extern const TclStubs *tclStubsPtr; @@ -3981,10 +3983,11 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_UtfNext) /* 655 */ #define Tcl_UtfPrev \ (tclStubsPtr->tcl_UtfPrev) /* 656 */ +/* Slot 657 is reserved */ #define Tcl_ExternalToUtfDStringEx \ - (tclStubsPtr->tcl_ExternalToUtfDStringEx) /* 657 */ + (tclStubsPtr->tcl_ExternalToUtfDStringEx) /* 658 */ #define Tcl_UtfToExternalDStringEx \ - (tclStubsPtr->tcl_UtfToExternalDStringEx) /* 658 */ + (tclStubsPtr->tcl_UtfToExternalDStringEx) /* 659 */ #endif /* defined(USE_TCL_STUBS) */ diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 0473bb1..54ab4b6 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -1932,8 +1932,9 @@ const TclStubs tclStubs = { Tcl_UtfCharComplete, /* 654 */ Tcl_UtfNext, /* 655 */ Tcl_UtfPrev, /* 656 */ - Tcl_ExternalToUtfDStringEx, /* 657 */ - Tcl_UtfToExternalDStringEx, /* 658 */ + 0, /* 657 */ + Tcl_ExternalToUtfDStringEx, /* 658 */ + Tcl_UtfToExternalDStringEx, /* 659 */ }; /* !END!: Do not edit above this line. */ diff --git a/tests/encoding.test b/tests/encoding.test index 63f0fa6..1c12be0 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -585,16 +585,19 @@ test encoding-24.12 {Parse valid or invalid utf-8} { } 1 test encoding-24.13 {Parse valid or invalid utf-8} -body { encoding convertfrom utf-8 "\xC0\x81" -stoponerror -} -returnCodes 1 -result {encoding error after reading 0 bytes} +} -returnCodes 1 -result {decoding error after reading 0 bytes} test encoding-24.14 {Parse valid or invalid utf-8} -body { encoding convertfrom utf-8 "\xC1\xBF" -stoponerror -} -returnCodes 1 -result {encoding error after reading 0 bytes} +} -returnCodes 1 -result {decoding error after reading 0 bytes} test encoding-24.15 {Parse valid or invalid utf-8} { string length [encoding convertfrom utf-8 "\xC2\x80" -stoponerror] } 1 test encoding-24.16 {Parse valid or invalid utf-8} -body { encoding convertfrom utf-8 "Z\xE0\x80" -stoponerror -} -returnCodes 1 -result {encoding error after reading 1 byte} +} -returnCodes 1 -result {decoding error after reading 1 byte} +test encoding-24.17 {Parse valid or invalid utf-8} -constraints testbytestring -body { + encoding convertto utf-8 [testbytestring "Z\xE0\x80"] -stoponerror +} -returnCodes 1 -result {encoding error after reading 1 character} file delete [file join [temporaryDirectory] iso2022.txt] -- cgit v0.12 From 78a0992b4431f976641f3d08f63c13fab742e1b9 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 30 Mar 2021 13:35:15 +0000 Subject: Better error-messages --- generic/tclCmdAH.c | 23 ++++++++++++++++------- tests/encoding.test | 11 +++++++---- 2 files changed, 23 insertions(+), 11 deletions(-) diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index df80d3c..0c0a4a4 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -579,12 +579,19 @@ EncodingConvertfromObjCmd( /* * Convert the string into a byte array in 'ds' */ - bytesPtr = (char *) Tcl_GetByteArrayFromObj(data, &length); + if (stopOnError) { + bytesPtr = (char *) TclGetBytesFromObj(interp, data, &length); + if (bytesPtr == NULL) { + return TCL_ERROR; + } + } else { + bytesPtr = (char *) Tcl_GetByteArrayFromObj(data, &length); + } result = Tcl_ExternalToUtfDStringEx(encoding, bytesPtr, length, stopOnError ? TCL_ENCODING_STOPONERROR : 0, &ds); if (stopOnError && (result != (size_t)-1)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf("decoding error after reading %" - TCL_LL_MODIFIER "u byte%s", (long long)result, (result != 1)?"s":"")); + Tcl_SetObjResult(interp, Tcl_ObjPrintf("unexpected byte at index %" + TCL_LL_MODIFIER "u: '%c' (\\x%X)", (long long)result, UCHAR(bytesPtr[result]), UCHAR(bytesPtr[result]))); Tcl_DStringFree(&ds); return TCL_ERROR; } @@ -667,10 +674,12 @@ EncodingConverttoObjCmd( result = Tcl_UtfToExternalDStringEx(encoding, stringPtr, length, stopOnError ? TCL_ENCODING_STOPONERROR : 0, &ds); if (stopOnError && (result != (size_t)-1)) { - result = Tcl_NumUtfChars(stringPtr, result); - Tcl_SetObjResult(interp, Tcl_ObjPrintf("encoding error after reading %" - TCL_LL_MODIFIER "u character%s", (long long)result, (result != 1)?"s":"")); - Tcl_DStringFree(&ds); + size_t pos = Tcl_NumUtfChars(stringPtr, result); + int ucs4; + TclUtfToUCS4(&stringPtr[result], &ucs4); + Tcl_SetObjResult(interp, Tcl_ObjPrintf("unexpected character at index %" + TCL_LL_MODIFIER "u: '%1s' (U+%06X)", (long long)pos, &stringPtr[result], ucs4)); + Tcl_DStringFree(&ds); return TCL_ERROR; } Tcl_SetObjResult(interp, diff --git a/tests/encoding.test b/tests/encoding.test index 1c12be0..114b296 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -585,19 +585,22 @@ test encoding-24.12 {Parse valid or invalid utf-8} { } 1 test encoding-24.13 {Parse valid or invalid utf-8} -body { encoding convertfrom utf-8 "\xC0\x81" -stoponerror -} -returnCodes 1 -result {decoding error after reading 0 bytes} +} -returnCodes 1 -result {unexpected byte at index 0: 'À' (\xC0)} test encoding-24.14 {Parse valid or invalid utf-8} -body { encoding convertfrom utf-8 "\xC1\xBF" -stoponerror -} -returnCodes 1 -result {decoding error after reading 0 bytes} +} -returnCodes 1 -result {unexpected byte at index 0: 'Á' (\xC1)} test encoding-24.15 {Parse valid or invalid utf-8} { string length [encoding convertfrom utf-8 "\xC2\x80" -stoponerror] } 1 test encoding-24.16 {Parse valid or invalid utf-8} -body { encoding convertfrom utf-8 "Z\xE0\x80" -stoponerror -} -returnCodes 1 -result {decoding error after reading 1 byte} +} -returnCodes 1 -result {unexpected byte at index 1: 'à' (\xE0)} test encoding-24.17 {Parse valid or invalid utf-8} -constraints testbytestring -body { + encoding convertto utf-8 [testbytestring "Z\u4343\x80"] -stoponerror +} -returnCodes 1 -result {expected byte sequence but character 1 was '䍃€' (U+004343)} +test encoding-24.18 {Parse valid or invalid utf-8} -constraints testbytestring -body { encoding convertto utf-8 [testbytestring "Z\xE0\x80"] -stoponerror -} -returnCodes 1 -result {encoding error after reading 1 character} +} -returnCodes 1 -match glob -result {unexpected character at index 1: '*' (U+0000E0)} file delete [file join [temporaryDirectory] iso2022.txt] -- cgit v0.12 From 975d478bfaf46abfe1b34bdbd82dd0dc9556d864 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 1 Apr 2021 09:10:13 +0000 Subject: More bugfixes (and testcases showing this) --- generic/tclCmdAH.c | 2 +- generic/tclEncoding.c | 17 +++++++++++------ tests/encoding.test | 5 ++++- 3 files changed, 16 insertions(+), 8 deletions(-) diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 0c0a4a4..1dfabd2 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -678,7 +678,7 @@ EncodingConverttoObjCmd( int ucs4; TclUtfToUCS4(&stringPtr[result], &ucs4); Tcl_SetObjResult(interp, Tcl_ObjPrintf("unexpected character at index %" - TCL_LL_MODIFIER "u: '%1s' (U+%06X)", (long long)pos, &stringPtr[result], ucs4)); + TCL_LL_MODIFIER "u: '%c' (U+%06X)", (long long)pos, ucs4, ucs4)); Tcl_DStringFree(&ds); return TCL_ERROR; } diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index d28fc8c..6cf0d76 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -2303,18 +2303,23 @@ UtfToUtfProc( * unless the user has explicitly asked to be told. */ - if (flags & TCL_ENCODING_STOPONERROR) { - result = TCL_CONVERT_MULTIBYTE; - break; + if (flags & TCL_ENCODING_MODIFIED) { + if (flags & TCL_ENCODING_STOPONERROR) { + result = TCL_CONVERT_MULTIBYTE; + break; + } + ch = UCHAR(*src++); + } else { + char chbuf[2]; + chbuf[0] = UCHAR(*src++); chbuf[1] = 0; + TclUtfToUCS4(chbuf, &ch); } - ch = UCHAR(*src); - src += 1; dst += Tcl_UniCharToUtf(ch, dst); } else { int low; const char *saveSrc = src; size_t len = TclUtfToUCS4(src, &ch); - if ((len < 2) && (ch != 0) && (flags & TCL_ENCODING_STOPONERROR)) { + if ((len < 2) && (ch != 0) && (flags & TCL_ENCODING_STOPONERROR) && (flags & TCL_ENCODING_MODIFIED)) { result = TCL_CONVERT_SYNTAX; break; } diff --git a/tests/encoding.test b/tests/encoding.test index 45b5f49..3b3f42c 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -671,8 +671,11 @@ test encoding-24.17 {Parse valid or invalid utf-8} -constraints testbytestring - } -returnCodes 1 -result {expected byte sequence but character 1 was '䍃€' (U+004343)} test encoding-24.18 {Parse valid or invalid utf-8} -constraints testbytestring -body { encoding convertto utf-8 [testbytestring "Z\xE0\x80"] -stoponerror -} -returnCodes 1 -match glob -result {unexpected character at index 1: '*' (U+0000E0)} +} -result "Z\xC3\xA0\xE2\x82\xAC" test encoding-24.19 {Parse valid or invalid utf-8} -constraints testbytestring -body { + encoding convertto utf-8 [testbytestring "Z\xE0\x80xxxxxx"] -stoponerror +} -result "Z\xC3\xA0\xE2\x82\xACxxxxxx" +test encoding-24.20 {Parse valid or invalid utf-8} -constraints testbytestring -body { encoding convertto utf-8 "ZX\uD800" -stoponerror } -returnCodes 1 -match glob -result "unexpected character at index 2: '\uD800' (U+00D800)" -- cgit v0.12 From 6941f99c78c730b92f232078e1aa3bad1b84ae1c Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 1 Apr 2021 13:50:21 +0000 Subject: Add experimental "-nothrow" option to encoding convertfrom|convertto. If compiled with -DTCL_NO_DEPRECATED (meant for Tcl 9.0), -stoponerror is the default for all IO --- generic/tcl.h | 13 +++++++++++-- generic/tclCmdAH.c | 36 ++++++++++++++++++++++++++++-------- generic/tclEncoding.c | 26 ++++++++++++++++---------- tests/chanio.test | 8 +++++--- tests/cmdAH.test | 4 ++-- tests/encoding.test | 40 ++++++++++++++++++++-------------------- tests/http.test | 4 +++- tests/io.test | 11 ++++++----- tests/main.test | 4 +++- tests/safe.test | 8 ++++---- tests/source.test | 4 +++- 11 files changed, 101 insertions(+), 57 deletions(-) diff --git a/generic/tcl.h b/generic/tcl.h index dfb4c3a..f6c6730 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -2056,10 +2056,10 @@ typedef struct Tcl_EncodingType { * encountering an invalid byte sequence or a * source character that has no mapping in the * target encoding. If clear, the converter - * substitues the problematic character(s) with + * substitutes the problematic character(s) with * one or more "close" characters in the * destination buffer and then continues to - * convert the source. + * convert the source. Only for Tcl 8.x. * TCL_ENCODING_NO_TERMINATE - If set, Tcl_ExternalToUtf does not append a * terminating NUL byte. Since it does not need * an extra byte for a terminating NUL, it fills @@ -2078,6 +2078,14 @@ typedef struct Tcl_EncodingType { * 0x00. Only valid for "utf-8", "wtf-8 and "cesu-8". * This flag is implicit for external -> internal conversions, * optional for internal -> external conversions. + * TCL_ENCODING_NO_THROW - If set, the converter + * substitutes the problematic character(s) with + * one or more "close" characters in the + * destination buffer and then continues to + * convert the source. If clear, the converter returns + * immediately upon encountering an invalid byte sequence + * or a source character that has no mapping in the + * target encoding. Only for Tcl 9.x. */ #define TCL_ENCODING_START 0x01 @@ -2086,6 +2094,7 @@ typedef struct Tcl_EncodingType { #define TCL_ENCODING_NO_TERMINATE 0x08 #define TCL_ENCODING_CHAR_LIMIT 0x10 #define TCL_ENCODING_MODIFIED 0x20 +#define TCL_ENCODING_NO_THROW 0x40 /* * The following definitions are the error codes returned by the conversion diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 1dfabd2..ca8e939 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -564,15 +564,25 @@ EncodingConvertfromObjCmd( if (objc > 3) { stopOnError = Tcl_GetString(objv[3]); if (!stopOnError[0]) { +#if TCL_MAJOR_VERSION < 9 && !defined(TCL_NO_DEPRECATED) stopOnError = NULL; - } else if (stopOnError[0] != '-' || stopOnError[1] != 's' - || strncmp(stopOnError, "-stoponerror", strlen(stopOnError))) { +#endif + } else if (stopOnError[0] == '-' && stopOnError[1] == 'n' + && !strncmp(stopOnError, "-nothrow", strlen(stopOnError))) { + stopOnError = NULL; + } else if (stopOnError[0] == '-' && stopOnError[1] == 's' + && !strncmp(stopOnError, "-stoponerror", strlen(stopOnError))) { + } else { goto encConvFromError; } +#if TCL_MAJOR_VERSION > 8 || defined(TCL_NO_DEPRECATED) + } else { + stopOnError = ""; +#endif } } else { encConvFromError: - Tcl_WrongNumArgs(interp, 1, objv, "?encoding? data ?-stoponerror?"); + Tcl_WrongNumArgs(interp, 1, objv, "?encoding? data ?-stoponerror|-nothrow?"); return TCL_ERROR; } @@ -588,7 +598,7 @@ EncodingConvertfromObjCmd( bytesPtr = (char *) Tcl_GetByteArrayFromObj(data, &length); } result = Tcl_ExternalToUtfDStringEx(encoding, bytesPtr, length, - stopOnError ? TCL_ENCODING_STOPONERROR : 0, &ds); + stopOnError ? TCL_ENCODING_STOPONERROR : TCL_ENCODING_NO_THROW, &ds); if (stopOnError && (result != (size_t)-1)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf("unexpected byte at index %" TCL_LL_MODIFIER "u: '%c' (\\x%X)", (long long)result, UCHAR(bytesPtr[result]), UCHAR(bytesPtr[result]))); @@ -654,15 +664,25 @@ EncodingConverttoObjCmd( if (objc > 3) { stopOnError = Tcl_GetString(objv[3]); if (!stopOnError[0]) { +#if TCL_MAJOR_VERSION < 9 && !defined(TCL_NO_DEPRECATED) stopOnError = NULL; - } else if (stopOnError[0] != '-' || stopOnError[1] != 's' - || strncmp(stopOnError, "-stoponerror", strlen(stopOnError))) { +#endif + } else if (stopOnError[0] == '-' && stopOnError[1] == 'n' + && !strncmp(stopOnError, "-nothrow", strlen(stopOnError))) { + stopOnError = NULL; + } else if (stopOnError[0] == '-' && stopOnError[1] == 's' + && !strncmp(stopOnError, "-stoponerror", strlen(stopOnError))) { + } else { goto encConvToError; } +#if TCL_MAJOR_VERSION > 8 || defined(TCL_NO_DEPRECATED) + } else { + stopOnError = ""; +#endif } } else { encConvToError: - Tcl_WrongNumArgs(interp, 1, objv, "?encoding? data ?-stoponerror?"); + Tcl_WrongNumArgs(interp, 1, objv, "?encoding? data ?-stoponerror|-nothrow?"); return TCL_ERROR; } @@ -672,7 +692,7 @@ EncodingConverttoObjCmd( stringPtr = TclGetStringFromObj(data, &length); result = Tcl_UtfToExternalDStringEx(encoding, stringPtr, length, - stopOnError ? TCL_ENCODING_STOPONERROR : 0, &ds); + stopOnError ? TCL_ENCODING_STOPONERROR : TCL_ENCODING_NO_THROW, &ds); if (stopOnError && (result != (size_t)-1)) { size_t pos = Tcl_NumUtfChars(stringPtr, result); int ucs4; diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index b7c0a4f..76dbe7f 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -2223,6 +2223,12 @@ BinaryProc( *------------------------------------------------------------------------- */ +#if TCL_MAJOR_VERSION > 8 || defined(TCL_NO_DEPRECATED) +# define STOPONERROR !(flags & TCL_ENCODING_NO_THROW) +#else +# define STOPONERROR (flags & TCL_ENCODING_STOPONERROR) +#endif + static int UtfToUtfProc( ClientData clientData, /* additional flags, e.g. TCL_ENCODING_MODIFIED */ @@ -2305,7 +2311,7 @@ UtfToUtfProc( */ if (flags & TCL_ENCODING_MODIFIED) { - if (flags & TCL_ENCODING_STOPONERROR) { + if (STOPONERROR) { result = TCL_CONVERT_MULTIBYTE; break; } @@ -2320,7 +2326,7 @@ UtfToUtfProc( int low; const char *saveSrc = src; size_t len = TclUtfToUCS4(src, &ch); - if ((len < 2) && (ch != 0) && (flags & TCL_ENCODING_STOPONERROR) + if ((len < 2) && (ch != 0) && STOPONERROR && (flags & TCL_ENCODING_MODIFIED)) { result = TCL_CONVERT_SYNTAX; break; @@ -2346,7 +2352,7 @@ UtfToUtfProc( if (((low & ~0x3FF) != 0xDC00) || (ch & 0x400)) { if (!(flags & TCL_ENCODING_WTF)) { - if (flags & TCL_ENCODING_STOPONERROR) { + if (STOPONERROR) { result = TCL_CONVERT_UNKNOWN; src = saveSrc; break; @@ -2365,7 +2371,7 @@ UtfToUtfProc( dst += Tcl_UniCharToUtf(ch, dst); ch = low; } else if (!(flags & TCL_ENCODING_WTF) && !Tcl_UniCharIsUnicode(ch)) { - if (flags & TCL_ENCODING_STOPONERROR) { + if (STOPONERROR) { result = TCL_CONVERT_UNKNOWN; src = saveSrc; break; @@ -2561,7 +2567,7 @@ UtfToUtf16Proc( } len = TclUtfToUCS4(src, &ch); if (!(flags & TCL_ENCODING_WTF) && !Tcl_UniCharIsUnicode(ch)) { - if (flags & TCL_ENCODING_STOPONERROR) { + if (STOPONERROR) { result = TCL_CONVERT_UNKNOWN; break; } @@ -2781,7 +2787,7 @@ TableToUtfProc( ch = pageZero[byte]; } if ((ch == 0) && (byte != 0)) { - if (flags & TCL_ENCODING_STOPONERROR) { + if (STOPONERROR) { result = TCL_CONVERT_SYNTAX; break; } @@ -2901,7 +2907,7 @@ TableFromUtfProc( word = fromUnicode[(ch >> 8)][ch & 0xFF]; if ((word == 0) && (ch != 0)) { - if (flags & TCL_ENCODING_STOPONERROR) { + if (STOPONERROR) { result = TCL_CONVERT_UNKNOWN; break; } @@ -3089,7 +3095,7 @@ Iso88591FromUtfProc( || ((ch >= 0xD800) && (len < 3)) #endif ) { - if (flags & TCL_ENCODING_STOPONERROR) { + if (STOPONERROR) { result = TCL_CONVERT_UNKNOWN; break; } @@ -3316,7 +3322,7 @@ EscapeToUtfProc( if ((checked == dataPtr->numSubTables + 2) || (flags & TCL_ENCODING_END)) { - if ((flags & TCL_ENCODING_STOPONERROR) == 0) { + if (!STOPONERROR) { /* * Skip the unknown escape sequence. */ @@ -3491,7 +3497,7 @@ EscapeFromUtfProc( if (word == 0) { state = oldState; - if (flags & TCL_ENCODING_STOPONERROR) { + if (STOPONERROR) { result = TCL_CONVERT_UNKNOWN; break; } diff --git a/tests/chanio.test b/tests/chanio.test index 8dfefb7..64d67d1 100644 --- a/tests/chanio.test +++ b/tests/chanio.test @@ -18,6 +18,8 @@ if {"::tcltest" ni [namespace children]} { namespace import -force ::tcltest::* } +testConstraint nodep [info exists tcl_precision] + namespace eval ::tcl::test::io { if {"::tcltest" ni [namespace children]} { @@ -248,7 +250,7 @@ test chan-io-3.3 {WriteChars: compatibility with WriteBytes: flush on line} -bod } -cleanup { chan close $f } -result "\r\n12" -test chan-io-3.4 {WriteChars: loop over stage buffer} { +test chan-io-3.4 {WriteChars: loop over stage buffer} nodep { # stage buffer maps to more than can be queued at once. set f [open $path(test1) w] chan configure $f -encoding jis0208 -buffersize 16 @@ -257,7 +259,7 @@ test chan-io-3.4 {WriteChars: loop over stage buffer} { chan close $f lappend x [contents $path(test1)] } [list "!)!)!)!)!)!)!)!)" "!)!)!)!)!)!)!)!)!)!)!)!)!)!)!)"] -test chan-io-3.5 {WriteChars: saved != 0} { +test chan-io-3.5 {WriteChars: saved != 0} nodep { # Bytes produced by UtfToExternal from end of last channel buffer had to # be moved to beginning of next channel buffer to preserve requested # buffersize. @@ -284,7 +286,7 @@ test chan-io-3.6 {WriteChars: (stageRead + dstWrote == 0)} { chan close $f lappend x [contents $path(test1)] } [list "12345678901234\x82\x60" "12345678901234\x82\x60\x82\x61"] -test chan-io-3.7 {WriteChars: (bufPtr->nextAdded > bufPtr->length)} { +test chan-io-3.7 {WriteChars: (bufPtr->nextAdded > bufPtr->length)} nodep { # When translating UTF-8 to external, the produced bytes went past end of # the channel buffer. This is done on purpose - we then truncate the bytes # at the end of the partial character to preserve the requested blocksize diff --git a/tests/cmdAH.test b/tests/cmdAH.test index f60068d..e9973a9 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -178,7 +178,7 @@ test cmdAH-4.2 {Tcl_EncodingObjCmd} -returnCodes error -body { } -result {unknown or ambiguous subcommand "foo": must be convertfrom, convertto, dirs, names, or system} test cmdAH-4.3 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding convertto -} -result {wrong # args: should be "encoding convertto ?encoding? data ?-stoponerror?"} +} -result {wrong # args: should be "encoding convertto ?encoding? data ?-stoponerror|-nothrow?"} test cmdAH-4.4 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding convertto foo bar } -result {unknown encoding "foo"} @@ -200,7 +200,7 @@ test cmdAH-4.6 {Tcl_EncodingObjCmd} -setup { } -result 8C test cmdAH-4.7 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding convertfrom -} -result {wrong # args: should be "encoding convertfrom ?encoding? data ?-stoponerror?"} +} -result {wrong # args: should be "encoding convertfrom ?encoding? data ?-stoponerror|-nothrow?"} test cmdAH-4.8 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding convertfrom foo bar } -result {unknown encoding "foo"} diff --git a/tests/encoding.test b/tests/encoding.test index 3b3f42c..0a5417e 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -291,7 +291,7 @@ test encoding-11.9 {encoding: extended Unicode UTF-16} { test encoding-12.1 {LoadTableEncoding: normal encoding} { set x [encoding convertto iso8859-3 Ġ] - append x [encoding convertto iso8859-3 Õ] + append x [encoding convertto iso8859-3 Õ -nothrow] append x [encoding convertfrom iso8859-3 Õ] } "Õ?Ġ" test encoding-12.2 {LoadTableEncoding: single-byte encoding} { @@ -400,7 +400,7 @@ test encoding-15.15 {UtfToUtfProc low surrogate character output} { } {1 3 eda882} test encoding-15.16 {UtfToUtfProc: Invalid 4-byte UTF-8, see [ed29806ba]} { set x \xF0\xA0\xA1\xC2 - set y [encoding convertfrom utf-8 \xF0\xA0\xA1\xC2] + set y [encoding convertfrom utf-8 \xF0\xA0\xA1\xC2 -nothrow] list [string length $x] $y } "4 \xF0\xA0\xA1\xC2" test encoding-15.17 {UtfToUtfProc emoji character output} { @@ -411,61 +411,61 @@ test encoding-15.17 {UtfToUtfProc emoji character output} { } {4 f09f9882} test encoding-15.18 {UtfToUtfProc emoji character output} { set x \uDE02\uD83D\uDE02\uD83D - set y [encoding convertto utf-8 \uDE02\uD83D\uDE02\uD83D] + set y [encoding convertto utf-8 \uDE02\uD83D\uDE02\uD83D -nothrow] binary scan $y H* z list [string length $y] $z } {10 efbfbdf09f9882efbfbd} test encoding-15.19 {UtfToUtfProc emoji character output} { set x \uDE02\uD83D\uD83D - set y [encoding convertto utf-8 \uDE02\uD83D\uD83D] + set y [encoding convertto utf-8 \uDE02\uD83D\uD83D -nothrow] binary scan $y H* z list [string length $x] [string length $y] $z } {3 9 efbfbdefbfbdefbfbd} test encoding-15.20 {UtfToUtfProc emoji character output} { set x \uDE02\uD83D\xE9 - set y [encoding convertto utf-8 \uDE02\uD83D\xE9] + set y [encoding convertto utf-8 \uDE02\uD83D\xE9 -nothrow] binary scan $y H* z list [string length $x] [string length $y] $z } {3 8 efbfbdefbfbdc3a9} test encoding-15.21 {UtfToUtfProc emoji character output} { set x \uDE02\uD83DX - set y [encoding convertto utf-8 \uDE02\uD83DX] + set y [encoding convertto utf-8 \uDE02\uD83DX -nothrow] binary scan $y H* z list [string length $x] [string length $y] $z } {3 7 efbfbdefbfbd58} test encoding-15.22 {UtfToUtfProc high surrogate character output} { set x \uDE02\xE9 - set y [encoding convertto utf-8 \uDE02\xE9] + set y [encoding convertto utf-8 \uDE02\xE9 -nothrow] binary scan $y H* z list [string length $x] [string length $y] $z } {2 5 efbfbdc3a9} test encoding-15.23 {UtfToUtfProc low surrogate character output} { set x \uDA02\xE9 - set y [encoding convertto utf-8 \uDA02\xE9] + set y [encoding convertto utf-8 \uDA02\xE9 -nothrow] binary scan $y H* z list [string length $x] [string length $y] $z } {2 5 efbfbdc3a9} test encoding-15.24 {UtfToUtfProc high surrogate character output} { set x \uDE02Y - set y [encoding convertto utf-8 \uDE02Y] + set y [encoding convertto utf-8 \uDE02Y -nothrow] binary scan $y H* z list [string length $x] [string length $y] $z } {2 4 efbfbd59} test encoding-15.25 {UtfToUtfProc low surrogate character output} { set x \uDA02Y - set y [encoding convertto utf-8 \uDA02Y] + set y [encoding convertto utf-8 \uDA02Y -nothrow] binary scan $y H* z list [string length $x] [string length $y] $z } {2 4 efbfbd59} test encoding-15.26 {UtfToUtfProc high surrogate character output} { set x \uDE02 - set y [encoding convertto utf-8 \uDE02] + set y [encoding convertto utf-8 \uDE02 -nothrow] binary scan $y H* z list [string length $x] [string length $y] $z } {1 3 efbfbd} test encoding-15.27 {UtfToUtfProc low surrogate character output} { set x \uDA02 - set y [encoding convertto utf-8 \uDA02] + set y [encoding convertto utf-8 \uDA02 -nothrow] binary scan $y H* z list [string length $x] [string length $y] $z } {1 3 efbfbd} @@ -509,10 +509,10 @@ test encoding-17.4 {UtfToUcs2Proc} -body { encoding convertfrom utf-16 [encoding convertto ucs-2 "\U460DC"] } -result "\uFFFD" test encoding-17.5 {UtfToUtf16Proc} -body { - encoding convertto utf-16be "\uDCDC" + encoding convertto utf-16be "\uDCDC" -nothrow } -result "\xFF\xFD" test encoding-17.6 {UtfToUtf16Proc} -body { - encoding convertto utf-16le "\uD8D8" + encoding convertto utf-16le "\uD8D8" -nothrow } -result "\xFD\xFF" test encoding-18.1 {TableToUtfProc} { @@ -631,25 +631,25 @@ test encoding-24.4 {Parse valid or invalid utf-8} { string length [encoding convertfrom utf-8 "\xC0\x80"] } 1 test encoding-24.5 {Parse valid or invalid utf-8} { - string length [encoding convertfrom utf-8 "\xC0\x81"] + string length [encoding convertfrom utf-8 "\xC0\x81" -nothrow] } 2 test encoding-24.6 {Parse valid or invalid utf-8} { - string length [encoding convertfrom utf-8 "\xC1\xBF"] + string length [encoding convertfrom utf-8 "\xC1\xBF" -nothrow] } 2 test encoding-24.7 {Parse valid or invalid utf-8} { string length [encoding convertfrom utf-8 "\xC2\x80"] } 1 test encoding-24.8 {Parse valid or invalid utf-8} { - string length [encoding convertfrom utf-8 "\xE0\x80\x80"] + string length [encoding convertfrom utf-8 "\xE0\x80\x80" -nothrow] } 3 test encoding-24.9 {Parse valid or invalid utf-8} { - string length [encoding convertfrom utf-8 "\xE0\x9F\xBF"] + string length [encoding convertfrom utf-8 "\xE0\x9F\xBF" -nothrow] } 3 test encoding-24.10 {Parse valid or invalid utf-8} { string length [encoding convertfrom utf-8 "\xE0\xA0\x80"] } 1 test encoding-24.11 {Parse valid or invalid utf-8} { - string length [encoding convertfrom utf-8 "\xEF\xBF\xBF"] + string length [encoding convertfrom utf-8 "\xEF\xBF\xBF" -nothrow] } 1 test encoding-24.12 {Parse valid or invalid utf-8} { string length [encoding convertfrom utf-8 "\xC0\x80" -stoponerror] @@ -833,7 +833,7 @@ test encoding-28.0 {all encodings load} -body { set string hello foreach name [encoding names] { incr count - encoding convertto $name $string + encoding convertto $name $string -nothrow # discard the cached internal representation of Tcl_Encoding # Unfortunately, without this, encoding 2-1 fails. diff --git a/tests/http.test b/tests/http.test index 2fd5af4..1275984 100644 --- a/tests/http.test +++ b/tests/http.test @@ -31,6 +31,8 @@ if {[catch {package require http 2} version]} { } } +testConstraint nodep [info exists tcl_precision] + proc bgerror {args} { global errorInfo puts stderr "http.test bgerror" @@ -661,7 +663,7 @@ test http-7.3 {http::formatQuery} -setup { } -cleanup { http::config -urlencoding $enc } -result "can't read \"formMap(∈)\": no such element in array" -test http-7.4 {http::formatQuery} -setup { +test http-7.4 {http::formatQuery} -constraints nodep -setup { set enc [http::config -urlencoding] } -body { # this would be reverting to http <=2.4 behavior w/o errors diff --git a/tests/io.test b/tests/io.test index e0a2389..329d041 100644 --- a/tests/io.test +++ b/tests/io.test @@ -48,6 +48,7 @@ testConstraint testservicemode [llength [info commands testservicemode]] testConstraint notWinCI [expr { $::tcl_platform(platform) ne "windows" || ![info exists ::env(CI)]}] testConstraint notOSX [expr {$::tcl_platform(os) ne "Darwin"}] +testConstraint nodep [info exists tcl_precision] # You need a *very* special environment to do some tests. In # particular, many file systems do not support large-files... @@ -268,7 +269,7 @@ test io-3.3 {WriteChars: compatibility with WriteBytes: flush on line} { close $f set x } "\r\n12" -test io-3.4 {WriteChars: loop over stage buffer} { +test io-3.4 {WriteChars: loop over stage buffer} nodep { # stage buffer maps to more than can be queued at once. set f [open $path(test1) w] @@ -278,7 +279,7 @@ test io-3.4 {WriteChars: loop over stage buffer} { close $f lappend x [contents $path(test1)] } [list "!)!)!)!)!)!)!)!)" "!)!)!)!)!)!)!)!)!)!)!)!)!)!)!)"] -test io-3.5 {WriteChars: saved != 0} { +test io-3.5 {WriteChars: saved != 0} nodep { # Bytes produced by UtfToExternal from end of last channel buffer # had to be moved to beginning of next channel buffer to preserve # requested buffersize. @@ -307,7 +308,7 @@ test io-3.6 {WriteChars: (stageRead + dstWrote == 0)} { close $f lappend x [contents $path(test1)] } [list "12345678901234\x82\x60" "12345678901234\x82\x60\x82\x61"] -test io-3.7 {WriteChars: (bufPtr->nextAdded > bufPtr->length)} { +test io-3.7 {WriteChars: (bufPtr->nextAdded > bufPtr->length)} nodep { # When translating UTF-8 to external, the produced bytes went past end # of the channel buffer. This is done purpose -- we then truncate the # bytes at the end of the partial character to preserve the requested @@ -1532,7 +1533,7 @@ test io-12.8 {ReadChars: multibyte chars split} { close $f scan [string index $in end] %c } 160 -test io-12.9 {ReadChars: multibyte chars split} { +test io-12.9 {ReadChars: multibyte chars split} nodep { set f [open $path(test1) w] fconfigure $f -translation binary puts -nonewline $f [string repeat a 9]\xC2 @@ -1543,7 +1544,7 @@ test io-12.9 {ReadChars: multibyte chars split} { close $f scan [string index $in end] %c } 194 -test io-12.10 {ReadChars: multibyte chars split} { +test io-12.10 {ReadChars: multibyte chars split} nodep { set f [open $path(test1) w] fconfigure $f -translation binary puts -nonewline $f [string repeat a 9]\xC2 diff --git a/tests/main.test b/tests/main.test index 2d3f63c..1480bc2 100644 --- a/tests/main.test +++ b/tests/main.test @@ -5,6 +5,8 @@ if {"::tcltest" ni [namespace children]} { namespace import -force ::tcltest::* } +testConstraint nodep [info exists tcl_precision] + namespace eval ::tcl::test::main { namespace import ::tcltest::* @@ -143,7 +145,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-1.8 { Tcl_Main: startup script - -encoding option - mismatched encodings } -constraints { - stdio + stdio nodep } -setup { set script [makeFile {} script] file delete $script diff --git a/tests/safe.test b/tests/safe.test index e2a9b83..b6668d7 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -1267,7 +1267,7 @@ test safe-11.7 {testing safe encoding} -setup { interp eval $i encoding convertfrom } -returnCodes error -cleanup { safe::interpDelete $i -} -result {wrong # args: should be "encoding convertfrom ?encoding? data ?-stoponerror?"} +} -result {wrong # args: should be "encoding convertfrom ?encoding? data ?-stoponerror|-nothrow?"} test safe-11.7.1 {testing safe encoding} -setup { set i [safe::interpCreate] } -body { @@ -1276,7 +1276,7 @@ test safe-11.7.1 {testing safe encoding} -setup { } -returnCodes ok -match glob -cleanup { unset -nocomplain m o safe::interpDelete $i -} -result {wrong # args: should be "encoding convertfrom ?encoding? data ?-stoponerror?" +} -result {wrong # args: should be "encoding convertfrom ?encoding? data ?-stoponerror|-nothrow?" while executing "encoding convertfrom" invoked from within @@ -1289,7 +1289,7 @@ test safe-11.8 {testing safe encoding} -setup { interp eval $i encoding convertto } -returnCodes error -cleanup { safe::interpDelete $i -} -result {wrong # args: should be "encoding convertto ?encoding? data ?-stoponerror?"} +} -result {wrong # args: should be "encoding convertto ?encoding? data ?-stoponerror|-nothrow?"} test safe-11.8.1 {testing safe encoding} -setup { set i [safe::interpCreate] } -body { @@ -1298,7 +1298,7 @@ test safe-11.8.1 {testing safe encoding} -setup { } -returnCodes ok -match glob -cleanup { unset -nocomplain m o safe::interpDelete $i -} -result {wrong # args: should be "encoding convertto ?encoding? data ?-stoponerror?" +} -result {wrong # args: should be "encoding convertto ?encoding? data ?-stoponerror|-nothrow?" while executing "encoding convertto" invoked from within diff --git a/tests/source.test b/tests/source.test index eee03ec..1748a70 100644 --- a/tests/source.test +++ b/tests/source.test @@ -20,6 +20,8 @@ if {[catch {package require tcltest 2.5}]} { namespace eval ::tcl::test::source { namespace import ::tcltest::* +testConstraint nodep [info exists tcl_precision] + test source-1.1 {source command} -setup { set x "old x value" set y "old y value" @@ -275,7 +277,7 @@ test source-7.5 {source -encoding: correct operation} -setup { removeFile source.file rename € {} } -result foo -test source-7.6 {source -encoding: mismatch encoding error} -setup { +test source-7.6 {source -encoding: mismatch encoding error} -constraints nodep -setup { set sourcefile [makeFile {} source.file] file delete $sourcefile set f [open $sourcefile w] -- cgit v0.12 From 684b9f01af31b898f57e7f05934043893186afc2 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 1 Apr 2021 14:55:22 +0000 Subject: Set errorcode for STOPONERROR --- generic/tclCmdAH.c | 14 +++++++++++--- 1 file changed, 11 insertions(+), 3 deletions(-) diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index ca8e939..cb5ef01 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -600,8 +600,12 @@ EncodingConvertfromObjCmd( result = Tcl_ExternalToUtfDStringEx(encoding, bytesPtr, length, stopOnError ? TCL_ENCODING_STOPONERROR : TCL_ENCODING_NO_THROW, &ds); if (stopOnError && (result != (size_t)-1)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf("unexpected byte at index %" - TCL_LL_MODIFIER "u: '%c' (\\x%X)", (long long)result, UCHAR(bytesPtr[result]), UCHAR(bytesPtr[result]))); + char buf[TCL_INTEGER_SPACE]; + sprintf(buf, "%" TCL_Z_MODIFIER "u", result); + Tcl_SetObjResult(interp, Tcl_ObjPrintf("unexpected byte at index %" + TCL_Z_MODIFIER "u: '%c' (\\x%X)", result, UCHAR(bytesPtr[result]), UCHAR(bytesPtr[result]))); + Tcl_SetErrorCode(interp, "TCL", "ENCODING", "STOPONERROR", + buf, NULL); Tcl_DStringFree(&ds); return TCL_ERROR; } @@ -696,9 +700,13 @@ EncodingConverttoObjCmd( if (stopOnError && (result != (size_t)-1)) { size_t pos = Tcl_NumUtfChars(stringPtr, result); int ucs4; + char buf[TCL_INTEGER_SPACE]; TclUtfToUCS4(&stringPtr[result], &ucs4); + sprintf(buf, "%" TCL_Z_MODIFIER "u", result); Tcl_SetObjResult(interp, Tcl_ObjPrintf("unexpected character at index %" - TCL_LL_MODIFIER "u: '%c' (U+%06X)", (long long)pos, ucs4, ucs4)); + TCL_Z_MODIFIER "u: '%c' (U+%06X)", pos, ucs4, ucs4)); + Tcl_SetErrorCode(interp, "TCL", "ENCODING", "STOPONERROR", + buf, NULL); Tcl_DStringFree(&ds); return TCL_ERROR; } -- 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 06c51c6b90d0f09d4b7cebd7a4018e9ca5dacd9f Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 30 Apr 2021 13:39:35 +0000 Subject: More test-cases --- tests/encoding.test | 28 +++++++++++++++++++++++++++- 1 file changed, 27 insertions(+), 1 deletion(-) diff --git a/tests/encoding.test b/tests/encoding.test index 195fc25..5471e0b 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -600,7 +600,33 @@ test encoding-24.10 {Parse valid or invalid utf-8} { test encoding-24.11 {Parse valid or invalid utf-8} { string length [encoding convertfrom utf-8 "\xEF\xBF\xBF" -nothrow] } 1 - +test encoding-24.12 {Parse valid or invalid utf-8} { + string length [encoding convertfrom utf-8 "\xC0\x80" -stoponerror] +} 1 +test encoding-24.13 {Parse valid or invalid utf-8} -body { + encoding convertfrom utf-8 "\xC0\x81" -stoponerror +} -returnCodes 1 -result {unexpected byte at index 0: 'À' (\xC0)} +test encoding-24.14 {Parse valid or invalid utf-8} -body { + encoding convertfrom utf-8 "\xC1\xBF" -stoponerror +} -returnCodes 1 -result {unexpected byte at index 0: 'Á' (\xC1)} +test encoding-24.15 {Parse valid or invalid utf-8} { + string length [encoding convertfrom utf-8 "\xC2\x80" -stoponerror] +} 1 +test encoding-24.16 {Parse valid or invalid utf-8} -body { + encoding convertfrom utf-8 "Z\xE0\x80" -stoponerror +} -returnCodes 1 -result {unexpected byte at index 1: 'à' (\xE0)} +test encoding-24.17 {Parse valid or invalid utf-8} -constraints testbytestring -body { + encoding convertto utf-8 [testbytestring "Z\u4343\x80"] -stoponerror +} -returnCodes 1 -result {expected byte sequence but character 1 was '䍃€' (U+004343)} +test encoding-24.18 {Parse valid or invalid utf-8} -constraints testbytestring -body { + encoding convertto utf-8 [testbytestring "Z\xE0\x80"] -stoponerror +} -result "Z\xC3\xA0\xE2\x82\xAC" +test encoding-24.19 {Parse valid or invalid utf-8} -constraints testbytestring -body { + encoding convertto utf-8 [testbytestring "Z\xE0\x80xxxxxx"] -stoponerror +} -result "Z\xC3\xA0\xE2\x82\xACxxxxxx" +test encoding-24.20 {Parse valid or invalid utf-8} -constraints testbytestring -body { + encoding convertto utf-8 "ZX\uD800" -stoponerror +} -returnCodes 1 -match glob -result "unexpected character at index 2: '\uD800' (U+00D800)" file delete [file join [temporaryDirectory] iso2022.txt] # -- cgit v0.12 From 9e781ffb02d3f384c1123ddcb6f96944cc4dc3ef Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 6 May 2021 11:35:39 +0000 Subject: Make ?-stoponerror|-nothrow? argument first in stead of last for encoding convertto/convertfrom --- generic/tclCmdAH.c | 16 +++++++-------- tests/cmdAH.test | 4 ++-- tests/encoding.test | 58 ++++++++++++++++++++++++++--------------------------- tests/safe.test | 8 ++++---- 4 files changed, 43 insertions(+), 43 deletions(-) diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index cb5ef01..682ba3f 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -557,12 +557,12 @@ EncodingConvertfromObjCmd( encoding = Tcl_GetEncoding(interp, NULL); data = objv[1]; } else if ((unsigned)(objc - 3) < 2) { - if (Tcl_GetEncodingFromObj(interp, objv[1], &encoding) != TCL_OK) { + if (Tcl_GetEncodingFromObj(interp, objv[objc - 2], &encoding) != TCL_OK) { return TCL_ERROR; } - data = objv[2]; + data = objv[objc - 1]; if (objc > 3) { - stopOnError = Tcl_GetString(objv[3]); + stopOnError = Tcl_GetString(objv[1]); if (!stopOnError[0]) { #if TCL_MAJOR_VERSION < 9 && !defined(TCL_NO_DEPRECATED) stopOnError = NULL; @@ -582,7 +582,7 @@ EncodingConvertfromObjCmd( } } else { encConvFromError: - Tcl_WrongNumArgs(interp, 1, objv, "?encoding? data ?-stoponerror|-nothrow?"); + Tcl_WrongNumArgs(interp, 1, objv, "?-stoponerror|-nothrow? ?encoding? data"); return TCL_ERROR; } @@ -661,12 +661,12 @@ EncodingConverttoObjCmd( encoding = Tcl_GetEncoding(interp, NULL); data = objv[1]; } else if ((unsigned)(objc - 3) < 2) { - if (Tcl_GetEncodingFromObj(interp, objv[1], &encoding) != TCL_OK) { + if (Tcl_GetEncodingFromObj(interp, objv[objc - 2], &encoding) != TCL_OK) { return TCL_ERROR; } - data = objv[2]; + data = objv[objc - 1]; if (objc > 3) { - stopOnError = Tcl_GetString(objv[3]); + stopOnError = Tcl_GetString(objv[1]); if (!stopOnError[0]) { #if TCL_MAJOR_VERSION < 9 && !defined(TCL_NO_DEPRECATED) stopOnError = NULL; @@ -686,7 +686,7 @@ EncodingConverttoObjCmd( } } else { encConvToError: - Tcl_WrongNumArgs(interp, 1, objv, "?encoding? data ?-stoponerror|-nothrow?"); + Tcl_WrongNumArgs(interp, 1, objv, "?-stoponerror|-nothrow? ?encoding? data"); return TCL_ERROR; } diff --git a/tests/cmdAH.test b/tests/cmdAH.test index e9973a9..5cf8fac 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -178,7 +178,7 @@ test cmdAH-4.2 {Tcl_EncodingObjCmd} -returnCodes error -body { } -result {unknown or ambiguous subcommand "foo": must be convertfrom, convertto, dirs, names, or system} test cmdAH-4.3 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding convertto -} -result {wrong # args: should be "encoding convertto ?encoding? data ?-stoponerror|-nothrow?"} +} -result {wrong # args: should be "encoding convertto ?-stoponerror|-nothrow? ?encoding? data"} test cmdAH-4.4 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding convertto foo bar } -result {unknown encoding "foo"} @@ -200,7 +200,7 @@ test cmdAH-4.6 {Tcl_EncodingObjCmd} -setup { } -result 8C test cmdAH-4.7 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding convertfrom -} -result {wrong # args: should be "encoding convertfrom ?encoding? data ?-stoponerror|-nothrow?"} +} -result {wrong # args: should be "encoding convertfrom ?-stoponerror|-nothrow? ?encoding? data"} test cmdAH-4.8 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding convertfrom foo bar } -result {unknown encoding "foo"} diff --git a/tests/encoding.test b/tests/encoding.test index 5471e0b..91fb1ec 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -291,7 +291,7 @@ test encoding-11.9 {encoding: extended Unicode UTF-16} { test encoding-12.1 {LoadTableEncoding: normal encoding} { set x [encoding convertto iso8859-3 Ġ] - append x [encoding convertto iso8859-3 Õ -nothrow] + append x [encoding convertto -nothrow iso8859-3 Õ] append x [encoding convertfrom iso8859-3 Õ] } "Õ?Ġ" test encoding-12.2 {LoadTableEncoding: single-byte encoding} { @@ -340,67 +340,67 @@ test encoding-15.5 {UtfToUtfProc emoji character input} { } "4 😂" test encoding-15.6 {UtfToUtfProc emoji character output} { set x \uDE02\uD83D\uDE02\uD83D - set y [encoding convertto utf-8 \uDE02\uD83D\uDE02\uD83D -nothrow] + set y [encoding convertto -nothrow utf-8 \uDE02\uD83D\uDE02\uD83D] binary scan $y H* z list [string length $y] $z } {10 efbfbdf09f9882efbfbd} test encoding-15.7 {UtfToUtfProc emoji character output} { set x \uDE02\uD83D\uD83D - set y [encoding convertto utf-8 \uDE02\uD83D\uD83D -nothrow] + set y [encoding convertto -nothrow utf-8 \uDE02\uD83D\uD83D] binary scan $y H* z list [string length $x] [string length $y] $z } {3 9 efbfbdefbfbdefbfbd} test encoding-15.8 {UtfToUtfProc emoji character output} { set x \uDE02\uD83Dé - set y [encoding convertto utf-8 \uDE02\uD83Dé -nothrow] + set y [encoding convertto -nothrow utf-8 \uDE02\uD83Dé] binary scan $y H* z list [string length $x] [string length $y] $z } {3 8 efbfbdefbfbdc3a9} test encoding-15.9 {UtfToUtfProc emoji character output} { set x \uDE02\uD83DX - set y [encoding convertto utf-8 \uDE02\uD83DX -nothrow] + set y [encoding convertto -nothrow utf-8 \uDE02\uD83DX] binary scan $y H* z list [string length $x] [string length $y] $z } {3 7 efbfbdefbfbd58} test encoding-15.10 {UtfToUtfProc high surrogate character output} { set x \uDE02é - set y [encoding convertto utf-8 \uDE02é -nothrow] + set y [encoding convertto -nothrow utf-8 \uDE02é] binary scan $y H* z list [string length $x] [string length $y] $z } {2 5 efbfbdc3a9} test encoding-15.11 {UtfToUtfProc low surrogate character output} { set x \uDA02é - set y [encoding convertto utf-8 \uDA02é -nothrow] + set y [encoding convertto -nothrow utf-8 \uDA02é] binary scan $y H* z list [string length $x] [string length $y] $z } {2 5 efbfbdc3a9} test encoding-15.12 {UtfToUtfProc high surrogate character output} { set x \uDE02Y - set y [encoding convertto utf-8 \uDE02Y -nothrow] + set y [encoding convertto -nothrow utf-8 \uDE02Y] binary scan $y H* z list [string length $x] [string length $y] $z } {2 4 efbfbd59} test encoding-15.13 {UtfToUtfProc low surrogate character output} { set x \uDA02Y - set y [encoding convertto utf-8 \uDA02Y -nothrow] + set y [encoding convertto -nothrow utf-8 \uDA02Y] binary scan $y H* z list [string length $x] [string length $y] $z } {2 4 efbfbd59} test encoding-15.14 {UtfToUtfProc high surrogate character output} { set x \uDE02 - set y [encoding convertto utf-8 \uDE02 -nothrow] + set y [encoding convertto -nothrow utf-8 \uDE02] binary scan $y H* z list [string length $x] [string length $y] $z } {1 3 efbfbd} test encoding-15.15 {UtfToUtfProc low surrogate character output} { set x \uDA02 - set y [encoding convertto utf-8 \uDA02 -nothrow] + set y [encoding convertto -nothrow utf-8 \uDA02] binary scan $y H* z list [string length $x] [string length $y] $z } {1 3 efbfbd} test encoding-15.16 {UtfToUtfProc: Invalid 4-byte UTF-8, see [ed29806ba]} { set x \xF0\xA0\xA1\xC2 - set y [encoding convertfrom utf-8 \xF0\xA0\xA1\xC2 -nothrow] + set y [encoding convertfrom -nothrow utf-8 \xF0\xA0\xA1\xC2] list [string length $x] $y } "4 \xF0\xA0\xA1\xC2" test encoding-15.17 {UtfToUtfProc emoji character output} { @@ -458,10 +458,10 @@ test encoding-17.2 {UtfToUcs2Proc} -body { encoding convertfrom utf-16 [encoding convertto ucs-2 "\U460DC"] } -result "\uFFFD" test encoding-17.3 {UtfToUtf16Proc} -body { - encoding convertto utf-16be "\uDCDC" -nothrow + encoding convertto -nothrow utf-16be "\uDCDC" } -result "\xFF\xFD" test encoding-17.4 {UtfToUtf16Proc} -body { - encoding convertto utf-16le "\uD8D8" -nothrow + encoding convertto -nothrow utf-16le "\uD8D8" } -result "\xFD\xFF" test encoding-18.1 {TableToUtfProc} { @@ -580,52 +580,52 @@ test encoding-24.4 {Parse valid or invalid utf-8} { string length [encoding convertfrom utf-8 "\xC0\x80"] } 1 test encoding-24.5 {Parse valid or invalid utf-8} { - string length [encoding convertfrom utf-8 "\xC0\x81" -nothrow] + string length [encoding convertfrom -nothrow utf-8 "\xC0\x81"] } 2 test encoding-24.6 {Parse valid or invalid utf-8} { - string length [encoding convertfrom utf-8 "\xC1\xBF" -nothrow] + string length [encoding convertfrom -nothrow utf-8 "\xC1\xBF"] } 2 test encoding-24.7 {Parse valid or invalid utf-8} { string length [encoding convertfrom utf-8 "\xC2\x80"] } 1 test encoding-24.8 {Parse valid or invalid utf-8} { - string length [encoding convertfrom utf-8 "\xE0\x80\x80" -nothrow] + string length [encoding convertfrom -nothrow utf-8 "\xE0\x80\x80"] } 3 test encoding-24.9 {Parse valid or invalid utf-8} { - string length [encoding convertfrom utf-8 "\xE0\x9F\xBF" -nothrow] + string length [encoding convertfrom -nothrow utf-8 "\xE0\x9F\xBF"] } 3 test encoding-24.10 {Parse valid or invalid utf-8} { string length [encoding convertfrom utf-8 "\xE0\xA0\x80"] } 1 test encoding-24.11 {Parse valid or invalid utf-8} { - string length [encoding convertfrom utf-8 "\xEF\xBF\xBF" -nothrow] + string length [encoding convertfrom -nothrow utf-8 "\xEF\xBF\xBF"] } 1 test encoding-24.12 {Parse valid or invalid utf-8} { - string length [encoding convertfrom utf-8 "\xC0\x80" -stoponerror] + string length [encoding convertfrom -stoponerror utf-8 "\xC0\x80"] } 1 test encoding-24.13 {Parse valid or invalid utf-8} -body { - encoding convertfrom utf-8 "\xC0\x81" -stoponerror + encoding convertfrom -stoponerror utf-8 "\xC0\x81" } -returnCodes 1 -result {unexpected byte at index 0: 'À' (\xC0)} test encoding-24.14 {Parse valid or invalid utf-8} -body { - encoding convertfrom utf-8 "\xC1\xBF" -stoponerror + encoding convertfrom -stoponerror utf-8 "\xC1\xBF" } -returnCodes 1 -result {unexpected byte at index 0: 'Á' (\xC1)} test encoding-24.15 {Parse valid or invalid utf-8} { - string length [encoding convertfrom utf-8 "\xC2\x80" -stoponerror] + string length [encoding convertfrom -stoponerror utf-8 "\xC2\x80"] } 1 test encoding-24.16 {Parse valid or invalid utf-8} -body { - encoding convertfrom utf-8 "Z\xE0\x80" -stoponerror + encoding convertfrom -stoponerror utf-8 "Z\xE0\x80" } -returnCodes 1 -result {unexpected byte at index 1: 'à' (\xE0)} test encoding-24.17 {Parse valid or invalid utf-8} -constraints testbytestring -body { - encoding convertto utf-8 [testbytestring "Z\u4343\x80"] -stoponerror + encoding convertto -stoponerror utf-8 [testbytestring "Z\u4343\x80"] } -returnCodes 1 -result {expected byte sequence but character 1 was '䍃€' (U+004343)} test encoding-24.18 {Parse valid or invalid utf-8} -constraints testbytestring -body { - encoding convertto utf-8 [testbytestring "Z\xE0\x80"] -stoponerror + encoding convertto -stoponerror utf-8 [testbytestring "Z\xE0\x80"] } -result "Z\xC3\xA0\xE2\x82\xAC" test encoding-24.19 {Parse valid or invalid utf-8} -constraints testbytestring -body { - encoding convertto utf-8 [testbytestring "Z\xE0\x80xxxxxx"] -stoponerror + encoding convertto -stoponerror utf-8 [testbytestring "Z\xE0\x80xxxxxx"] } -result "Z\xC3\xA0\xE2\x82\xACxxxxxx" test encoding-24.20 {Parse valid or invalid utf-8} -constraints testbytestring -body { - encoding convertto utf-8 "ZX\uD800" -stoponerror + encoding convertto -stoponerror utf-8 "ZX\uD800" } -returnCodes 1 -match glob -result "unexpected character at index 2: '\uD800' (U+00D800)" file delete [file join [temporaryDirectory] iso2022.txt] @@ -781,7 +781,7 @@ test encoding-28.0 {all encodings load} -body { set string hello foreach name [encoding names] { incr count - encoding convertto $name $string -nothrow + encoding convertto -nothrow $name $string # discard the cached internal representation of Tcl_Encoding # Unfortunately, without this, encoding 2-1 fails. diff --git a/tests/safe.test b/tests/safe.test index e7e427b..2ea32f5 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -1269,7 +1269,7 @@ test safe-11.7 {testing safe encoding} -setup { interp eval $i encoding convertfrom } -returnCodes error -cleanup { safe::interpDelete $i -} -result {wrong # args: should be "encoding convertfrom ?encoding? data ?-stoponerror|-nothrow?"} +} -result {wrong # args: should be "encoding convertfrom ?-stoponerror|-nothrow? ?encoding? data"} test safe-11.7.1 {testing safe encoding} -setup { set i [safe::interpCreate] } -body { @@ -1278,7 +1278,7 @@ test safe-11.7.1 {testing safe encoding} -setup { } -returnCodes ok -match glob -cleanup { unset -nocomplain m o safe::interpDelete $i -} -result {wrong # args: should be "encoding convertfrom ?encoding? data ?-stoponerror|-nothrow?" +} -result {wrong # args: should be "encoding convertfrom ?-stoponerror|-nothrow? ?encoding? data" while executing "encoding convertfrom" invoked from within @@ -1291,7 +1291,7 @@ test safe-11.8 {testing safe encoding} -setup { interp eval $i encoding convertto } -returnCodes error -cleanup { safe::interpDelete $i -} -result {wrong # args: should be "encoding convertto ?encoding? data ?-stoponerror|-nothrow?"} +} -result {wrong # args: should be "encoding convertto ?-stoponerror|-nothrow? ?encoding? data"} test safe-11.8.1 {testing safe encoding} -setup { set i [safe::interpCreate] } -body { @@ -1300,7 +1300,7 @@ test safe-11.8.1 {testing safe encoding} -setup { } -returnCodes ok -match glob -cleanup { unset -nocomplain m o safe::interpDelete $i -} -result {wrong # args: should be "encoding convertto ?encoding? data ?-stoponerror|-nothrow?" +} -result {wrong # args: should be "encoding convertto ?-stoponerror|-nothrow? ?encoding? data" while executing "encoding convertto" invoked from within -- cgit v0.12 From 82b2bfa1b8f90760f53b543c9dc7e4fa7c2e3510 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 6 May 2021 14:16:58 +0000 Subject: Remove character/byte value from error-message, only use hex here. --- generic/tclCmdAH.c | 4 ++-- tests/encoding.test | 8 ++++---- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 682ba3f..1361f11 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -603,7 +603,7 @@ EncodingConvertfromObjCmd( char buf[TCL_INTEGER_SPACE]; sprintf(buf, "%" TCL_Z_MODIFIER "u", result); Tcl_SetObjResult(interp, Tcl_ObjPrintf("unexpected byte at index %" - TCL_Z_MODIFIER "u: '%c' (\\x%X)", result, UCHAR(bytesPtr[result]), UCHAR(bytesPtr[result]))); + TCL_Z_MODIFIER "u: '\\x%X'", result, UCHAR(bytesPtr[result]))); Tcl_SetErrorCode(interp, "TCL", "ENCODING", "STOPONERROR", buf, NULL); Tcl_DStringFree(&ds); @@ -704,7 +704,7 @@ EncodingConverttoObjCmd( TclUtfToUCS4(&stringPtr[result], &ucs4); sprintf(buf, "%" TCL_Z_MODIFIER "u", result); Tcl_SetObjResult(interp, Tcl_ObjPrintf("unexpected character at index %" - TCL_Z_MODIFIER "u: '%c' (U+%06X)", pos, ucs4, ucs4)); + TCL_Z_MODIFIER "u: 'U+%06X'", pos, ucs4)); Tcl_SetErrorCode(interp, "TCL", "ENCODING", "STOPONERROR", buf, NULL); Tcl_DStringFree(&ds); diff --git a/tests/encoding.test b/tests/encoding.test index 91fb1ec..355c2ec 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -605,16 +605,16 @@ test encoding-24.12 {Parse valid or invalid utf-8} { } 1 test encoding-24.13 {Parse valid or invalid utf-8} -body { encoding convertfrom -stoponerror utf-8 "\xC0\x81" -} -returnCodes 1 -result {unexpected byte at index 0: 'À' (\xC0)} +} -returnCodes 1 -result {unexpected byte at index 0: '\xC0'} test encoding-24.14 {Parse valid or invalid utf-8} -body { encoding convertfrom -stoponerror utf-8 "\xC1\xBF" -} -returnCodes 1 -result {unexpected byte at index 0: 'Á' (\xC1)} +} -returnCodes 1 -result {unexpected byte at index 0: '\xC1'} test encoding-24.15 {Parse valid or invalid utf-8} { string length [encoding convertfrom -stoponerror utf-8 "\xC2\x80"] } 1 test encoding-24.16 {Parse valid or invalid utf-8} -body { encoding convertfrom -stoponerror utf-8 "Z\xE0\x80" -} -returnCodes 1 -result {unexpected byte at index 1: 'à' (\xE0)} +} -returnCodes 1 -result {unexpected byte at index 1: '\xE0'} test encoding-24.17 {Parse valid or invalid utf-8} -constraints testbytestring -body { encoding convertto -stoponerror utf-8 [testbytestring "Z\u4343\x80"] } -returnCodes 1 -result {expected byte sequence but character 1 was '䍃€' (U+004343)} @@ -626,7 +626,7 @@ test encoding-24.19 {Parse valid or invalid utf-8} -constraints testbytestring - } -result "Z\xC3\xA0\xE2\x82\xACxxxxxx" test encoding-24.20 {Parse valid or invalid utf-8} -constraints testbytestring -body { encoding convertto -stoponerror utf-8 "ZX\uD800" -} -returnCodes 1 -match glob -result "unexpected character at index 2: '\uD800' (U+00D800)" +} -returnCodes 1 -match glob -result "unexpected character at index 2: 'U+00D800'" file delete [file join [temporaryDirectory] iso2022.txt] # -- cgit v0.12 From 99994365ea8c04611e93f3108f4a7d8d4e1ca49f Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 7 May 2021 09:50:13 +0000 Subject: Parse simplifications and better errormessage. Not 100% correct yet --- generic/tclCmdAH.c | 36 +++++++++++++----------------------- tests/encoding.test | 6 +++--- 2 files changed, 16 insertions(+), 26 deletions(-) diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 1361f11..9cd8c12 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -550,24 +550,24 @@ EncodingConvertfromObjCmd( Tcl_Encoding encoding; /* Encoding to use */ int length; /* Length of the byte array being converted */ const char *bytesPtr; /* Pointer to the first byte of the array */ +#if TCL_MAJOR_VERSION > 8 || defined(TCL_NO_DEPRECATED) + const char *stopOnError = ""; +#else const char *stopOnError = NULL; +#endif size_t result; if (objc == 2) { encoding = Tcl_GetEncoding(interp, NULL); data = objv[1]; - } else if ((unsigned)(objc - 3) < 2) { + } else if ((unsigned)(objc - 2) < 3) { if (Tcl_GetEncodingFromObj(interp, objv[objc - 2], &encoding) != TCL_OK) { return TCL_ERROR; } data = objv[objc - 1]; if (objc > 3) { stopOnError = Tcl_GetString(objv[1]); - if (!stopOnError[0]) { -#if TCL_MAJOR_VERSION < 9 && !defined(TCL_NO_DEPRECATED) - stopOnError = NULL; -#endif - } else if (stopOnError[0] == '-' && stopOnError[1] == 'n' + if (stopOnError[0] == '-' && stopOnError[1] == 'n' && !strncmp(stopOnError, "-nothrow", strlen(stopOnError))) { stopOnError = NULL; } else if (stopOnError[0] == '-' && stopOnError[1] == 's' @@ -575,10 +575,6 @@ EncodingConvertfromObjCmd( } else { goto encConvFromError; } -#if TCL_MAJOR_VERSION > 8 || defined(TCL_NO_DEPRECATED) - } else { - stopOnError = ""; -#endif } } else { encConvFromError: @@ -602,7 +598,7 @@ EncodingConvertfromObjCmd( if (stopOnError && (result != (size_t)-1)) { char buf[TCL_INTEGER_SPACE]; sprintf(buf, "%" TCL_Z_MODIFIER "u", result); - Tcl_SetObjResult(interp, Tcl_ObjPrintf("unexpected byte at index %" + Tcl_SetObjResult(interp, Tcl_ObjPrintf("unexpected byte sequence starting at index %" TCL_Z_MODIFIER "u: '\\x%X'", result, UCHAR(bytesPtr[result]))); Tcl_SetErrorCode(interp, "TCL", "ENCODING", "STOPONERROR", buf, NULL); @@ -653,25 +649,23 @@ EncodingConverttoObjCmd( int length; /* Length of the string being converted */ const char *stringPtr; /* Pointer to the first byte of the string */ size_t result; +#if TCL_MAJOR_VERSION > 8 || defined(TCL_NO_DEPRECATED) + const char *stopOnError = ""; +#else const char *stopOnError = NULL; - - /* TODO - ADJUST OBJ INDICES WHEN ENSEMBLIFYING THIS */ +#endif if (objc == 2) { encoding = Tcl_GetEncoding(interp, NULL); data = objv[1]; - } else if ((unsigned)(objc - 3) < 2) { + } else if ((unsigned)(objc - 2) < 3) { if (Tcl_GetEncodingFromObj(interp, objv[objc - 2], &encoding) != TCL_OK) { return TCL_ERROR; } data = objv[objc - 1]; if (objc > 3) { stopOnError = Tcl_GetString(objv[1]); - if (!stopOnError[0]) { -#if TCL_MAJOR_VERSION < 9 && !defined(TCL_NO_DEPRECATED) - stopOnError = NULL; -#endif - } else if (stopOnError[0] == '-' && stopOnError[1] == 'n' + if (stopOnError[0] == '-' && stopOnError[1] == 'n' && !strncmp(stopOnError, "-nothrow", strlen(stopOnError))) { stopOnError = NULL; } else if (stopOnError[0] == '-' && stopOnError[1] == 's' @@ -679,10 +673,6 @@ EncodingConverttoObjCmd( } else { goto encConvToError; } -#if TCL_MAJOR_VERSION > 8 || defined(TCL_NO_DEPRECATED) - } else { - stopOnError = ""; -#endif } } else { encConvToError: diff --git a/tests/encoding.test b/tests/encoding.test index 355c2ec..d30ef60 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -605,16 +605,16 @@ test encoding-24.12 {Parse valid or invalid utf-8} { } 1 test encoding-24.13 {Parse valid or invalid utf-8} -body { encoding convertfrom -stoponerror utf-8 "\xC0\x81" -} -returnCodes 1 -result {unexpected byte at index 0: '\xC0'} +} -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\xC0'} test encoding-24.14 {Parse valid or invalid utf-8} -body { encoding convertfrom -stoponerror utf-8 "\xC1\xBF" -} -returnCodes 1 -result {unexpected byte at index 0: '\xC1'} +} -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\xC1'} test encoding-24.15 {Parse valid or invalid utf-8} { string length [encoding convertfrom -stoponerror utf-8 "\xC2\x80"] } 1 test encoding-24.16 {Parse valid or invalid utf-8} -body { encoding convertfrom -stoponerror utf-8 "Z\xE0\x80" -} -returnCodes 1 -result {unexpected byte at index 1: '\xE0'} +} -returnCodes 1 -result {unexpected byte sequence starting at index 1: '\xE0'} test encoding-24.17 {Parse valid or invalid utf-8} -constraints testbytestring -body { encoding convertto -stoponerror utf-8 [testbytestring "Z\u4343\x80"] } -returnCodes 1 -result {expected byte sequence but character 1 was '䍃€' (U+004343)} -- cgit v0.12 From c1591561bfc41b9b4bd3f4bf09929d419325c9ef Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 7 May 2021 13:44:53 +0000 Subject: doc fix --- doc/Encoding.3 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/doc/Encoding.3 b/doc/Encoding.3 index d853977..73ad65d 100644 --- a/doc/Encoding.3 +++ b/doc/Encoding.3 @@ -25,13 +25,13 @@ int char * \fBTcl_ExternalToUtfDString\fR(\fIencoding, src, srcLen, dstPtr\fR) .sp -char * +size_t \fBTcl_ExternalToUtfDStringEx\fR(\fIencoding, src, srcLen, flags, dstPtr\fR) .sp char * \fBTcl_UtfToExternalDString\fR(\fIencoding, src, srcLen, dstPtr\fR) .sp -char * +size_t \fBTcl_UtfToExternalDStringEx\fR(\fIencoding, src, srcLen, flags, dstPtr\fR) .sp int @@ -261,8 +261,8 @@ a pointer to the value stored in the DString. .PP \fBTcl_UtfToExternalDStringEx\fR is the same as \fBTcl_UtfToExternalDString\fR, but it has an additional flags parameter. The return value is the index of -the first byte in the input string causing a conversion error. -Or (size_t)-1 if all is OK. +the first byte of an utf-8 byte-sequence in the input string causing a +conversion error. Or (size_t)-1 if all is OK. .PP \fBTcl_UtfToExternal\fR converts a source buffer \fIsrc\fR from UTF-8 into the specified \fIencoding\fR. Up to \fIsrcLen\fR bytes are converted from -- cgit v0.12 From c19b90133a56c0adc06f764732d80720e60747a3 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 7 May 2021 13:55:14 +0000 Subject: Double definition of TCL_ENCODING_MODIFIED and another doc fix --- doc/string.n | 2 +- generic/tclEncoding.c | 1 - 2 files changed, 1 insertion(+), 2 deletions(-) diff --git a/doc/string.n b/doc/string.n index 6a10da8..f3d7616 100644 --- a/doc/string.n +++ b/doc/string.n @@ -419,7 +419,7 @@ command to convert a string to a known encoding (e.g. "utf-8" or "cesu-8") and then apply \fBstring length\fR to that. .PP .CS -\fBstring length\fR [encoding convertto wtf-8 $theString] +\fBstring length\fR [encoding convertto utf-8 $theString] .CE .RE .TP diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index a53261e..17b00d6 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -512,7 +512,6 @@ FillEncodingFileMap(void) /* Since TCL_ENCODING_MODIFIED is only used for utf-8/cesu-8 and * TCL_ENCODING_LE is only used for utf-16/ucs-2. re-use the same value */ -#define TCL_ENCODING_MODIFIED 0x20 /* Converting NULL bytes to 0xC0 0x80 */ #define TCL_ENCODING_LE TCL_ENCODING_MODIFIED /* Little-endian encoding */ #define TCL_ENCODING_UTF 0x200 /* For UTF-8 encoding, allow 4-byte output sequences */ -- cgit v0.12 From 95cd48673472309ca5a790f3d26e4a137c010a6b Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 14 May 2021 10:52:53 +0000 Subject: One left-over wtf-8 mentioning, which is no longer part of TIP #597 --- generic/tcl.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tcl.h b/generic/tcl.h index a5d0106..759adc9 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -2075,7 +2075,7 @@ typedef struct Tcl_EncodingType { * produced is controlled only by other limiting * factors. * TCL_ENCODING_MODIFIED - Convert NULL bytes to \xC0\x80 in stead of - * 0x00. Only valid for "utf-8", "wtf-8 and "cesu-8". + * 0x00. Only valid for "utf-8" and "cesu-8". * This flag is implicit for external -> internal conversions, * optional for internal -> external conversions. * TCL_ENCODING_NO_THROW - If set, the converter -- cgit v0.12 From b9bd6ffbf8851cfc23fefe5653355b201d12cf83 Mon Sep 17 00:00:00 2001 From: oehhar Date: Wed, 26 May 2021 06:44:40 +0000 Subject: TIP601 encoding stoponerror: document Tcl_ExternalToUtfDStringEx and Tcl_ExternalToUtfDStringEx --- generic/tclEncoding.c | 64 +++++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 62 insertions(+), 2 deletions(-) diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 17b00d6..1e56c12 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -1093,7 +1093,7 @@ Tcl_CreateEncoding( /* *------------------------------------------------------------------------- * - * Tcl_ExternalToUtfDString/Tcl_ExternalToUtfDStringEx -- + * Tcl_ExternalToUtfDString -- * * Convert a source buffer from the specified encoding into UTF-8. If any * of the bytes in the source buffer are invalid or cannot be represented @@ -1125,6 +1125,35 @@ Tcl_ExternalToUtfDString( return Tcl_DStringValue(dstPtr); } + +/* + *------------------------------------------------------------------------- + * + * Tcl_ExternalToUtfDStringEx -- + * + * Convert a source buffer from the specified encoding into UTF-8. +* The parameter flags controls the behavior, if any of the bytes in + * the source buffer are invalid or cannot be represented in utf-8. + * Possible flags values: + * TCLENCODINGSTOPONERROR: don't replace invalid characters/bytes but + * return the first error position (Default in Tcl 9.0). + * TCLENCODINGNO_THROW: replace invalid characters/bytes by a default + * fallback character. Always return -1 (Default in Tcl 8.7). + * TCLENCODINGMODIFIED: convert NULL bytes to \xC0\x80 in stead of 0x00. + * Only valid for "utf-8" and "cesu-8". This flag may be used together + * with the other flags. + * + * Results: + * The converted bytes are stored in the DString, which is then NULL + * terminated in an encoding-specific manner. The return value is + * the error position in the source string or -1 if no conversion error + * is reported. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ size_t Tcl_ExternalToUtfDStringEx( @@ -1303,7 +1332,7 @@ Tcl_ExternalToUtf( /* *------------------------------------------------------------------------- * - * Tcl_UtfToExternalDString/Tcl_UtfToExternalDStringEx -- + * Tcl_UtfToExternalDString -- * * Convert a source buffer from UTF-8 to the specified encoding. If any * of the bytes in the source buffer are invalid or cannot be represented @@ -1335,6 +1364,37 @@ Tcl_UtfToExternalDString( return Tcl_DStringValue(dstPtr); } + +/* + *------------------------------------------------------------------------- + * + * Tcl_UtfToExternalDStringEx -- + * + * Convert a source buffer from UTF-8 to the specified encoding. + * The parameter flags controls the behavior, if any of the bytes in + * the source buffer are invalid or cannot be represented in the + * target encoding. + * Possible flags values: + * TCLENCODINGSTOPONERROR: don't replace invalid characters/bytes but + * return the first error position (Default in Tcl 9.0). + * TCLENCODINGNO_THROW: replace invalid characters/bytes by a default + * fallback character. Always return -1 (Default in Tcl 8.7). + * TCLENCODINGMODIFIED: convert NULL bytes to \xC0\x80 in stead of 0x00. + * Only valid for "utf-8" and "cesu-8". This flag may be used together + * with the other flags. + * + * Results: + * The converted bytes are stored in the DString, which is then NULL + * terminated in an encoding-specific manner. The return value is + * the error position in the source string or -1 if no conversion error + * is reported. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + size_t Tcl_UtfToExternalDStringEx( Tcl_Encoding encoding, /* The encoding for the converted string, or -- cgit v0.12 From 5ab98c9b65c66ac15cafc95755202ac31b237450 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 26 May 2021 08:36:28 +0000 Subject: Add underscores in flag names --- generic/tclEncoding.c | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 1e56c12..7a9f0b7 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -1135,11 +1135,11 @@ Tcl_ExternalToUtfDString( * The parameter flags controls the behavior, if any of the bytes in * the source buffer are invalid or cannot be represented in utf-8. * Possible flags values: - * TCLENCODINGSTOPONERROR: don't replace invalid characters/bytes but + * TCL_ENCODING_STOPONERROR: don't replace invalid characters/bytes but * return the first error position (Default in Tcl 9.0). - * TCLENCODINGNO_THROW: replace invalid characters/bytes by a default + * TCL_ENCODING_NO_THROW: replace invalid characters/bytes by a default * fallback character. Always return -1 (Default in Tcl 8.7). - * TCLENCODINGMODIFIED: convert NULL bytes to \xC0\x80 in stead of 0x00. + * TCL_ENCODING_MODIFIED: convert NULL bytes to \xC0\x80 in stead of 0x00. * Only valid for "utf-8" and "cesu-8". This flag may be used together * with the other flags. * @@ -1375,11 +1375,11 @@ Tcl_UtfToExternalDString( * the source buffer are invalid or cannot be represented in the * target encoding. * Possible flags values: - * TCLENCODINGSTOPONERROR: don't replace invalid characters/bytes but + * TCL_ENCODING_STOPONERROR: don't replace invalid characters/bytes but * return the first error position (Default in Tcl 9.0). - * TCLENCODINGNO_THROW: replace invalid characters/bytes by a default + * TCL_ENCODING_NO_THROW: replace invalid characters/bytes by a default * fallback character. Always return -1 (Default in Tcl 8.7). - * TCLENCODINGMODIFIED: convert NULL bytes to \xC0\x80 in stead of 0x00. + * TCL_ENCODING_MODIFIED: convert NULL bytes to \xC0\x80 in stead of 0x00. * Only valid for "utf-8" and "cesu-8". This flag may be used together * with the other flags. * -- cgit v0.12 From 588e5a48cb262a4fa3d60698be3f1d94434dfcf1 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 26 May 2021 14:04:00 +0000 Subject: Handle the situation when there is "-nothrow" or "-stoponerror" but without providing encoding --- generic/tclCmdAH.c | 77 +++++++++++++++++++++++++++++++---------------------- tests/encoding.test | 6 +++++ 2 files changed, 51 insertions(+), 32 deletions(-) diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 0f9aa27..6549648 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -561,21 +561,26 @@ EncodingConvertfromObjCmd( encoding = Tcl_GetEncoding(interp, NULL); data = objv[1]; } else if ((unsigned)(objc - 2) < 3) { - if (Tcl_GetEncodingFromObj(interp, objv[objc - 2], &encoding) != TCL_OK) { - return TCL_ERROR; - } data = objv[objc - 1]; - if (objc > 3) { - bytesPtr = Tcl_GetString(objv[1]); - if (bytesPtr[0] == '-' && bytesPtr[1] == 'n' - && !strncmp(bytesPtr, "-nothrow", strlen(bytesPtr))) { - flags = TCL_ENCODING_NO_THROW; - } else if (bytesPtr[0] == '-' && bytesPtr[1] == 's' - && !strncmp(bytesPtr, "-stoponerror", strlen(bytesPtr))) { - flags = TCL_ENCODING_STOPONERROR; - } else { - goto encConvFromError; + bytesPtr = Tcl_GetString(objv[1]); + if (bytesPtr[0] == '-' && bytesPtr[1] == 'n' + && !strncmp(bytesPtr, "-nothrow", strlen(bytesPtr))) { + flags = TCL_ENCODING_NO_THROW; + } else if (bytesPtr[0] == '-' && bytesPtr[1] == 's' + && !strncmp(bytesPtr, "-stoponerror", strlen(bytesPtr))) { + flags = TCL_ENCODING_STOPONERROR; + } else if (objc < 4) { + if (Tcl_GetEncodingFromObj(interp, objv[objc - 2], &encoding) != TCL_OK) { + return TCL_ERROR; } + goto encConvFromOK; + } else { + goto encConvFromError; + } + if (objc < 4) { + encoding = Tcl_GetEncoding(interp, NULL); + } else if (Tcl_GetEncodingFromObj(interp, objv[objc - 2], &encoding) != TCL_OK) { + return TCL_ERROR; } } else { encConvFromError: @@ -583,16 +588,18 @@ EncodingConvertfromObjCmd( return TCL_ERROR; } +encConvFromOK: /* * Convert the string into a byte array in 'ds' */ - if (flags & TCL_ENCODING_STOPONERROR) { - bytesPtr = (char *) TclGetBytesFromObj(interp, data, &length); - if (bytesPtr == NULL) { - return TCL_ERROR; - } - } else { +#if !defined(TCL_NO_DEPRECATED) && (TCL_MAJOR_VERSION < 9) + if (!(flags & TCL_ENCODING_STOPONERROR)) { bytesPtr = (char *) Tcl_GetByteArrayFromObj(data, &length); + } else +#endif + bytesPtr = (char *) TclGetBytesFromObj(interp, data, &length); + if (bytesPtr == NULL) { + return TCL_ERROR; } result = Tcl_ExternalToUtfDStringEx(encoding, bytesPtr, length, flags, &ds); @@ -660,21 +667,26 @@ EncodingConverttoObjCmd( encoding = Tcl_GetEncoding(interp, NULL); data = objv[1]; } else if ((unsigned)(objc - 2) < 3) { - if (Tcl_GetEncodingFromObj(interp, objv[objc - 2], &encoding) != TCL_OK) { - return TCL_ERROR; - } data = objv[objc - 1]; - if (objc > 3) { - stringPtr = Tcl_GetString(objv[1]); - if (stringPtr[0] == '-' && stringPtr[1] == 'n' - && !strncmp(stringPtr, "-nothrow", strlen(stringPtr))) { - flags = TCL_ENCODING_NO_THROW; - } else if (stringPtr[0] == '-' && stringPtr[1] == 's' - && !strncmp(stringPtr, "-stoponerror", strlen(stringPtr))) { - flags = TCL_ENCODING_STOPONERROR; - } else { - goto encConvToError; + stringPtr = Tcl_GetString(objv[1]); + if (stringPtr[0] == '-' && stringPtr[1] == 'n' + && !strncmp(stringPtr, "-nothrow", strlen(stringPtr))) { + flags = TCL_ENCODING_NO_THROW; + } else if (stringPtr[0] == '-' && stringPtr[1] == 's' + && !strncmp(stringPtr, "-stoponerror", strlen(stringPtr))) { + flags = TCL_ENCODING_STOPONERROR; + } else if (objc < 4) { + if (Tcl_GetEncodingFromObj(interp, objv[objc - 2], &encoding) != TCL_OK) { + return TCL_ERROR; } + goto encConvToOK; + } else { + goto encConvToError; + } + if (objc < 4) { + encoding = Tcl_GetEncoding(interp, NULL); + } else if (Tcl_GetEncodingFromObj(interp, objv[objc - 2], &encoding) != TCL_OK) { + return TCL_ERROR; } } else { encConvToError: @@ -682,6 +694,7 @@ EncodingConverttoObjCmd( return TCL_ERROR; } +encConvToOK: /* * Convert the string to a byte array in 'ds' */ diff --git a/tests/encoding.test b/tests/encoding.test index d30ef60..55ace7f 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -627,6 +627,12 @@ test encoding-24.19 {Parse valid or invalid utf-8} -constraints testbytestring - test encoding-24.20 {Parse valid or invalid utf-8} -constraints testbytestring -body { encoding convertto -stoponerror utf-8 "ZX\uD800" } -returnCodes 1 -match glob -result "unexpected character at index 2: 'U+00D800'" +test encoding-24.21 {Parse with -nothrow but without providing encoding} { + string length [encoding convertfrom -nothrow "\x20"] +} 1 +test encoding-24.22 {Parse with -nothrow but without providing encoding} { + string length [encoding convertto -nothrow "\x20"] +} 1 file delete [file join [temporaryDirectory] iso2022.txt] # -- cgit v0.12 From 20fcf335945daf5dedf6f10f940026b681dd7f1b Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 26 May 2021 14:10:30 +0000 Subject: More testcases regarding possible parse errors --- tests/encoding.test | 15 ++++++++++++++- 1 file changed, 14 insertions(+), 1 deletion(-) diff --git a/tests/encoding.test b/tests/encoding.test index 55ace7f..bdebad9 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -624,7 +624,7 @@ test encoding-24.18 {Parse valid or invalid utf-8} -constraints testbytestring - test encoding-24.19 {Parse valid or invalid utf-8} -constraints testbytestring -body { encoding convertto -stoponerror utf-8 [testbytestring "Z\xE0\x80xxxxxx"] } -result "Z\xC3\xA0\xE2\x82\xACxxxxxx" -test encoding-24.20 {Parse valid or invalid utf-8} -constraints testbytestring -body { +test encoding-24.20 {Parse valid or invalid utf-8} -body { encoding convertto -stoponerror utf-8 "ZX\uD800" } -returnCodes 1 -match glob -result "unexpected character at index 2: 'U+00D800'" test encoding-24.21 {Parse with -nothrow but without providing encoding} { @@ -633,6 +633,19 @@ test encoding-24.21 {Parse with -nothrow but without providing encoding} { test encoding-24.22 {Parse with -nothrow but without providing encoding} { string length [encoding convertto -nothrow "\x20"] } 1 +test encoding-24.23 {Syntax error, two encodings} -body { + encoding convertfrom iso8859-1 utf-8 "ZX\uD800" +} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertfrom ?-nothrow|-stoponerror? ?encoding? data"} +test encoding-24.24 {Syntax error, two encodings} -body { + encoding convertto iso8859-1 utf-8 "ZX\uD800" +} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertto ?-nothrow|-stoponerror? ?encoding? data"} +test encoding-24.25 {Syntax error, two options} -body { + encoding convertfrom -nothrow -stoponerror "ZX\uD800" +} -returnCodes 1 -result {unknown encoding "-stoponerror"} +test encoding-24.26 {Syntax error, two options} -body { + encoding convertto -nothrow -stoponerror "ZX\uD800" +} -returnCodes 1 -result {unknown encoding "-stoponerror"} + file delete [file join [temporaryDirectory] iso2022.txt] # -- 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 2a56bd9e36e6a9ae0ecc6bfd139cc7951296fc20 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 29 Jul 2021 14:03:30 +0000 Subject: Experiment: Switch tclsh console to UTF-8 by default on Windows, if possible, using the manifest. --- win/tclsh.exe.manifest.in | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/win/tclsh.exe.manifest.in b/win/tclsh.exe.manifest.in index dd8a7c5..8caef97 100644 --- a/win/tclsh.exe.manifest.in +++ b/win/tclsh.exe.manifest.in @@ -31,9 +31,9 @@ - - true + + true + UTF-8 -- 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 36dbbdbb723b994c072318068ca9c78aac8a2bcf Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 1 Aug 2021 11:47:23 +0000 Subject: Turn code snippets in TIP into a branch. --- doc/Class.3 | 15 +++++++++++++++ generic/tclOO.c | 20 ++++++++++++++++++++ generic/tclOO.decls | 6 ++++++ generic/tclOODecls.h | 11 +++++++++++ generic/tclOOStubInit.c | 2 ++ 5 files changed, 54 insertions(+) diff --git a/doc/Class.3 b/doc/Class.3 index 5f8e061..c89c5f4 100644 --- a/doc/Class.3 +++ b/doc/Class.3 @@ -55,6 +55,14 @@ Tcl_ObjectMapMethodNameProc \fBTcl_ObjectGetMethodNameMapper\fR(\fIobject\fR) .sp \fBTcl_ObjectSetMethodNameMapper\fR(\fIobject\fR, \fImethodNameMapper\fR) +.sp +.VS "TIP 605" +Tcl_Class +\fBTcl_GetClassOfObject\fR(\fIobject\fR) +.sp +Tcl_Obj * +\fBTcl_GetObjectClassName\fR(\fIinterp\fR, \fIobject\fR) +.VE "TIP 605" .SH ARGUMENTS .AS ClientData metadata in/out .AP Tcl_Interp *interp in/out @@ -114,6 +122,13 @@ function. Note that the Tcl_Obj reference returned by \fBTcl_GetObjectName\fR is a shared reference. You can also get whether the object has been marked for deletion with \fBTcl_ObjectDeleted\fR (it returns true if deletion of the object has begun); this can be useful during the processing of methods. +.VS "TIP 605" +The class of an object can be retrieved with \fBTcl_GetClassOfObject\fR, and +the name of the class of an object with \fBTcl_GetObjectClassName\fR; note +that these two \fImay\fR return NULL during deletion of an object (this is +transient, and only occurs when the object is a long way through being +deleted). +.VE "TIP 605" .PP Instances of classes are created using \fBTcl_NewObjectInstance\fR, which creates an object from any class (and which is internally called by both diff --git a/generic/tclOO.c b/generic/tclOO.c index 405d5d0..bdceec4 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -3144,6 +3144,26 @@ Tcl_ObjectSetMethodNameMapper( { ((Object *) object)->mapMethodNameProc = mapMethodNameProc; } + +Tcl_Class +Tcl_GetClassOfObject( + Tcl_Object object) +{ + return (Tcl_Class) ((Object *) object)->selfCls; +} + +Tcl_Obj * +Tcl_GetObjectClassName( + Tcl_Interp *interp, + Tcl_Object object) +{ + Tcl_Object classObj = (Tcl_Object) (((Object *) object)->selfCls)->thisPtr; + + if (classObj == NULL) { + return NULL; + } + return Tcl_GetObjectName(interp, classObj); +} /* * Local Variables: diff --git a/generic/tclOO.decls b/generic/tclOO.decls index 4602460..e4063c7 100644 --- a/generic/tclOO.decls +++ b/generic/tclOO.decls @@ -129,6 +129,12 @@ declare 28 { declare 29 { int Tcl_MethodIsPrivate(Tcl_Method method) } +declare 30 { + Tcl_Class Tcl_GetClassOfObject(Tcl_Object object) +} +declare 31 { + Tcl_Obj *Tcl_GetObjectClassName(Tcl_Interp *interp, Tcl_Object object) +} ###################################################################### # Private API, exposed to support advanced OO systems that plug in on top of diff --git a/generic/tclOODecls.h b/generic/tclOODecls.h index 928d07e..3be1e3d 100644 --- a/generic/tclOODecls.h +++ b/generic/tclOODecls.h @@ -118,6 +118,11 @@ TCLAPI Tcl_Obj * Tcl_GetObjectName(Tcl_Interp *interp, Tcl_Object object); /* 29 */ TCLAPI int Tcl_MethodIsPrivate(Tcl_Method method); +/* 30 */ +TCLAPI Tcl_Class Tcl_GetClassOfObject(Tcl_Object object); +/* 31 */ +TCLAPI Tcl_Obj * Tcl_GetObjectClassName(Tcl_Interp *interp, + Tcl_Object object); typedef struct { const struct TclOOIntStubs *tclOOIntStubs; @@ -157,6 +162,8 @@ typedef struct TclOOStubs { void (*tcl_ClassSetDestructor) (Tcl_Interp *interp, Tcl_Class clazz, Tcl_Method method); /* 27 */ Tcl_Obj * (*tcl_GetObjectName) (Tcl_Interp *interp, Tcl_Object object); /* 28 */ int (*tcl_MethodIsPrivate) (Tcl_Method method); /* 29 */ + Tcl_Class (*tcl_GetClassOfObject) (Tcl_Object object); /* 30 */ + Tcl_Obj * (*tcl_GetObjectClassName) (Tcl_Interp *interp, Tcl_Object object); /* 31 */ } TclOOStubs; extern const TclOOStubs *tclOOStubsPtr; @@ -231,6 +238,10 @@ extern const TclOOStubs *tclOOStubsPtr; (tclOOStubsPtr->tcl_GetObjectName) /* 28 */ #define Tcl_MethodIsPrivate \ (tclOOStubsPtr->tcl_MethodIsPrivate) /* 29 */ +#define Tcl_GetClassOfObject \ + (tclOOStubsPtr->tcl_GetClassOfObject) /* 30 */ +#define Tcl_GetObjectClassName \ + (tclOOStubsPtr->tcl_GetObjectClassName) /* 31 */ #endif /* defined(USE_TCLOO_STUBS) */ diff --git a/generic/tclOOStubInit.c b/generic/tclOOStubInit.c index 5e235f4..b9034f0 100644 --- a/generic/tclOOStubInit.c +++ b/generic/tclOOStubInit.c @@ -74,6 +74,8 @@ const TclOOStubs tclOOStubs = { Tcl_ClassSetDestructor, /* 27 */ Tcl_GetObjectName, /* 28 */ Tcl_MethodIsPrivate, /* 29 */ + Tcl_GetClassOfObject, /* 30 */ + Tcl_GetObjectClassName, /* 31 */ }; /* !END!: Do not edit above this line. */ -- 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 b649d5f2ef697debf06046efc1af7bdfcd58a5c1 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 27 Aug 2021 18:46:10 +0000 Subject: Work in progress updating the documentation to modern perspectives. --- doc/ByteArrObj.3 | 64 +++++++++++++++++++++++++++++++------------------------- 1 file changed, 35 insertions(+), 29 deletions(-) diff --git a/doc/ByteArrObj.3 b/doc/ByteArrObj.3 index 90f749e..a8b70eb 100644 --- a/doc/ByteArrObj.3 +++ b/doc/ByteArrObj.3 @@ -19,11 +19,13 @@ Tcl_Obj * void \fBTcl_SetByteArrayObj\fR(\fIobjPtr, bytes, length\fR) .sp +.VS TIP568 unsigned char * -\fBTcl_GetByteArrayFromObj\fR(\fIobjPtr, lengthPtr\fR) +\fBTcl_GetBytesFromObj\fR(\fIinterp, objPtr, lengthPtr\fR) +.VE TIP568 .sp unsigned char * -\fBTcl_GetBytesFromObj\fR(\fIinterp, objPtr, lengthPtr\fR) +\fBTcl_GetByteArrayFromObj\fR(\fIobjPtr, lengthPtr\fR) .sp unsigned char * \fBTcl_SetByteArrayLength\fR(\fIobjPtr, length\fR) @@ -37,41 +39,45 @@ even if \fIlength\fR is non-zero. .AP int length in The length of the array of bytes. It must be >= 0. .AP Tcl_Obj *objPtr in/out -For \fBTcl_SetByteArrayObj\fR, this points to the value to be converted to -byte-array type. For \fBTcl_GetByteArrayFromObj\fR, \fBTcl_GetBytesFromObj\fR and -\fBTcl_SetByteArrayLength\fR, this points to the value from which to get -the byte-array value; if \fIobjPtr\fR does not already point to a byte-array -value, it will be converted to one. -.AP size_t | int *lengthPtr out -Filled with the length of the array of bytes in the value. -May be (int *)NULL when not used. +For \fBTcl_SetByteArrayObj\fR, this points to an unshared value to be +overwritten by a byte-array value. For \fBTcl_GetBytesFromObj\fR, +\fBTcl_GetByteArrayFromObj\fR and \fBTcl_SetByteArrayLength\fR, this points +to the value from which to extract a byte-array value. +.AP "size_t | int" *lengthPtr out +Points to space to be filled with the length of the array of bytes extracted +from \fIobjPtr\fR. May be NULL when the caller does not need the length. .BE .SH DESCRIPTION .PP These procedures are used to create, modify, and read Tcl byte-array values from C code. Byte-array values are typically used to hold the -results of binary IO operations or data structures created with the -\fBbinary\fR command. In Tcl, an array of bytes is not equivalent to a -string. Conceptually, a string is an array of Unicode characters, while a -byte-array is an array of 8-bit quantities with no implicit meaning. -Accessor functions are provided to get the string representation of a -byte-array or to convert an arbitrary value to a byte-array. Obtaining the +results of binary IO operations, data structures created with the +\fBbinary\fR command, or other information, such as encrypted data, +represented as arbitrary binary data. +A byte-array is an array of 8-bit quantities (the integer range 0 - 255) +with no inherent meaning. When a byte-array value must be processed as +a string, the sequence of \fBN\fR bytes is transformed into the corresponding +sequence of \fBN\fR characters, where each byte value transforms to the same +character codepoint value in the range (U+0000 - U+00FF). Obtaining the string representation of a byte-array value (by calling -\fBTcl_GetStringFromObj\fR) produces a properly formed UTF-8 sequence with a -one-to-one mapping between the bytes in the internal representation and the -UTF-8 characters in the string representation. +\fBTcl_GetStringFromObj\fR) produces this string in Tcl's usual +Modified UTF-8 encoding. .PP -\fBTcl_NewByteArrayObj\fR and \fBTcl_SetByteArrayObj\fR will -create a new value of byte-array type or modify an existing value to have a -byte-array type. Both of these procedures set the value's type to be -byte-array and set the value's internal representation to a copy of the -array of bytes given by \fIbytes\fR. \fBTcl_NewByteArrayObj\fR returns a -pointer to a newly allocated value with a reference count of zero. -\fBTcl_SetByteArrayObj\fR invalidates any old string representation and, if -the value is not already a byte-array value, frees any old internal -representation. If \fIbytes\fR is NULL then the new byte array contains -arbitrary values. +\fBTcl_NewByteArrayObj\fR and \fBTcl_SetByteArrayObj\fR +create a new value or overwrite an existing unshared value, respectively, +to hold a byte-array value of \fIlength\fR bytes. \fBTcl_NewByteArrayObj\fR +returns a pointer to the created value with a reference count of zero. +\fBTcl_SetByteArrayObj\fR overwrites and invalidates any old contents +as appropriate, and keeps the same reference count (0 or 1). When +the \fIbytes\fR argument passed to either routine is not NULL, \fIlength\fR +bytes are copied from \fIbytes\fR into the new value. When +the \fIbytes\fR argument passed to either routine is NULL, the +contents of the resulting byte array value are undefined. A \fIbytes\fR +value of NULL is useful only when the caller will arrange to write +known contents into the byte array through a pointer retrieved by a call +to one of the routines explained below. Such manipulation must be performed +only on unshared values, and accompanied by all appropriate invalidations. .PP \fBTcl_GetByteArrayFromObj\fR converts a Tcl value to byte-array type and returns a pointer to the value's new internal representation as an array of -- cgit v0.12 From bc437743d592d3d9a2e37ef46633532102d1e629 Mon Sep 17 00:00:00 2001 From: griffin Date: Tue, 31 Aug 2021 14:36:33 +0000 Subject: Patch to fix zipfs mkimg bug. --- generic/tclZipfs.c | 30 +++++++++++++++++++++++++++++- 1 file changed, 29 insertions(+), 1 deletion(-) diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c index c77e8db..da46acd 100644 --- a/generic/tclZipfs.c +++ b/generic/tclZipfs.c @@ -1191,7 +1191,8 @@ ZipFSFindTOC( const unsigned char *p, *q; const unsigned char *start = zf->data; const unsigned char *end = zf->data + zf->length; - + size_t pass_offset; + /* * Scan backwards from the end of the file for the signature. This is * necessary because ZIP archives aren't the only things that get tagged @@ -1224,6 +1225,11 @@ ZipFSFindTOC( goto error; } + /* + * Remember passOffset + */ + pass_offset = p - zf->data; + /* * How many files in the archive? If that's bogus, we're done here. */ @@ -1300,6 +1306,12 @@ ZipFSFindTOC( zf->passOffset -= i ? (5 + i) : 0; } } + + /* + * Restore passOffset + */ + zf->passOffset = pass_offset; + return TCL_OK; error: @@ -3108,6 +3120,22 @@ ZipFSMkZipOrImg( * Copy everything up to the ZIP-related suffix. */ + if (zf->passOffset == 0) { + /* + * Hmm, this mounted archive is local (in this image), but + * zf->passOffset does not have a valid value. Let's open + * this image and find the passOffset so as to copy the image + * correctly. + */ + + ZipFile zflocal; + memset(&zflocal, 0, sizeof(ZipFile)); + if (ZipFSOpenArchive(interp, imgName, 0, &zflocal) == TCL_OK) { + zf->passOffset = zflocal.passOffset; + ZipFSCloseArchive(interp, &zflocal); + } + } + if ((size_t) Tcl_Write(out, (char *) zf->data, zf->passOffset) != zf->passOffset) { memset(passBuf, 0, sizeof(passBuf)); -- cgit v0.12 From 6fc4828aadc3d97a83a14a07a637415b9dafa8c6 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 2 Sep 2021 14:41:53 +0000 Subject: =?UTF-8?q?(c)=20->=20=C2=A9,=20now=20that=20TIP=20#587=20is=20acc?= =?UTF-8?q?epted?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- library/tcltest/tcltest.tcl | 6 +++--- tests/http11.test | 2 +- tests/httpPipeline.test | 2 +- tests/httpTest.tcl | 2 +- tests/httpTestScript.tcl | 2 +- tests/httpd11.tcl | 2 +- tools/checkLibraryDoc.tcl | 2 +- tools/findBadExternals.tcl | 2 +- tools/genStubs.tcl | 4 ++-- tools/index.tcl | 2 +- tools/installData.tcl | 2 +- tools/loadICU.tcl | 2 +- tools/mkdepend.tcl | 2 +- tools/regexpTestLib.tcl | 4 ++-- tools/tclZIC.tcl | 2 +- tools/tcltk-man2html-utils.tcl | 4 ++-- tools/tcltk-man2html.tcl | 4 ++-- tools/uniParse.tcl | 4 ++-- 18 files changed, 25 insertions(+), 25 deletions(-) diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl index eb47963..72c7b94 100644 --- a/library/tcltest/tcltest.tcl +++ b/library/tcltest/tcltest.tcl @@ -10,9 +10,9 @@ # initially implemented by Mary Ann May-Pumphrey of Sun # Microsystems. # -# Copyright (c) 1994-1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 Scriptics Corporation. -# Copyright (c) 2000 Ajuba Solutions +# Copyright © 1994-1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. +# Copyright © 2000 Ajuba Solutions # Contributions from Don Porter, NIST, 2002. (not subject to US copyright) # All rights reserved. diff --git a/tests/http11.test b/tests/http11.test index f243e56..4f6fb92 100644 --- a/tests/http11.test +++ b/tests/http11.test @@ -2,7 +2,7 @@ # # Test HTTP/1.1 features. # -# Copyright (C) 2009 Pat Thoyts +# Copyright © 2009 Pat Thoyts # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/tests/httpPipeline.test b/tests/httpPipeline.test index 4306149..4e55a10 100644 --- a/tests/httpPipeline.test +++ b/tests/httpPipeline.test @@ -3,7 +3,7 @@ # Test HTTP/1.1 concurrent requests including # queueing, pipelining and retries. # -# Copyright (C) 2018 Keith Nash +# Copyright © 2018 Keith Nash # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/tests/httpTest.tcl b/tests/httpTest.tcl index 8a96d95..1dc6772 100644 --- a/tests/httpTest.tcl +++ b/tests/httpTest.tcl @@ -3,7 +3,7 @@ # Test HTTP/1.1 concurrent requests including # queueing, pipelining and retries. # -# Copyright (C) 2018 Keith Nash +# Copyright © 2018 Keith Nash # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/tests/httpTestScript.tcl b/tests/httpTestScript.tcl index a40449a..5437bf6 100644 --- a/tests/httpTestScript.tcl +++ b/tests/httpTestScript.tcl @@ -3,7 +3,7 @@ # Test HTTP/1.1 concurrent requests including # queueing, pipelining and retries. # -# Copyright (C) 2018 Keith Nash +# Copyright © 2018 Keith Nash # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/tests/httpd11.tcl b/tests/httpd11.tcl index c7dde43..d0624f8 100644 --- a/tests/httpd11.tcl +++ b/tests/httpd11.tcl @@ -3,7 +3,7 @@ # A simple httpd for testing HTTP/1.1 client features. # Not suitable for use on a internet connected port. # -# Copyright (C) 2009 Pat Thoyts +# Copyright © 2009 Pat Thoyts # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/tools/checkLibraryDoc.tcl b/tools/checkLibraryDoc.tcl index 4e4d6e7..36d82b2 100644 --- a/tools/checkLibraryDoc.tcl +++ b/tools/checkLibraryDoc.tcl @@ -16,7 +16,7 @@ # non-standard code, this script will produce erroneous results. Each # list should be carefully checked for accuracy. # -# Copyright (c) 1998-1999 Scriptics Corporation. +# Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. diff --git a/tools/findBadExternals.tcl b/tools/findBadExternals.tcl index 2228357..2351cd2 100755 --- a/tools/findBadExternals.tcl +++ b/tools/findBadExternals.tcl @@ -10,7 +10,7 @@ # # tclsh findBadExternals.tcl /path/to/tclXX.so-or-.dll # -# Copyright (c) 2005 George Peter Staplin and Kevin Kenny +# Copyright © 2005 George Peter Staplin and Kevin Kenny # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/tools/genStubs.tcl b/tools/genStubs.tcl index 4f4acbb..282abcc 100644 --- a/tools/genStubs.tcl +++ b/tools/genStubs.tcl @@ -4,8 +4,8 @@ # interface. # # -# Copyright (c) 1998-1999 Scriptics Corporation. -# Copyright (c) 2007 Daniel A. Steffen +# Copyright © 1998-1999 Scriptics Corporation. +# Copyright © 2007 Daniel A. Steffen # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/tools/index.tcl b/tools/index.tcl index 0e645c4..07f5868 100644 --- a/tools/index.tcl +++ b/tools/index.tcl @@ -4,7 +4,7 @@ # the man page conversion. It is used to extract information used to # generate a table of contents and a keyword list. # -# Copyright (c) 1996 Sun Microsystems, Inc. +# Copyright © 1996 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/tools/installData.tcl b/tools/installData.tcl index 4a3b1ee..644cf53 100644 --- a/tools/installData.tcl +++ b/tools/installData.tcl @@ -12,7 +12,7 @@ exec tclsh "$0" ${1+"$@"} # #---------------------------------------------------------------------- # -# Copyright (c) 2004 Kevin B. Kenny. All rights reserved. +# Copyright © 2004 Kevin B. Kenny. All rights reserved. # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. #---------------------------------------------------------------------- diff --git a/tools/loadICU.tcl b/tools/loadICU.tcl index 6057662..bbe5e4a 100755 --- a/tools/loadICU.tcl +++ b/tools/loadICU.tcl @@ -22,7 +22,7 @@ # #---------------------------------------------------------------------- # -# Copyright (c) 2004 Kevin B. Kenny. All rights reserved. +# Copyright © 2004 Kevin B. Kenny. All rights reserved. # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. #---------------------------------------------------------------------- diff --git a/tools/mkdepend.tcl b/tools/mkdepend.tcl index b1ad076..6e3d6ed 100644 --- a/tools/mkdepend.tcl +++ b/tools/mkdepend.tcl @@ -2,7 +2,7 @@ # # mkdepend : generate dependency information from C/C++ files # -# Copyright (c) 1998, Nat Pryce +# Copyright © 1998, Nat Pryce # # Permission is hereby granted, without written agreement and without # license or royalty fees, to use, copy, modify, and distribute this diff --git a/tools/regexpTestLib.tcl b/tools/regexpTestLib.tcl index bdb7d90..454a4e8 100644 --- a/tools/regexpTestLib.tcl +++ b/tools/regexpTestLib.tcl @@ -4,7 +4,7 @@ # spencer2regexp.tcl, which are programs written to convert Henry # Spencer's test suite to tcl test files. # -# Copyright (c) 1996 Sun Microsystems, Inc. +# Copyright © 1996 Sun Microsystems, Inc. proc readInputFile {} { global inFileName @@ -105,7 +105,7 @@ proc writeOutputFile {numLines fcn} { puts $fileId "# errors. No output means no errors were found. Setting VERBOSE to" puts $fileId "# -1 will run tests that are known to fail." puts $fileId "#" - puts $fileId "# Copyright (c) 1998 Sun Microsystems, Inc." + puts $fileId "# Copyright © 1998 Sun Microsystems, Inc." puts $fileId "#" puts $fileId "# See the file \"license.terms\" for information on usage and redistribution" puts $fileId "# of this file, and for a DISCLAIMER OF ALL WARRANTIES." diff --git a/tools/tclZIC.tcl b/tools/tclZIC.tcl index 901814f..b04669e 100755 --- a/tools/tclZIC.tcl +++ b/tools/tclZIC.tcl @@ -25,7 +25,7 @@ # #---------------------------------------------------------------------- # -# Copyright (c) 2004 Kevin B. Kenny. All rights reserved. +# Copyright © 2004 Kevin B. Kenny. All rights reserved. # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. #---------------------------------------------------------------------- diff --git a/tools/tcltk-man2html-utils.tcl b/tools/tcltk-man2html-utils.tcl index b7a8520..98bbf86 100644 --- a/tools/tcltk-man2html-utils.tcl +++ b/tools/tcltk-man2html-utils.tcl @@ -3,8 +3,8 @@ ## functions are specifically intended to work with the format as used ## by Tcl and Tk; they do not cope with arbitrary nroff markup. ## -## Copyright (c) 1995-1997 Roger E. Critchlow Jr -## Copyright (c) 2004-2011 Donal K. Fellows +## Copyright © 1995-1997 Roger E. Critchlow Jr +## Copyright © 2004-2011 Donal K. Fellows set ::manual(report-level) 1 diff --git a/tools/tcltk-man2html.tcl b/tools/tcltk-man2html.tcl index 0e87531..020aad9 100755 --- a/tools/tcltk-man2html.tcl +++ b/tools/tcltk-man2html.tcl @@ -19,8 +19,8 @@ if {[catch {package require Tcl 8.6-} msg]} { # into hypertext, not as a general solution to the problem. If you # try to use this, you'll be very much on your own. # -# Copyright (c) 1995-1997 Roger E. Critchlow Jr -# Copyright (c) 2004-2010 Donal K. Fellows +# Copyright © 1995-1997 Roger E. Critchlow Jr +# Copyright © 2004-2010 Donal K. Fellows set ::Version "50/8.7" set ::CSSFILE "docs.css" diff --git a/tools/uniParse.tcl b/tools/uniParse.tcl index aec5864..3acf19c 100644 --- a/tools/uniParse.tcl +++ b/tools/uniParse.tcl @@ -6,7 +6,7 @@ # UnicodeData file from: # ftp://ftp.unicode.org/Public/UNIDATA/UnicodeData.txt # -# Copyright (c) 1998-1999 Scriptics Corporation. +# Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. @@ -185,7 +185,7 @@ proc uni::main {} { * automatically generated by the tools/uniParse.tcl script. Do not * modify this file by hand. * - * Copyright (c) 1998 Scriptics Corporation. + * Copyright © 1998 Scriptics Corporation. * All rights reserved. */ -- cgit v0.12 From 274f7dbfe0151611c97366d884cb1fdaeccbc3f3 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 2 Sep 2021 14:46:55 +0000 Subject: =?UTF-8?q?Few=20more=20(c)=20->=20=C2=A9?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- tools/installVfs.tcl | 2 +- tools/makeHeader.tcl | 2 +- tools/tclOOScript.tcl | 6 +++--- 3 files changed, 5 insertions(+), 5 deletions(-) diff --git a/tools/installVfs.tcl b/tools/installVfs.tcl index 14993ec..699b00e 100644 --- a/tools/installVfs.tcl +++ b/tools/installVfs.tcl @@ -10,7 +10,7 @@ exec tclsh "$0" ${1+"$@"} # #---------------------------------------------------------------------- # -# Copyright (c) 2018 Sean Woods. All rights reserved. +# Copyright © 2018 Sean Woods. All rights reserved. # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. #---------------------------------------------------------------------- diff --git a/tools/makeHeader.tcl b/tools/makeHeader.tcl index 1d961c9..17526e0 100644 --- a/tools/makeHeader.tcl +++ b/tools/makeHeader.tcl @@ -3,7 +3,7 @@ # This script generates embeddable C source (in a .h file) from a .tcl # script. # -# Copyright (c) 2018 Donal K. Fellows +# Copyright © 2018 Donal K. Fellows # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl index 5e0145f..10d3bf8 100644 --- a/tools/tclOOScript.tcl +++ b/tools/tclOOScript.tcl @@ -4,9 +4,9 @@ # that the code can be definitely run even in safe interpreters; TclOO's # core setup is safe. # -# Copyright (c) 2012-2018 Donal K. Fellows -# Copyright (c) 2013 Andreas Kupries -# Copyright (c) 2017 Gerald Lester +# Copyright © 2012-2018 Donal K. Fellows +# Copyright © 2013 Andreas Kupries +# Copyright © 2017 Gerald Lester # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -- cgit v0.12 From 76871708808853f6b59ece6e2a6d6ec4a594df70 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Thu, 2 Sep 2021 22:38:32 +0000 Subject: Backport fixes for [ccc448a6bfd5], namespace ensemble subcommand name prefix matching and a subsequent error results in a segmentation fault. --- generic/tclEnsemble.c | 20 +++++++++++++++++++- generic/tclIndexObj.c | 18 +++++------------- generic/tclInt.h | 1 + generic/tclNamesp.c | 5 +++-- tests/namespace.test | 18 ++++++++++++++++++ 5 files changed, 46 insertions(+), 16 deletions(-) diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index ccd43b9..7d060b0 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -2201,6 +2201,18 @@ TclSpellFix( TclNRAddCallback(interp, TclNRReleaseValues, fix, NULL, NULL, NULL); } +Tcl_Obj *const *TclEnsembleGetRewriteValues( + Tcl_Interp *interp /* Current interpreter. */ +) +{ + Interp *iPtr = (Interp *) interp; + Tcl_Obj *const *origObjv = iPtr->ensembleRewrite.sourceObjs; + if (origObjv[0] == NULL) { + origObjv = (Tcl_Obj *const *)origObjv[2]; + } + return origObjv; +} + /* *---------------------------------------------------------------------- * @@ -2225,12 +2237,18 @@ TclFetchEnsembleRoot( int objc, int *objcPtr) { + Tcl_Obj *const *sourceObjs; Interp *iPtr = (Interp *) interp; if (iPtr->ensembleRewrite.sourceObjs) { *objcPtr = objc + iPtr->ensembleRewrite.numRemovedObjs - iPtr->ensembleRewrite.numInsertedObjs; - return iPtr->ensembleRewrite.sourceObjs; + if (iPtr->ensembleRewrite.sourceObjs[0] == NULL) { + sourceObjs = (Tcl_Obj *const *)iPtr->ensembleRewrite.sourceObjs[1]; + } else { + sourceObjs = iPtr->ensembleRewrite.sourceObjs; + } + return sourceObjs; } *objcPtr = objc; return objv; diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index 48ebb69..c33caf8 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -887,27 +887,19 @@ Tcl_WrongNumArgs( } /* - * Check to see if we are processing an ensemble implementation, and if so - * rewrite the results in terms of how the ensemble was invoked. + * If processing an an ensemble implementation, rewrite the results in + * terms of how the ensemble was invoked. */ if (iPtr->ensembleRewrite.sourceObjs != NULL) { int toSkip = iPtr->ensembleRewrite.numInsertedObjs; int toPrint = iPtr->ensembleRewrite.numRemovedObjs; - Tcl_Obj *const *origObjv = iPtr->ensembleRewrite.sourceObjs; + Tcl_Obj *const *origObjv = TclEnsembleGetRewriteValues(interp); /* - * Check for spelling fixes, and substitute the fixed values. - */ - - if (origObjv[0] == NULL) { - origObjv = (Tcl_Obj *const *)origObjv[2]; - } - - /* - * We only know how to do rewriting if all the replaced objects are + * Only do rewrite the command if all the replaced objects are * actually arguments (in objv) to this function. Otherwise it just - * gets too complicated and we'd be better off just giving a slightly + * gets too complicated and it's to just give a slightly * confusing error message... */ diff --git a/generic/tclInt.h b/generic/tclInt.h index b561cbd..6c3a05d 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2993,6 +2993,7 @@ MODULE_SCOPE char * TclDStringAppendDString(Tcl_DString *dsPtr, MODULE_SCOPE Tcl_Obj * TclDStringToObj(Tcl_DString *dsPtr); MODULE_SCOPE Tcl_Obj *const *TclFetchEnsembleRoot(Tcl_Interp *interp, Tcl_Obj *const *objv, int objc, int *objcPtr); +MODULE_SCOPE Tcl_Obj *const *TclEnsembleGetRewriteValues(Tcl_Interp *interp); MODULE_SCOPE Tcl_Namespace *TclEnsureNamespace(Tcl_Interp *interp, Tcl_Namespace *namespacePtr); MODULE_SCOPE void TclFinalizeAllocSubsystem(void); diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 5dc9659..2aed628 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -4921,8 +4921,9 @@ TclLogCommandInfo( * command (must be <= command). */ const char *command, /* First character in command that generated * the error. */ - int length, /* Number of bytes in command (-1 means use - * all bytes up to first null byte). */ + int length, /* Number of bytes in command (TCL_INDEX_NONE + * means use all bytes up to first null byte). + */ const unsigned char *pc, /* Current pc of bytecode execution context */ Tcl_Obj **tosPtr) /* Current stack of bytecode execution * context */ diff --git a/tests/namespace.test b/tests/namespace.test index 6eabf61..c98ad4a 100644 --- a/tests/namespace.test +++ b/tests/namespace.test @@ -1908,6 +1908,24 @@ test namespace-42.10 { unset -nocomplain lst } -returnCodes error -match glob -result {invalid command name *three*} + +test namespace-42.11 { + ensembles: prefix matching segmentation fault + + issue ccc448a6bfd59cbd +} -body { + namespace eval n1 { + namespace ensemble create + namespace export * + proc p1 args {error success} + } + # segmentation fault only occurs in the non-byte-compiled path, so avoid + # byte compilation + set cmd {namespace eva n1 {[namespace parent]::n1 p1}} + {*}$cmd +} -returnCodes error -result success + + test namespace-43.1 {ensembles: dict-driven} { namespace eval ns { namespace export x* -- cgit v0.12 From 2e1d5a50d831b9c760366ca2d238a7478bbcc053 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Mon, 4 Oct 2021 21:09:02 +0000 Subject: Rewrite comments for clarity and conciseness. --- generic/tclCkalloc.c | 2 +- generic/tclCompCmds.c | 6 +- generic/tclCompile.c | 367 ++++++++++++++++++++++++-------------------------- 3 files changed, 182 insertions(+), 193 deletions(-) diff --git a/generic/tclCkalloc.c b/generic/tclCkalloc.c index 6cf3c4c..f2394b1 100644 --- a/generic/tclCkalloc.c +++ b/generic/tclCkalloc.c @@ -381,7 +381,7 @@ Tcl_DumpActiveMemory( * Tcl_DbCkalloc - debugging ckalloc * * Allocate the requested amount of space plus some extra for guard bands - * at both ends of the request, plus a size, panicing if there isn't + * at both ends of the request, plus a size, panicking if there isn't * enough space, then write in the guard bands and return the address of * the space in the middle that the user asked for. * diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 13589b2..a2e11c0 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -2641,8 +2641,8 @@ TclCompileLmapCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ + Command *cmdPtr, /* Points to the definition of the command + * being compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { return CompileEachloopCmd(interp, parsePtr, cmdPtr, envPtr, @@ -2703,7 +2703,7 @@ CompileEachloopCmd( } /* - * Bail out if the body requires substitutions in order to insure correct + * Bail out if the body requires substitutions in order to ensure correct * behaviour. [Bug 219166] */ diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 6ffb3dd..f966979 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -717,8 +717,8 @@ static void EnterCmdWordData(ExtCmdLoc *eclPtr, int srcOffset, static void ReleaseCmdWordData(ExtCmdLoc *eclPtr); /* - * The structure below defines the bytecode Tcl object type by means of - * procedures that can be invoked by generic object code. + * tclByteCodeType provides the standard type management procedures for the + * bytecode type. */ const Tcl_ObjType tclByteCodeType = { @@ -730,8 +730,8 @@ const Tcl_ObjType tclByteCodeType = { }; /* - * The structure below defines a bytecode Tcl object type to hold the - * compiled bytecode for the [subst]itution of Tcl values. + * subtCodeType provides the standard type managemnt procedures for the + * substcode type, which represents substiution within a Tcl value. */ static const Tcl_ObjType substCodeType = { @@ -756,16 +756,14 @@ static const Tcl_ObjType substCodeType = { * TclSetByteCodeFromAny -- * * Part of the bytecode Tcl object type implementation. Attempts to - * generate an byte code internal form for the Tcl object "objPtr" by - * compiling its string representation. This function also takes a hook - * procedure that will be invoked to perform any needed post processing - * on the compilation results before generating byte codes. interp is + * compile the string representation of the objPtr into bytecode. Accepts + * a hook routine that is invoked to perform any needed post-processing on + * the compilation results before generating byte codes. interp is the * compilation context and may not be NULL. * * Results: - * The return value is a standard Tcl object result. If an error occurs - * during compilation, an error message is left in the interpreter's - * result. + * A standard Tcl object result. If an error occurs during compilation, an + * error message is left in the interpreter's result. * * Side effects: * Frees the old internal representation. If no error occurs, then the @@ -807,7 +805,7 @@ TclSetByteCodeFromAny( length = objPtr->length; /* - * TIP #280: Pick up the CmdFrame in which the BC compiler was invoked and + * TIP #280: Pick up the CmdFrame in which the BC compiler was invoked, and * use to initialize the tracking in the compiler. This information was * stored by TclCompEvalObj and ProcCompileProc. */ @@ -816,15 +814,14 @@ TclSetByteCodeFromAny( iPtr->invokeCmdFramePtr, iPtr->invokeWord); /* - * Now we check if we have data about invisible continuation lines for the - * script, and make it available to the compile environment, if so. + * Make available to the compilation environment any data about invisible + * continuation lines for the script. * * It is not clear if the script Tcl_Obj* can be free'd while the compiler * is using it, leading to the release of the associated ContLineLoc - * structure as well. To ensure that the latter doesn't happen we set a - * lock on it. We release this lock in the function TclFreeCompileEnv(), - * found in this file. The "lineCLPtr" hashtable is managed in the file - * "tclObj.c". + * structure as well. To ensure that the latter doesn't happen set a lock + * on it, which is released in TclFreeCompileEnv(). The "lineCLPtr" + * hashtable tclObj.c. */ clLocPtr = TclContinuationsGet(objPtr); @@ -835,7 +832,7 @@ TclSetByteCodeFromAny( TclCompileScript(interp, stringPtr, length, &compEnv); /* - * Successful compilation. Add a "done" instruction at the end. + * Compilation succeeded. Add a "done" instruction at the end. */ TclEmitOpcode(INST_DONE, &compEnv); @@ -843,9 +840,9 @@ TclSetByteCodeFromAny( /* * Check for optimizations! * - * Test if the generated code is free of most hazards; if so, recompile - * but with generation of INST_START_CMD disabled. This produces somewhat - * faster code in some cases, and more compact code in more. + * If the generated code is free of most hazards, recompile with generation + * of INST_START_CMD disabled to produce code that more compact in many + * cases, and also sometimes more performant. */ if (Tcl_GetParent(interp) == NULL && @@ -875,7 +872,7 @@ TclSetByteCodeFromAny( } /* - * Invoke the compilation hook procedure if one exists. + * Invoke the compilation hook procedure if there is one. */ if (hookProc) { @@ -884,7 +881,7 @@ TclSetByteCodeFromAny( /* * Change the object into a ByteCode object. Ownership of the literal - * objects and aux data items is given to the ByteCode object. + * objects and aux data items passes to the ByteCode object. */ #ifdef TCL_COMPILE_DEBUG @@ -915,12 +912,12 @@ TclSetByteCodeFromAny( * compiling its string representation. * * Results: - * The return value is a standard Tcl object result. If an error occurs - * during compilation, an error message is left in the interpreter's - * result unless "interp" is NULL. + * A standard Tcl object result. If an error occurs during compilation and + * "interp" is not null, an error message is left in the interpreter's + * result. * * Side effects: - * Frees the old internal representation. If no error occurs, then the + * Frees the old internal representation. If no error occurs then the * compiled code is stored as "objPtr"s bytecode representation. Also, if * debugging, initializes the "tcl_traceCompile" Tcl variable used to * trace compilations. @@ -932,7 +929,7 @@ static int SetByteCodeFromAny( Tcl_Interp *interp, /* The interpreter for which the code is being * compiled. Must not be NULL. */ - Tcl_Obj *objPtr) /* The object to make a ByteCode object. */ + Tcl_Obj *objPtr) /* The object to compile to bytecode */ { if (interp == NULL) { return TCL_ERROR; @@ -946,9 +943,9 @@ SetByteCodeFromAny( * DupByteCodeInternalRep -- * * Part of the bytecode Tcl object type implementation. However, it does - * not copy the internal representation of a bytecode Tcl_Obj, but - * instead leaves the new object untyped (with a NULL type pointer). - * Code will be compiled for the new object only if necessary. + * not copy the internal representation of a bytecode Tcl_Obj, instead + * assigning NULL to the type pointer of the new object. Code is compiled + * for the new object only if necessary. * * Results: * None. @@ -980,9 +977,9 @@ DupByteCodeInternalRep( * None. * * Side effects: - * The bytecode object's internal rep is marked invalid and its code gets - * freed unless the code is actively being executed. In that case the - * cleanup is delayed until the last execution of the code completes. + * The bytecode object's internal rep is invalidated and its code is freed + * unless the code is actively being executed, in which case cleanup is + * delayed until the last execution of the code completes. * *---------------------------------------------------------------------- */ @@ -1004,16 +1001,16 @@ FreeByteCodeInternalRep( * * TclReleaseByteCode -- * - * This procedure does all the real work of freeing up a bytecode - * object's ByteCode structure. It's called only when the structure's - * reference count becomes zero. + * Does all the real work of freeing up a bytecode object's ByteCode + * structure. Called only when the structure's reference count + * is zero. * * Results: * None. * * Side effects: - * Frees objPtr's bytecode internal representation and sets its type NULL - * Also releases its literals and frees its auxiliary data items. + * Frees objPtr's bytecode internal representation and sets its type to + * NULL. Also releases its literals and frees its auxiliary data items. * *---------------------------------------------------------------------- */ @@ -1089,8 +1086,8 @@ CleanupByteCode( /* * A single heap object holds the ByteCode structure and its code, object, * command location, and auxiliary data arrays. This means we only need to - * 1) decrement the ref counts of the LiteralEntry's in its literal array, - * 2) call the free procs for the auxiliary data items, 3) free the + * 1) decrement the ref counts of each LiteralEntry in the literal array, + * 2) call the free procedures for the auxiliary data items, 3) free the * localCache if it is unused, and finally 4) free the ByteCode * structure's heap object. * @@ -1099,11 +1096,11 @@ CleanupByteCode( * the global literal table. They instead maintain private references to * their literals which must be decremented. * - * In order to insure a proper and efficient cleanup of the literal array - * when it contains non-shared literals [Bug 983660], we also distinguish - * the case of an interpreter being deleted (signaled by interp == NULL). + * In order to ensure proper and efficient cleanup of the literal array + * when it contains non-shared literals [Bug 983660], distinguish the case + * of an interpreter being deleted, which is signaled by interp == NULL. * Also, as the interp deletion will remove the global literal table - * anyway, we avoid the extra cost of updating it for each literal being + * anyway, avoid the extra cost of updating it for each literal being * released. */ @@ -1135,9 +1132,9 @@ CleanupByteCode( } /* - * TIP #280. Release the location data associated with this byte code - * structure, if any. NOTE: The interp we belong to may be gone already, - * and the data with it. + * TIP #280. Release the location data associated with this bytecode + * structure, if any. The associated interp may be gone already, and the + * data with it. * * See also tclBasic.c, DeleteInterpProc */ @@ -1165,8 +1162,8 @@ CleanupByteCode( * * IsCompactibleCompileEnv -- * - * Checks to see if we may apply some basic compaction optimizations to a - * piece of bytecode. Idempotent. + * Determines whether some basic compaction optimizations may be applied + * to a piece of bytecode. Idempotent. * * --------------------------------------------------------------------- */ @@ -1180,7 +1177,7 @@ IsCompactibleCompileEnv( /* * Special: procedures in the '::tcl' namespace (or its children) are - * considered to be well-behaved and so can have compaction applied even + * considered to be well-behaved, so compaction can be applied to them even * if it would otherwise be invalid. */ @@ -1196,10 +1193,10 @@ IsCompactibleCompileEnv( /* * Go through and ensure that no operation involved can cause a desired - * change of bytecode sequence during running. This comes down to ensuring - * that there are no mapped variables (due to traces) or calls to external - * commands (traces, [uplevel] trickery). This is actually a very - * conservative check; it turns down a lot of code that is OK in practice. + * change of bytecode sequence during its execution. This comes down to + * ensuring that there are no mapped variables (due to traces) or calls to + * external commands (traces, [uplevel] trickery). This is actually a very + * conservative check. It turns down a lot of code that is OK in practice. */ for (pc = envPtr->codeStart ; pc < envPtr->codeNext ; pc += size) { @@ -1235,8 +1232,8 @@ IsCompactibleCompileEnv( * * Tcl_SubstObj -- * - * This function performs the substitutions specified on the given string - * as described in the user documentation for the "subst" Tcl command. + * Performs substitutions on the given string as described in the user + * documentation for "subst". * * Results: * A Tcl_Obj* containing the substituted string, or NULL to indicate that @@ -1268,14 +1265,14 @@ Tcl_SubstObj( * * Tcl_NRSubstObj -- * - * Request substitution of a Tcl value by the NR stack. + * Adds substitution within the value of objPtr to the NR execution stack. * * Results: - * Returns TCL_OK. + * TCL_OK. * * Side effects: * Compiles objPtr into bytecode that performs the substitutions as - * governed by flags and places callbacks on the NR stack to execute + * governed by flags, adds a callback to the NR execution stack to execute * the bytecode and store the result in the interp. * *---------------------------------------------------------------------- @@ -1299,11 +1296,11 @@ Tcl_NRSubstObj( * * CompileSubstObj -- * - * Compile a Tcl value into ByteCode implementing its substitution, as - * governed by flags. + * Compiles a value into bytecode that performs substitution within the + * value, as governed by flags. * * Results: - * A (ByteCode *) is returned pointing to the resulting ByteCode. + * A (ByteCode *) is pointing to the resulting ByteCode. * * Side effects: * The Tcl_ObjType of objPtr is changed to the "substcode" type, and the @@ -1373,9 +1370,9 @@ CompileSubstObj( * * FreeSubstCodeInternalRep -- * - * Part of the substcode Tcl object type implementation. Frees the - * storage associated with a substcode object's internal representation - * unless its code is actively being executed. + * Part of the "substcode" Tcl object type implementation. Frees the + * storage associated with the substcode internal representation of a + * Tcl_Obj unless its code is actively being executed. * * Results: * None. @@ -1629,14 +1626,14 @@ TclInitCompileEnv( * * TclFreeCompileEnv -- * - * Free the storage allocated in a CompileEnv compilation environment + * Frees the storage allocated in a CompileEnv compilation environment * structure. * * Results: * None. * * Side effects: - * Allocated storage in the CompileEnv structure is freed. Note that its + * Allocated storage in the CompileEnv structure is freed, although its * local literal table is not deleted and its literal objects are not * released. In addition, storage referenced by its auxiliary data items * is not freed. This is done so that, when compilation is successful, @@ -1707,10 +1704,11 @@ TclFreeCompileEnv( * * TclWordKnownAtCompileTime -- * - * Test whether the value of a token is completely known at compile time. + * Determines whether the value of a token is completely known at compile + * time. * * Results: - * Returns true if the tokenPtr argument points to a word value that is + * True if the tokenPtr argument points to a word value that is * completely known at compile time. Generally, values that are known at * compile time can be compiled to their values, while values that cannot * be known until substitution at runtime must be compiled to bytecode @@ -1787,12 +1785,12 @@ TclWordKnownAtCompileTime( * * TclCompileScript -- * - * Compile a Tcl script in a string. + * Compiles a Tcl script in a string. * * Results: - * The return value is TCL_OK on a successful compilation and TCL_ERROR - * on failure. If TCL_ERROR is returned, then the interpreter's result - * contains an error message. + * + * A standard Tcl result. If an error occurs, an + * error message is left in the interpreter's result. * * Side effects: * Adds instructions to envPtr to evaluate the script at runtime. @@ -1929,14 +1927,14 @@ CompileExpanded( /* * The stack depth during argument expansion can only be managed at * runtime, as the number of elements in the expanded lists is not known - * at compile time. We adjust here the stack depth estimate so that it is + * at compile time. Adjust the stack depth estimate here so that it is * correct after the command with expanded arguments returns. * * The end effect of this command's invocation is that all the words of - * the command are popped from the stack, and the result is pushed: the + * the command are popped from the stack and the result is pushed: The * stack top changes by (1-wordIdx). * - * Note that the estimates are not correct while the command is being + * The estimates are not correct while the command is being * prepared and run, INST_EXPAND_STKTOP is not stack-neutral in general. */ @@ -1956,16 +1954,16 @@ CompileCmdCompileProc( int depth = TclGetStackDepth(envPtr); /* - * Emit of the INST_START_CMD instruction is controlled by the value of + * Emission of the INST_START_CMD instruction is controlled by the value of * envPtr->atCmdStart: * - * atCmdStart == 2 : We are not using the INST_START_CMD instruction. - * atCmdStart == 1 : INST_START_CMD was the last instruction emitted. - * : We do not need to emit another. Instead we - * : increment the number of cmds started at it (except - * : for the special case at the start of a script.) - * atCmdStart == 0 : The last instruction was something else. We need - * : to emit INST_START_CMD here. + * atCmdStart == 2 : Don't use the INST_START_CMD instruction. + * atCmdStart == 1 : INST_START_CMD was the last instruction emitted, + * : so no need to emit another. Instead + * : increment the number of cmds started at it, except + * : for the special case at the start of a script. + * atCmdStart == 0 : The last instruction was something else. + * : Emit INST_START_CMD here. */ switch (envPtr->atCmdStart) { @@ -1988,7 +1986,7 @@ CompileCmdCompileProc( if (TCL_OK == TclAttemptCompileProc(interp, parsePtr, 1, cmdPtr, envPtr)) { if (incrOffset >= 0) { /* - * We successfully compiled a command. Increment the number of + * Command compiled succesfully. Increment the number of * commands that start at the currently active INST_START_CMD. */ @@ -2057,7 +2055,7 @@ CompileCommandTokens( /* * TIP #280. Scan the words and compute the extended location information. - * The map first contain full per-word line information for use by the + * At first the map first contains full per-word line information for use by the * compiler. This is later replaced by a reduced form which signals * non-literal words, stored in 'wlines'. */ @@ -2099,7 +2097,7 @@ CompileCommandTokens( } } - /* If cmdPtr != NULL, we will try to call cmdPtr->compileProc */ + /* If cmdPtr != NULL, try to call cmdPtr->compileProc */ if (cmdPtr) { code = CompileCmdCompileProc(interp, parsePtr, cmdPtr, envPtr); } @@ -2126,8 +2124,8 @@ CompileCommandTokens( (envPtr->codeNext-envPtr->codeStart) - startCodeOffset); /* - * TIP #280: Free full form of per-word line data and insert the reduced - * form now + * TIP #280: Free the full form of per-word line data and insert the + * reduced form now. */ envPtr->line = cmdLine; @@ -2165,10 +2163,10 @@ TclCompileScript( } /* * Check depth to avoid overflow of the C execution stack by too many - * nested calls of TclCompileScript (considering interp recursionlimit). - * Factor 5/4 (1.25) is used to avoid too mistaken limit recognition - * during "mixed" evaluation and compilation process (nested eval+compile) - * and is good enough for default recursionlimit (1000). + * nested calls of TclCompileScript, considering interp recursionlimit. + * Use factor 5/4 (1.25) to avoid being too mistaken when recognizing the + * limit during "mixed" evaluation and compilation process (nested + * eval+compile) and is good enough for default recursionlimit (1000). */ if (iPtr->numLevels / 5 > iPtr->maxNestingDepth / 4) { Tcl_SetObjResult(interp, Tcl_NewStringObj( @@ -2311,8 +2309,8 @@ TclCompileScript( * * TclCompileTokens -- * - * Given an array of tokens parsed from a Tcl command (e.g., the tokens - * that make up a word) this procedure emits instructions to evaluate the + * Given an array of tokens parsed from a Tcl command, e.g. the tokens + * that make up a word, emits instructions to evaluate the * tokens and concatenate their values to form a single result value on * the interpreter's runtime evaluation stack. * @@ -2417,18 +2415,16 @@ TclCompileTokens( int depth = TclGetStackDepth(envPtr); /* - * For the handling of continuation lines in literals we first check if - * this is actually a literal. For if not we can forego the additional - * processing. Otherwise we pre-allocate a small table to store the - * locations of all continuation lines we find in this literal, if any. - * The table is extended if needed. + * if this is actually a literal, handle continuation lines by + * preallocating a small table to store the locations of any continuation + * lines we find in this literal. The table is extended if needed. * - * Note: Different to the equivalent code in function 'TclSubstTokens()' - * (see file "tclParse.c") we do not seem to need the 'adjust' variable. - * We also do not seem to need code which merges continuation line - * information of multiple words which concat'd at runtime. Either that or - * I have not managed to find a test case for these two possibilities yet. - * It might be a difference between compile- versus run-time processing. + * Note: In contrast with the analagous code in 'TclSubstTokens()' the + * 'adjust' variable seems unneeded here. The code which merges + * continuation line information of multiple words which concat'd at + * runtime also seems unneeded. Either that or I have not managed to find a + * test case for these two possibilities yet. It might be a difference + * between compile- versus run-time processing. */ numCL = 0; @@ -2464,18 +2460,17 @@ TclCompileTokens( Tcl_DStringAppend(&textBuffer, buffer, length); /* - * If the backslash sequence we found is in a literal, and - * represented a continuation line, we compute and store its + * If the identified backslash sequence is in a literal and + * represented a continuation line, compute and store its * location (as char offset to the beginning of the _result_ * script). We may have to extend the table of locations. * - * Note that the continuation line information is relevant even if - * the word we are processing is not a literal, as it can affect - * nested commands. See the branch for TCL_TOKEN_COMMAND below, - * where the adjustment we are tracking here is taken into - * account. The good thing is that we do not need a table of - * everything, just the number of lines we have to add as - * correction. + * The continuation line information is relevant even if the word + * being processed is not a literal, as it can affect nested + * commands. See the branch below for TCL_TOKEN_COMMAND, where the + * adjustment being tracked here is taken into account. The good + * thing is a table of everything is not needed, just the number of + * lines to to add as correction. */ if ((length == 1) && (buffer[0] == ' ') && @@ -2601,13 +2596,13 @@ TclCompileTokens( * TclCompileCmdWord -- * * Given an array of parse tokens for a word containing one or more Tcl - * commands, emit inline instructions to execute them. This procedure - * differs from TclCompileTokens in that a simple word such as a loop - * body enclosed in braces is not just pushed as a string, but is itself - * parsed into tokens and compiled. + * commands, emits inline instructions to execute them. In contrast with + * TclCompileTokens, a simple word such as a loop body enclosed in braces + * is not just pushed as a string, but is itself parsed into tokens and + * compiled. * * Results: - * The return value is a standard Tcl result. If an error occurs, an + * A standard Tcl result. If an error occurs, an * error message is left in the interpreter's result. * * Side effects: @@ -2627,16 +2622,16 @@ TclCompileCmdWord( { if ((count == 1) && (tokenPtr->type == TCL_TOKEN_TEXT)) { /* - * Handle the common case: if there is a single text token, compile it + * The common case that there is a single text token. Compile it * into an inline sequence of instructions. */ TclCompileScript(interp, tokenPtr->start, tokenPtr->size, envPtr); } else { /* - * Multiple tokens or the single token involves substitutions. Emit - * instructions to invoke the eval command procedure at runtime on the - * result of evaluating the tokens. + * Either there are multiple tokens, or the single token involves + * substitutions. Emit instructions to invoke the eval command + * procedure at runtime on the result of evaluating the tokens. */ TclCompileTokens(interp, tokenPtr, count, envPtr); @@ -2650,13 +2645,12 @@ TclCompileCmdWord( * TclCompileExprWords -- * * Given an array of parse tokens representing one or more words that - * contain a Tcl expression, emit inline instructions to execute the - * expression. This procedure differs from TclCompileExpr in that it - * supports Tcl's two-level substitution semantics for expressions that - * appear as command words. + * contain a Tcl expression, emits inline instructions to execute the + * expression. In contrast with TclCompileExpr, supports Tcl's two-level + * substitution semantics for an expression that appears as command words. * * Results: - * The return value is a standard Tcl result. If an error occurs, an + * A standard Tcl result. If an error occurs, an * error message is left in the interpreter's result. * * Side effects: @@ -2718,10 +2712,10 @@ TclCompileExprWords( * * TclCompileNoOp -- * - * Function called to compile no-op's + * Compiles no-op's * * Results: - * The return value is TCL_OK, indicating successful compilation. + * TCL_OK if completion was successful. * * Side effects: * Instructions are added to envPtr to execute a no-op at runtime. No @@ -2760,14 +2754,14 @@ TclCompileNoOp( * * TclInitByteCodeObj -- * - * Create a ByteCode structure and initialize it from a CompileEnv + * Creates a ByteCode structure and initializes it from a CompileEnv * compilation environment structure. The ByteCode structure is smaller * and contains just that information needed to execute the bytecode * instructions resulting from compiling a Tcl script. The resulting * structure is placed in the specified object. * * Results: - * A newly constructed ByteCode object is stored in the internal + * A newly-constructed ByteCode object is stored in the internal * representation of the objPtr. * * Side effects: @@ -3102,16 +3096,15 @@ TclFindCompiledLocal( * * TclExpandCodeArray -- * - * Procedure that uses malloc to allocate more storage for a CompileEnv's - * code array. + * Uses malloc to allocate more storage for a CompileEnv's code array. * * Results: * None. * * Side effects: - * The byte code array in *envPtr is reallocated to a new array of double - * the size, and if envPtr->mallocedCodeArray is non-zero the old array - * is freed. Byte codes are copied from the old array to the new one. + * The size of the bytecode array is doubled. If envPtr->mallocedCodeArray + * is non-zero the old array is freed. Byte codes are copied from the old + * array to the new one. * *---------------------------------------------------------------------- */ @@ -3138,8 +3131,8 @@ TclExpandCodeArray( envPtr->codeStart = (unsigned char *)ckrealloc(envPtr->codeStart, newBytes); } else { /* - * envPtr->codeStart isn't a ckalloc'd pointer, so we must code a - * ckrealloc equivalent for ourselves. + * envPtr->exceptArrayPtr isn't a Tcl_Alloc'd pointer, so + * perform the equivalent of Tcl_Realloc directly. */ unsigned char *newPtr = (unsigned char *)ckalloc(newBytes); @@ -3455,7 +3448,7 @@ TclCreateExceptRange( * TclGetInnermostExceptionRange -- * * Returns the innermost exception range that covers the current code - * creation point, and (optionally) the stack depth that is expected at + * creation point, and optionally the stack depth that is expected at * that point. Relies on the fact that the range has a numCodeBytes = -1 * when it is being populated and that inner ranges come after outer * ranges. @@ -3497,7 +3490,7 @@ TclGetInnermostExceptionRange( * * Adds a place that wants to break/continue to the loop exception range * tracking that will be fixed up once the loop can be finalized. These - * functions will generate an INST_JUMP4 that will be fixed up during the + * functions generate an INST_JUMP4 that is fixed up during the * loop finalization. * * --------------------------------------------------------------------- @@ -3561,8 +3554,8 @@ TclAddLoopContinueFixup( * * TclCleanupStackForBreakContinue -- * - * Ditch the extra elements from the auxiliary stack and the main stack. - * How to do this exactly depends on whether there are any elements on + * Removes the extra elements from the auxiliary stack and the main stack. + * How this is done depends on whether there are any elements on * the auxiliary stack to pop. * * --------------------------------------------------------------------- @@ -3632,7 +3625,7 @@ StartExpanding( } /* - * Adequate condition: further out loops and further in exceptions + * Adequate condition: loops further out and exceptions further in * don't actually need this information. */ @@ -3642,7 +3635,7 @@ StartExpanding( } /* - * There's now one more expansion being processed on the auxiliary stack. + * One more expansion is now being processed on the auxiliary stack. */ envPtr->expandCount++; @@ -3655,7 +3648,7 @@ StartExpanding( * * Finalizes a loop exception range, binding the registered [break] and * [continue] implementations so that they jump to the correct place. - * Note that this must only be called after *all* the exception range + * This must be called only after *all* the exception range * target offsets have been set. * * --------------------------------------------------------------------- @@ -3726,21 +3719,17 @@ TclFinalizeLoopExceptionRange( * * TclCreateAuxData -- * - * Procedure that allocates and initializes a new AuxData structure in a + * Allocates and initializes a new AuxData structure in a * CompileEnv's array of compilation auxiliary data records. These * AuxData records hold information created during compilation by * CompileProcs and used by instructions during execution. * * Results: - * Returns the index for the newly created AuxData structure. + * The index of the newly-created AuxData structure in the array. * * Side effects: - * If there is not enough room in the CompileEnv's AuxData array, the - * AuxData array in expanded: a new array of double the size is - * allocated, if envPtr->mallocedAuxDataArray is non-zero the old array - * is freed, and AuxData entries are copied from the old array to the new - * one. - * + * If there is not enough room in the CompileEnv's AuxData array, its size + * is doubled. *---------------------------------------------------------------------- */ @@ -3828,8 +3817,7 @@ TclInitJumpFixupArray( * * TclExpandJumpFixupArray -- * - * Procedure that uses malloc to allocate more storage for a jump fixup - * array. + * Uses malloc to allocate more storage for a jump fixup array. * * Results: * None. @@ -3908,10 +3896,11 @@ TclFreeJumpFixupArray( * * TclEmitForwardJump -- * - * Procedure to emit a two-byte forward jump of kind "jumpType". Since - * the jump may later have to be grown to five bytes if the jump target - * is more than, say, 127 bytes away, this procedure also initializes a - * JumpFixup record with information about the jump. + * Emits a two-byte forward jump of kind "jumpType". Also initializes a + * JumpFixup record with information about the jump. Since may later be + * necessary to increase the size of the jump instruction to five bytes if + * the jump target is more than, say, 127 bytes away. + * * * Results: * None. @@ -3966,16 +3955,17 @@ TclEmitForwardJump( * * TclFixupForwardJump -- * - * Procedure that updates a previously-emitted forward jump to jump a - * specified number of bytes, "jumpDist". If necessary, the jump is grown - * from two to five bytes; this is done if the jump distance is greater - * than "distThreshold" (normally 127 bytes). The jump is described by a - * JumpFixup record previously initialized by TclEmitForwardJump. + * Modifies a previously-emitted forward jump to jump a specified number + * of bytes, "jumpDist". If necessary, the size of the jump instruction is + * increased from two to five bytes. This is done if the jump distance is + * greater than "distThreshold" (normally 127 bytes). The jump is + * described by a JumpFixup record previously initialized by + * TclEmitForwardJump. * * Results: - * 1 if the jump was grown and subsequent instructions had to be moved; - * otherwise 0. This result is returned to allow callers to update any - * additional code offsets they may hold. + * 1 if the jump was grown and subsequent instructions had to be moved, or + * 0 otherwsie. This allows callers to update any additional code offsets + * they may hold. * * Side effects: * The jump may be grown and subsequent instructions moved. If this @@ -4018,10 +4008,10 @@ TclFixupForwardJump( } /* - * We must grow the jump then move subsequent instructions down. Note that - * if we expand the space for generated instructions, code addresses might - * change; be careful about updating any of these addresses held in - * variables. + * Increase the size of the jump instruction, and then move subsequent + * instructions down. Expanding the space for generated instructions means + * that code addresses might change. Be careful about updating any of + * these addresses held in variables. */ if ((envPtr->codeNext + 3) > envPtr->codeEnd) { @@ -4105,7 +4095,7 @@ TclFixupForwardJump( * * TclEmitInvoke -- * - * Emit one of the invoke-related instructions, wrapping it if necessary + * Emits one of the invoke-related instructions, wrapping it if necessary * in code that ensures that any break or continue operation passing * through it gets the stack unwinding correct, converting it into an * internal jump if in an appropriate context. @@ -4115,7 +4105,7 @@ TclFixupForwardJump( * * Side effects: * Issues the jump with all correct stack management. May create another - * loop exception range; pointers to ExceptionRange and ExceptionAux + * loop exception range. Pointers to ExceptionRange and ExceptionAux * structures should not be held across this call. * *---------------------------------------------------------------------- @@ -4173,12 +4163,11 @@ TclEmitInvoke( va_end(argList); /* - * Determine if we need to handle break and continue exceptions with a - * special handling exception range (so that we can correctly unwind the - * stack). + * If the exceptions is for break or continue handle it with special + * handling exception range so the stack may be correctly unwound. * - * These must be done separately; they can be different (especially for - * calls from inside a [for] increment clause). + * These must be done separately since they can be different, especially + * for calls from inside a [for] increment clause. */ rangePtr = TclGetInnermostExceptionRange(envPtr, TCL_CONTINUE, @@ -4398,16 +4387,16 @@ GetCmdLocEncodingSize( * * EncodeCmdLocMap -- * - * Encode the command location information for some compiled code into a + * Encodes the command location information for some compiled code into a * ByteCode structure. The encoded command location map is stored as - * three adjacent byte sequences. + * three-adjacent-byte sequences. * * Results: - * Pointer to the first byte after the encoded command location + * A pointer to the first byte after the encoded command location * information. * * Side effects: - * The encoded information is stored into the block of memory headed by + * Stores encoded information into the block of memory headed by * codePtr. Also records pointers to the start of the four byte sequences * in fields in codePtr's ByteCode header structure. * @@ -4522,9 +4511,9 @@ EncodeCmdLocMap( * * RecordByteCodeStats -- * - * Accumulates various compilation-related statistics for each newly - * compiled ByteCode. Called by the TclInitByteCodeObj when Tcl is - * compiled with the -DTCL_COMPILE_STATS flag + * Accumulates compilation-related statistics for each newly-compiled + * ByteCode. Called by the TclInitByteCodeObj when Tcl is compiled with + * the -DTCL_COMPILE_STATS flag * * Results: * None. -- cgit v0.12 From fa2cb7883beede585b4082ff56dc6cb16872553b Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 6 Oct 2021 14:00:44 +0000 Subject: Fix problem with application manifest, supporting UTF-8 console (it appears that mingw is stricter than msvc on this) --- win/tclsh.exe.manifest.in | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/win/tclsh.exe.manifest.in b/win/tclsh.exe.manifest.in index d62044a..dc652e6 100644 --- a/win/tclsh.exe.manifest.in +++ b/win/tclsh.exe.manifest.in @@ -31,8 +31,12 @@ - + true + + UTF-8 -- cgit v0.12 From 0b1f6ed09a118b4d974ca8048adec672061662d1 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 6 Oct 2021 19:33:03 +0000 Subject: Change "IntRep" to "InternalRep", as discussed in the Tcl Core mailing list --- generic/tcl.decls | 8 +-- generic/tcl.h | 12 ++-- generic/tclAssembly.c | 10 ++-- generic/tclBasic.c | 18 +++--- generic/tclBinary.c | 74 ++++++++++++------------- generic/tclClock.c | 2 +- generic/tclCmdMZ.c | 20 +++---- generic/tclCompExpr.c | 10 ++-- generic/tclCompile.c | 14 ++--- generic/tclCompile.h | 36 ++++++------ generic/tclDecls.h | 26 ++++----- generic/tclDictObj.c | 58 ++++++++++---------- generic/tclDisassemble.c | 32 +++++------ generic/tclEncoding.c | 36 ++++++------ generic/tclEnsemble.c | 24 ++++---- generic/tclExecute.c | 52 +++++++++--------- generic/tclGet.c | 4 +- generic/tclIO.c | 40 +++++++------- generic/tclIndexObj.c | 32 +++++------ generic/tclInt.h | 24 ++++---- generic/tclLink.c | 6 +- generic/tclListObj.c | 140 +++++++++++++++++++++++------------------------ generic/tclLiteral.c | 6 +- generic/tclNamesp.c | 30 +++++----- generic/tclOOCall.c | 14 ++--- generic/tclOOMethod.c | 4 +- generic/tclObj.c | 56 +++++++++---------- generic/tclPathObj.c | 38 ++++++------- generic/tclProc.c | 72 ++++++++++++------------ generic/tclRegexp.c | 22 ++++---- generic/tclResult.c | 4 +- generic/tclScan.c | 4 +- generic/tclStrToD.c | 10 ++-- generic/tclStringObj.c | 28 +++++----- generic/tclStubInit.c | 6 +- generic/tclTest.c | 4 +- generic/tclUtil.c | 22 ++++---- generic/tclVar.c | 58 ++++++++++---------- macosx/tclMacOSXFCmd.c | 4 +- 39 files changed, 532 insertions(+), 528 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index 5d2fc62..6bf669e 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2348,18 +2348,18 @@ declare 635 { # TIP #445 declare 636 { - void Tcl_FreeIntRep(Tcl_Obj *objPtr) + void Tcl_FreeInternalRep(Tcl_Obj *objPtr) } declare 637 { char *Tcl_InitStringRep(Tcl_Obj *objPtr, const char *bytes, unsigned int numBytes) } declare 638 { - Tcl_ObjIntRep *Tcl_FetchIntRep(Tcl_Obj *objPtr, const Tcl_ObjType *typePtr) + Tcl_ObjInternalRep *Tcl_FetchInternalRep(Tcl_Obj *objPtr, const Tcl_ObjType *typePtr) } declare 639 { - void Tcl_StoreIntRep(Tcl_Obj *objPtr, const Tcl_ObjType *typePtr, - const Tcl_ObjIntRep *irPtr) + void Tcl_StoreInternalRep(Tcl_Obj *objPtr, const Tcl_ObjType *typePtr, + const Tcl_ObjInternalRep *irPtr) } declare 640 { int Tcl_HasStringRep(Tcl_Obj *objPtr) diff --git a/generic/tcl.h b/generic/tcl.h index 2d529b7..fa61efc 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -749,13 +749,13 @@ typedef struct Tcl_ObjType { } Tcl_ObjType; /* - * The following structure stores an internal representation (intrep) for - * a Tcl value. An intrep is associated with an Tcl_ObjType when both + * The following structure stores an internal representation (internalrep) for + * a Tcl value. An internalrep is associated with an Tcl_ObjType when both * are stored in the same Tcl_Obj. The routines of the Tcl_ObjType govern - * the handling of the intrep. + * the handling of the internalrep. */ -typedef union Tcl_ObjIntRep { /* The internal representation: */ +typedef union Tcl_ObjInternalRep { /* The internal representation: */ long longValue; /* - an long integer value. */ double doubleValue; /* - a double-precision floating value. */ void *otherValuePtr; /* - another, type-specific value, */ @@ -769,7 +769,7 @@ typedef union Tcl_ObjIntRep { /* The internal representation: */ void *ptr; /* not used internally any more. */ unsigned long value; } ptrAndLongRep; -} Tcl_ObjIntRep; +} Tcl_ObjInternalRep; /* * One of the following structures exists for each object in the Tcl system. @@ -796,7 +796,7 @@ typedef struct Tcl_Obj { * corresponds to the type of the object's * internal rep. NULL indicates the object has * no internal rep (has no type). */ - Tcl_ObjIntRep internalRep; /* The internal representation: */ + Tcl_ObjInternalRep internalRep; /* The internal representation: */ } Tcl_Obj; diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index a20cd1a..b429113 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -865,7 +865,7 @@ CompileAssembleObj( * is valid in the current context. */ - ByteCodeGetIntRep(objPtr, &assembleCodeType, codePtr); + ByteCodeGetInternalRep(objPtr, &assembleCodeType, codePtr); if (codePtr) { namespacePtr = iPtr->varFramePtr->nsPtr; @@ -882,7 +882,7 @@ CompileAssembleObj( * Not valid, so free it and regenerate. */ - Tcl_StoreIntRep(objPtr, &assembleCodeType, NULL); + Tcl_StoreInternalRep(objPtr, &assembleCodeType, NULL); } /* @@ -4289,7 +4289,7 @@ AddBasicBlockRangeToErrorInfo( * DupAssembleCodeInternalRep -- * * Part of the Tcl object type implementation for Tcl assembly language - * bytecode. We do not copy the bytecode intrep. Instead, we return + * bytecode. We do not copy the bytecode internalrep. Instead, we return * without setting copyPtr->typePtr, so the copy is a plain string copy * of the assembly source, and if it is to be used as a compiled * expression, it will need to be reprocessed. @@ -4298,7 +4298,7 @@ AddBasicBlockRangeToErrorInfo( * usual (only?) time Tcl_DuplicateObj() will be called is when the copy * is about to be modified, which would invalidate any copied bytecode * anyway. The only reason it might make sense to copy the bytecode is if - * we had some modifying routines that operated directly on the intrep, + * we had some modifying routines that operated directly on the internalrep, * as we do for lists and dicts. * * Results: @@ -4342,7 +4342,7 @@ FreeAssembleCodeInternalRep( { ByteCode *codePtr; - ByteCodeGetIntRep(objPtr, &assembleCodeType, codePtr); + ByteCodeGetInternalRep(objPtr, &assembleCodeType, codePtr); assert(codePtr != NULL); TclReleaseByteCode(codePtr); diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 69194f8..599366b 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -3959,8 +3959,8 @@ OldMathFuncProc( result = Tcl_GetDoubleFromObj(NULL, valuePtr, &d); #ifdef ACCEPT_NAN if (result != TCL_OK) { - const Tcl_ObjIntRep *irPtr - = TclFetchIntRep(valuePtr, &tclDoubleType); + const Tcl_ObjInternalRep *irPtr + = TclFetchInternalRep(valuePtr, &tclDoubleType); if (irPtr) { d = irPtr->doubleValue; @@ -7537,7 +7537,7 @@ ExprCeilFunc( code = Tcl_GetDoubleFromObj(interp, objv[1], &d); #ifdef ACCEPT_NAN if (code != TCL_OK) { - const Tcl_ObjIntRep *irPtr = TclFetchIntRep(objv[1], &tclDoubleType); + const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType); if (irPtr) { Tcl_SetObjResult(interp, objv[1]); @@ -7577,7 +7577,7 @@ ExprFloorFunc( code = Tcl_GetDoubleFromObj(interp, objv[1], &d); #ifdef ACCEPT_NAN if (code != TCL_OK) { - const Tcl_ObjIntRep *irPtr = TclFetchIntRep(objv[1], &tclDoubleType); + const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType); if (irPtr) { Tcl_SetObjResult(interp, objv[1]); @@ -7723,7 +7723,7 @@ ExprSqrtFunc( code = Tcl_GetDoubleFromObj(interp, objv[1], &d); #ifdef ACCEPT_NAN if (code != TCL_OK) { - const Tcl_ObjIntRep *irPtr = TclFetchIntRep(objv[1], &tclDoubleType); + const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType); if (irPtr) { Tcl_SetObjResult(interp, objv[1]); @@ -7777,7 +7777,7 @@ ExprUnaryFunc( code = Tcl_GetDoubleFromObj(interp, objv[1], &d); #ifdef ACCEPT_NAN if (code != TCL_OK) { - const Tcl_ObjIntRep *irPtr = TclFetchIntRep(objv[1], &tclDoubleType); + const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType); if (irPtr) { d = irPtr->doubleValue; @@ -7841,7 +7841,7 @@ ExprBinaryFunc( code = Tcl_GetDoubleFromObj(interp, objv[1], &d1); #ifdef ACCEPT_NAN if (code != TCL_OK) { - const Tcl_ObjIntRep *irPtr = TclFetchIntRep(objv[1], &tclDoubleType); + const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType); if (irPtr) { d1 = irPtr->doubleValue; @@ -7856,7 +7856,7 @@ ExprBinaryFunc( code = Tcl_GetDoubleFromObj(interp, objv[2], &d2); #ifdef ACCEPT_NAN if (code != TCL_OK) { - const Tcl_ObjIntRep *irPtr = TclFetchIntRep(objv[1], &tclDoubleType); + const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType); if (irPtr) { d2 = irPtr->doubleValue; @@ -8017,7 +8017,7 @@ ExprDoubleFunc( } if (Tcl_GetDoubleFromObj(interp, objv[1], &dResult) != TCL_OK) { #ifdef ACCEPT_NAN - if (TclHasIntRep(objv[1], &tclDoubleType)) { + if (TclHasInternalRep(objv[1], &tclDoubleType)) { Tcl_SetObjResult(interp, objv[1]); return TCL_OK; } diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 396beec..633bc1e 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -226,7 +226,7 @@ static const EnsembleImplMap decodeMap[] = { * implies a side testing burden -- past mistakes will not let us avoid that * immediately, but it is at least a conventional test of type, and can be * implemented entirely by examining the objPtr fields, with no need to query - * the intrep, as a canonical flag would require. + * the internalrep, as a canonical flag would require. * * Until Tcl_GetByteArrayFromObj() and Tcl_SetByteArrayLength() can be revised * to admit the possibility of returning NULL when the true value is not a @@ -289,7 +289,7 @@ int TclIsPureByteArray( Tcl_Obj * objPtr) { - return TclHasIntRep(objPtr, &properByteArrayType); + return TclHasInternalRep(objPtr, &properByteArrayType); } /* @@ -414,7 +414,7 @@ Tcl_SetByteArrayObj( * be >= 0. */ { ByteArray *byteArrayPtr; - Tcl_ObjIntRep ir; + Tcl_ObjInternalRep ir; if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object", "Tcl_SetByteArrayObj"); @@ -434,7 +434,7 @@ Tcl_SetByteArrayObj( } SET_BYTEARRAY(&ir, byteArrayPtr); - Tcl_StoreIntRep(objPtr, &properByteArrayType, &ir); + Tcl_StoreInternalRep(objPtr, &properByteArrayType, &ir); } /* @@ -462,17 +462,17 @@ TclGetBytesFromObj( * array of bytes in the ByteArray object. */ { ByteArray *baPtr; - const Tcl_ObjIntRep *irPtr = TclFetchIntRep(objPtr, &properByteArrayType); + const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objPtr, &properByteArrayType); if (irPtr == NULL) { SetByteArrayFromAny(NULL, objPtr); - irPtr = TclFetchIntRep(objPtr, &properByteArrayType); + irPtr = TclFetchInternalRep(objPtr, &properByteArrayType); if (irPtr == NULL) { if (interp) { const char *nonbyte; int ucs4; - irPtr = TclFetchIntRep(objPtr, &tclByteArrayType); + irPtr = TclFetchInternalRep(objPtr, &tclByteArrayType); baPtr = GET_BYTEARRAY(irPtr); nonbyte = Tcl_UtfAtIndex(Tcl_GetString(objPtr), baPtr->bad); TclUtfToUCS4(nonbyte, &ucs4); @@ -519,14 +519,14 @@ Tcl_GetByteArrayFromObj( * array of bytes in the ByteArray object. */ { ByteArray *baPtr; - const Tcl_ObjIntRep *irPtr; + const Tcl_ObjInternalRep *irPtr; unsigned char *result = TclGetBytesFromObj(NULL, objPtr, lengthPtr); if (result) { return result; } - irPtr = TclFetchIntRep(objPtr, &tclByteArrayType); + irPtr = TclFetchInternalRep(objPtr, &tclByteArrayType); assert(irPtr != NULL); baPtr = GET_BYTEARRAY(irPtr); @@ -544,14 +544,14 @@ TclGetByteArrayFromObj( * array of bytes in the ByteArray object. */ { ByteArray *baPtr; - const Tcl_ObjIntRep *irPtr; + const Tcl_ObjInternalRep *irPtr; unsigned char *result = TclGetBytesFromObj(NULL, objPtr, (int *)NULL); if (result) { return result; } - irPtr = TclFetchIntRep(objPtr, &tclByteArrayType); + irPtr = TclFetchInternalRep(objPtr, &tclByteArrayType); assert(irPtr != NULL); baPtr = GET_BYTEARRAY(irPtr); @@ -595,7 +595,7 @@ Tcl_SetByteArrayLength( { ByteArray *byteArrayPtr; unsigned newLength; - Tcl_ObjIntRep *irPtr; + Tcl_ObjInternalRep *irPtr; assert(length >= 0); newLength = (unsigned int)length; @@ -604,14 +604,14 @@ Tcl_SetByteArrayLength( Tcl_Panic("%s called with shared object", "Tcl_SetByteArrayLength"); } - irPtr = TclFetchIntRep(objPtr, &properByteArrayType); + irPtr = TclFetchInternalRep(objPtr, &properByteArrayType); if (irPtr == NULL) { - irPtr = TclFetchIntRep(objPtr, &tclByteArrayType); + irPtr = TclFetchInternalRep(objPtr, &tclByteArrayType); if (irPtr == NULL) { SetByteArrayFromAny(NULL, objPtr); - irPtr = TclFetchIntRep(objPtr, &properByteArrayType); + irPtr = TclFetchInternalRep(objPtr, &properByteArrayType); if (irPtr == NULL) { - irPtr = TclFetchIntRep(objPtr, &tclByteArrayType); + irPtr = TclFetchInternalRep(objPtr, &tclByteArrayType); } } } @@ -655,12 +655,12 @@ SetByteArrayFromAny( unsigned char *dst; Tcl_UniChar ch = 0; ByteArray *byteArrayPtr; - Tcl_ObjIntRep ir; + Tcl_ObjInternalRep ir; - if (TclHasIntRep(objPtr, &properByteArrayType)) { + if (TclHasInternalRep(objPtr, &properByteArrayType)) { return TCL_OK; } - if (TclHasIntRep(objPtr, &tclByteArrayType)) { + if (TclHasInternalRep(objPtr, &tclByteArrayType)) { return TCL_OK; } @@ -683,10 +683,10 @@ SetByteArrayFromAny( if (bad == length) { byteArrayPtr->bad = byteArrayPtr->used; - Tcl_StoreIntRep(objPtr, &properByteArrayType, &ir); + Tcl_StoreInternalRep(objPtr, &properByteArrayType, &ir); } else { byteArrayPtr->bad = bad; - Tcl_StoreIntRep(objPtr, &tclByteArrayType, &ir); + Tcl_StoreInternalRep(objPtr, &tclByteArrayType, &ir); } return TCL_OK; @@ -713,14 +713,14 @@ static void FreeByteArrayInternalRep( Tcl_Obj *objPtr) /* Object with internal rep to free. */ { - ckfree(GET_BYTEARRAY(TclFetchIntRep(objPtr, &tclByteArrayType))); + ckfree(GET_BYTEARRAY(TclFetchInternalRep(objPtr, &tclByteArrayType))); } static void FreeProperByteArrayInternalRep( Tcl_Obj *objPtr) /* Object with internal rep to free. */ { - ckfree(GET_BYTEARRAY(TclFetchIntRep(objPtr, &properByteArrayType))); + ckfree(GET_BYTEARRAY(TclFetchInternalRep(objPtr, &properByteArrayType))); } /* @@ -747,9 +747,9 @@ DupByteArrayInternalRep( { unsigned int length; ByteArray *srcArrayPtr, *copyArrayPtr; - Tcl_ObjIntRep ir; + Tcl_ObjInternalRep ir; - srcArrayPtr = GET_BYTEARRAY(TclFetchIntRep(srcPtr, &tclByteArrayType)); + srcArrayPtr = GET_BYTEARRAY(TclFetchInternalRep(srcPtr, &tclByteArrayType)); length = srcArrayPtr->used; copyArrayPtr = (ByteArray *)ckalloc(BYTEARRAY_SIZE(length)); @@ -759,7 +759,7 @@ DupByteArrayInternalRep( memcpy(copyArrayPtr->bytes, srcArrayPtr->bytes, length); SET_BYTEARRAY(&ir, copyArrayPtr); - Tcl_StoreIntRep(copyPtr, &tclByteArrayType, &ir); + Tcl_StoreInternalRep(copyPtr, &tclByteArrayType, &ir); } static void @@ -769,9 +769,9 @@ DupProperByteArrayInternalRep( { unsigned int length; ByteArray *srcArrayPtr, *copyArrayPtr; - Tcl_ObjIntRep ir; + Tcl_ObjInternalRep ir; - srcArrayPtr = GET_BYTEARRAY(TclFetchIntRep(srcPtr, &properByteArrayType)); + srcArrayPtr = GET_BYTEARRAY(TclFetchInternalRep(srcPtr, &properByteArrayType)); length = srcArrayPtr->used; copyArrayPtr = (ByteArray *)ckalloc(BYTEARRAY_SIZE(length)); @@ -781,7 +781,7 @@ DupProperByteArrayInternalRep( memcpy(copyArrayPtr->bytes, srcArrayPtr->bytes, length); SET_BYTEARRAY(&ir, copyArrayPtr); - Tcl_StoreIntRep(copyPtr, &properByteArrayType, &ir); + Tcl_StoreInternalRep(copyPtr, &properByteArrayType, &ir); } /* @@ -806,7 +806,7 @@ UpdateStringOfByteArray( Tcl_Obj *objPtr) /* ByteArray object whose string rep to * update. */ { - const Tcl_ObjIntRep *irPtr = TclFetchIntRep(objPtr, &properByteArrayType); + const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objPtr, &properByteArrayType); ByteArray *byteArrayPtr = GET_BYTEARRAY(irPtr); unsigned char *src = byteArrayPtr->bytes; unsigned int i, length = byteArrayPtr->used; @@ -867,7 +867,7 @@ TclAppendBytesToByteArray( { ByteArray *byteArrayPtr; unsigned int length, needed; - Tcl_ObjIntRep *irPtr; + Tcl_ObjInternalRep *irPtr; if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object","TclAppendBytesToByteArray"); @@ -886,14 +886,14 @@ TclAppendBytesToByteArray( length = (unsigned int) len; - irPtr = TclFetchIntRep(objPtr, &properByteArrayType); + irPtr = TclFetchInternalRep(objPtr, &properByteArrayType); if (irPtr == NULL) { - irPtr = TclFetchIntRep(objPtr, &tclByteArrayType); + irPtr = TclFetchInternalRep(objPtr, &tclByteArrayType); if (irPtr == NULL) { SetByteArrayFromAny(NULL, objPtr); - irPtr = TclFetchIntRep(objPtr, &properByteArrayType); + irPtr = TclFetchInternalRep(objPtr, &properByteArrayType); if (irPtr == NULL) { - irPtr = TclFetchIntRep(objPtr, &tclByteArrayType); + irPtr = TclFetchInternalRep(objPtr, &tclByteArrayType); } } } @@ -2158,7 +2158,7 @@ FormatNumber( */ if (Tcl_GetDoubleFromObj(interp, src, &dvalue) != TCL_OK) { - const Tcl_ObjIntRep *irPtr = TclFetchIntRep(src, &tclDoubleType); + const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(src, &tclDoubleType); if (irPtr == NULL) { return TCL_ERROR; } @@ -2178,7 +2178,7 @@ FormatNumber( */ if (Tcl_GetDoubleFromObj(interp, src, &dvalue) != TCL_OK) { - const Tcl_ObjIntRep *irPtr = TclFetchIntRep(src, &tclDoubleType); + const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(src, &tclDoubleType); if (irPtr == NULL) { return TCL_ERROR; diff --git a/generic/tclClock.c b/generic/tclClock.c index 90a998d..4473f74 100644 --- a/generic/tclClock.c +++ b/generic/tclClock.c @@ -452,7 +452,7 @@ ClockGetdatefieldsObjCmd( * that it isn't. */ - if (TclHasIntRep(objv[1], &tclBignumType)) { + if (TclHasInternalRep(objv[1], &tclBignumType)) { Tcl_SetObjResult(interp, lit[LIT_INTEGER_VALUE_TOO_LARGE]); return TCL_ERROR; } diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index d37f5bf..f8f0004 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -1611,7 +1611,7 @@ StringIsCmd( case STR_IS_BOOL: case STR_IS_TRUE: case STR_IS_FALSE: - if (!TclHasIntRep(objPtr, &tclBooleanType) + if (!TclHasInternalRep(objPtr, &tclBooleanType) && (TCL_OK != TclSetBooleanFromAny(NULL, objPtr))) { if (strict) { result = 0; @@ -1681,9 +1681,9 @@ StringIsCmd( chcomp = Tcl_UniCharIsDigit; break; case STR_IS_DOUBLE: { - if (TclHasIntRep(objPtr, &tclDoubleType) || - TclHasIntRep(objPtr, &tclIntType) || - TclHasIntRep(objPtr, &tclBignumType)) { + if (TclHasInternalRep(objPtr, &tclDoubleType) || + TclHasInternalRep(objPtr, &tclIntType) || + TclHasInternalRep(objPtr, &tclBignumType)) { break; } string1 = TclGetStringFromObj(objPtr, &length1); @@ -1702,7 +1702,7 @@ StringIsCmd( failat = stop - string1; if (stop < end) { result = 0; - TclFreeIntRep(objPtr); + TclFreeInternalRep(objPtr); } } break; @@ -1712,8 +1712,8 @@ StringIsCmd( break; case STR_IS_INT: case STR_IS_ENTIER: - if (TclHasIntRep(objPtr, &tclIntType) || - TclHasIntRep(objPtr, &tclBignumType)) { + if (TclHasInternalRep(objPtr, &tclIntType) || + TclHasInternalRep(objPtr, &tclBignumType)) { break; } string1 = TclGetStringFromObj(objPtr, &length1); @@ -1742,7 +1742,7 @@ StringIsCmd( result = 0; failat = stop - string1; - TclFreeIntRep(objPtr); + TclFreeInternalRep(objPtr); } } else { /* @@ -1795,7 +1795,7 @@ StringIsCmd( */ failat = stop - string1; - TclFreeIntRep(objPtr); + TclFreeInternalRep(objPtr); } } else { /* @@ -1990,7 +1990,7 @@ StringMapCmd( */ if (!TclHasStringRep(objv[objc-2]) - && TclHasIntRep(objv[objc-2], &tclDictType)) { + && TclHasInternalRep(objv[objc-2], &tclDictType)) { int i, done; Tcl_DictSearch search; diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index 03aebe3..23d8711 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -2109,7 +2109,7 @@ ParseLexeme( * Example: Inf + luence + () becomes a valid function call. * [Bug 3401704] */ - if (TclHasIntRep(literal, &tclDoubleType)) { + if (TclHasInternalRep(literal, &tclDoubleType)) { const char *p = start; while (p < end) { @@ -2520,7 +2520,7 @@ CompileExprTree( * However, the design of the "global" and "local" * LiteralTable does not permit the value of lePtr->objPtr * to change. So rather than replace lePtr->objPtr, we do - * surgery to transfer our desired intrep into it. + * surgery to transfer our desired internalrep into it. */ objPtr->typePtr = literal->typePtr; @@ -2533,9 +2533,9 @@ CompileExprTree( * When optimize==0, we know the expression is a one-off and * there's nothing to be gained from sharing literals when * they won't live long, and the copies we have already have - * an appropriate intrep. In this case, skip literal + * an appropriate internalrep. In this case, skip literal * registration that would enable sharing, and use the routine - * that preserves intreps. + * that preserves internalreps. */ TclEmitPush(TclAddLiteralObj(envPtr, literal, NULL), envPtr); @@ -2572,7 +2572,7 @@ CompileExprTree( if ((tableValue->typePtr == NULL) && (objPtr->typePtr != NULL)) { /* - * Same intrep surgery as for OT_LITERAL. + * Same internalrep surgery as for OT_LITERAL. */ tableValue->typePtr = objPtr->typePtr; diff --git a/generic/tclCompile.c b/generic/tclCompile.c index f966979..5b047b3 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -990,7 +990,7 @@ FreeByteCodeInternalRep( { ByteCode *codePtr; - ByteCodeGetIntRep(objPtr, &tclByteCodeType, codePtr); + ByteCodeGetInternalRep(objPtr, &tclByteCodeType, codePtr); assert(codePtr != NULL); TclReleaseByteCode(codePtr); @@ -1320,7 +1320,7 @@ CompileSubstObj( Interp *iPtr = (Interp *) interp; ByteCode *codePtr = NULL; - ByteCodeGetIntRep(objPtr, &substCodeType, codePtr); + ByteCodeGetInternalRep(objPtr, &substCodeType, codePtr); if (codePtr != NULL) { Namespace *nsPtr = iPtr->varFramePtr->nsPtr; @@ -1332,7 +1332,7 @@ CompileSubstObj( || (codePtr->nsEpoch != nsPtr->resolverEpoch) || (codePtr->localCachePtr != iPtr->varFramePtr->localCachePtr)) { - Tcl_StoreIntRep(objPtr, &substCodeType, NULL); + Tcl_StoreInternalRep(objPtr, &substCodeType, NULL); codePtr = NULL; } } @@ -1391,7 +1391,7 @@ FreeSubstCodeInternalRep( { ByteCode *codePtr; - ByteCodeGetIntRep(objPtr, &substCodeType, codePtr); + ByteCodeGetInternalRep(objPtr, &substCodeType, codePtr); assert(codePtr != NULL); TclReleaseByteCode(codePtr); @@ -2784,7 +2784,7 @@ PreventCycle( for (i = 0; i < envPtr->literalArrayNext; i++) { if (objPtr == TclFetchLiteral(envPtr, i)) { /* - * Prevent circular reference where the bytecode intrep of + * Prevent circular reference where the bytecode internalrep of * a value contains a literal which is that same value. * If this is allowed to happen, refcount decrements may not * reach zero, and memory may leak. Bugs 467523, 3357771 @@ -2792,7 +2792,7 @@ PreventCycle( * NOTE: [Bugs 3392070, 3389764] We make a copy based completely * on the string value, and do not call Tcl_DuplicateObj() so we * can be sure we do not have any lingering cycles hiding in - * the intrep. + * the internalrep. */ int numBytes; const char *bytes = TclGetStringFromObj(objPtr, &numBytes); @@ -2963,7 +2963,7 @@ TclInitByteCodeObj( * by making its internal rep point to the just compiled ByteCode. */ - ByteCodeSetIntRep(objPtr, typePtr, codePtr); + ByteCodeSetInternalRep(objPtr, typePtr, codePtr); return codePtr; } diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 6a5faaf..96a3541 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -217,9 +217,9 @@ typedef struct ExtCmdLoc { * the AuxData structure. */ -typedef ClientData (AuxDataDupProc) (ClientData clientData); -typedef void (AuxDataFreeProc) (ClientData clientData); -typedef void (AuxDataPrintProc)(ClientData clientData, +typedef void *(AuxDataDupProc) (void *clientData); +typedef void (AuxDataFreeProc) (void *clientData); +typedef void (AuxDataPrintProc)(void *clientData, Tcl_Obj *appendObj, struct ByteCode *codePtr, unsigned int pcOffset); @@ -515,20 +515,20 @@ typedef struct ByteCode { #endif /* TCL_COMPILE_STATS */ } ByteCode; -#define ByteCodeSetIntRep(objPtr, typePtr, codePtr) \ +#define ByteCodeSetInternalRep(objPtr, typePtr, codePtr) \ do { \ - Tcl_ObjIntRep ir; \ + Tcl_ObjInternalRep ir; \ ir.twoPtrValue.ptr1 = (codePtr); \ ir.twoPtrValue.ptr2 = NULL; \ - Tcl_StoreIntRep((objPtr), (typePtr), &ir); \ + Tcl_StoreInternalRep((objPtr), (typePtr), &ir); \ } while (0) -#define ByteCodeGetIntRep(objPtr, typePtr, codePtr) \ +#define ByteCodeGetInternalRep(objPtr, typePtr, codePtr) \ do { \ - const Tcl_ObjIntRep *irPtr; \ - irPtr = TclFetchIntRep((objPtr), (typePtr)); \ + const Tcl_ObjInternalRep *irPtr; \ + irPtr = TclFetchInternalRep((objPtr), (typePtr)); \ (codePtr) = irPtr ? (ByteCode*)irPtr->twoPtrValue.ptr1 : NULL; \ } while (0) @@ -1118,7 +1118,7 @@ MODULE_SCOPE void TclCompileTokens(Tcl_Interp *interp, CompileEnv *envPtr); MODULE_SCOPE void TclCompileVarSubst(Tcl_Interp *interp, Tcl_Token *tokenPtr, CompileEnv *envPtr); -MODULE_SCOPE int TclCreateAuxData(ClientData clientData, +MODULE_SCOPE int TclCreateAuxData(void *clientData, const AuxDataType *typePtr, CompileEnv *envPtr); MODULE_SCOPE int TclCreateExceptRange(ExceptionRangeType type, CompileEnv *envPtr); @@ -1192,16 +1192,16 @@ MODULE_SCOPE void TclReleaseByteCode(ByteCode *codePtr); MODULE_SCOPE void TclReleaseLiteral(Tcl_Interp *interp, Tcl_Obj *objPtr); MODULE_SCOPE void TclInvalidateCmdLiteral(Tcl_Interp *interp, const char *name, Namespace *nsPtr); -MODULE_SCOPE int TclSingleOpCmd(ClientData clientData, +MODULE_SCOPE int TclSingleOpCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int TclSortingOpCmd(ClientData clientData, +MODULE_SCOPE int TclSortingOpCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int TclVariadicOpCmd(ClientData clientData, +MODULE_SCOPE int TclVariadicOpCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int TclNoIdentOpCmd(ClientData clientData, +MODULE_SCOPE int TclNoIdentOpCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); #ifdef TCL_COMPILE_DEBUG @@ -1217,7 +1217,7 @@ MODULE_SCOPE void TclLogCommandInfo(Tcl_Interp *interp, MODULE_SCOPE Tcl_Obj *TclGetInnerContext(Tcl_Interp *interp, const unsigned char *pc, Tcl_Obj **tosPtr); MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst); -MODULE_SCOPE int TclPushProcCallFrame(ClientData clientData, +MODULE_SCOPE int TclPushProcCallFrame(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int isLambda); @@ -1232,7 +1232,7 @@ MODULE_SCOPE int TclPushProcCallFrame(ClientData clientData, /* * Simplified form to access AuxData. * - * ClientData TclFetchAuxData(CompileEng *envPtr, int index); + * void *TclFetchAuxData(CompileEng *envPtr, int index); */ #define TclFetchAuxData(envPtr, index) \ @@ -1557,9 +1557,9 @@ MODULE_SCOPE int TclPushProcCallFrame(ClientData clientData, */ #define PushLiteral(envPtr, string, length) \ - TclEmitPush(TclRegisterLiteral(envPtr, string, length, 0), (envPtr)) + TclEmitPush(TclRegisterLiteral((envPtr), (string), (length), 0), (envPtr)) #define PushStringLiteral(envPtr, string) \ - PushLiteral(envPtr, string, (int) (sizeof(string "") - 1)) + PushLiteral((envPtr), (string), (int) (sizeof(string "") - 1)) /* * Macro to advance to the next token; it is more mnemonic than the address diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 7d2e202..f833206 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1886,17 +1886,17 @@ EXTERN int TclZipfs_MountBuffer(Tcl_Interp *interp, const char *mountPoint, unsigned char *data, size_t datalen, int copy); /* 636 */ -EXTERN void Tcl_FreeIntRep(Tcl_Obj *objPtr); +EXTERN void Tcl_FreeInternalRep(Tcl_Obj *objPtr); /* 637 */ EXTERN char * Tcl_InitStringRep(Tcl_Obj *objPtr, const char *bytes, unsigned int numBytes); /* 638 */ -EXTERN Tcl_ObjIntRep * Tcl_FetchIntRep(Tcl_Obj *objPtr, +EXTERN Tcl_ObjInternalRep * Tcl_FetchInternalRep(Tcl_Obj *objPtr, const Tcl_ObjType *typePtr); /* 639 */ -EXTERN void Tcl_StoreIntRep(Tcl_Obj *objPtr, +EXTERN void Tcl_StoreInternalRep(Tcl_Obj *objPtr, const Tcl_ObjType *typePtr, - const Tcl_ObjIntRep *irPtr); + const Tcl_ObjInternalRep *irPtr); /* 640 */ EXTERN int Tcl_HasStringRep(Tcl_Obj *objPtr); /* 641 */ @@ -2615,10 +2615,10 @@ typedef struct TclStubs { int (*tclZipfs_Unmount) (Tcl_Interp *interp, const char *mountPoint); /* 633 */ Tcl_Obj * (*tclZipfs_TclLibrary) (void); /* 634 */ int (*tclZipfs_MountBuffer) (Tcl_Interp *interp, const char *mountPoint, unsigned char *data, size_t datalen, int copy); /* 635 */ - void (*tcl_FreeIntRep) (Tcl_Obj *objPtr); /* 636 */ + void (*tcl_FreeInternalRep) (Tcl_Obj *objPtr); /* 636 */ char * (*tcl_InitStringRep) (Tcl_Obj *objPtr, const char *bytes, unsigned int numBytes); /* 637 */ - Tcl_ObjIntRep * (*tcl_FetchIntRep) (Tcl_Obj *objPtr, const Tcl_ObjType *typePtr); /* 638 */ - void (*tcl_StoreIntRep) (Tcl_Obj *objPtr, const Tcl_ObjType *typePtr, const Tcl_ObjIntRep *irPtr); /* 639 */ + Tcl_ObjInternalRep * (*tcl_FetchInternalRep) (Tcl_Obj *objPtr, const Tcl_ObjType *typePtr); /* 638 */ + void (*tcl_StoreInternalRep) (Tcl_Obj *objPtr, const Tcl_ObjType *typePtr, const Tcl_ObjInternalRep *irPtr); /* 639 */ int (*tcl_HasStringRep) (Tcl_Obj *objPtr); /* 640 */ void (*tcl_IncrRefCount) (Tcl_Obj *objPtr); /* 641 */ void (*tcl_DecrRefCount) (Tcl_Obj *objPtr); /* 642 */ @@ -3942,14 +3942,14 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tclZipfs_TclLibrary) /* 634 */ #define TclZipfs_MountBuffer \ (tclStubsPtr->tclZipfs_MountBuffer) /* 635 */ -#define Tcl_FreeIntRep \ - (tclStubsPtr->tcl_FreeIntRep) /* 636 */ +#define Tcl_FreeInternalRep \ + (tclStubsPtr->tcl_FreeInternalRep) /* 636 */ #define Tcl_InitStringRep \ (tclStubsPtr->tcl_InitStringRep) /* 637 */ -#define Tcl_FetchIntRep \ - (tclStubsPtr->tcl_FetchIntRep) /* 638 */ -#define Tcl_StoreIntRep \ - (tclStubsPtr->tcl_StoreIntRep) /* 639 */ +#define Tcl_FetchInternalRep \ + (tclStubsPtr->tcl_FetchInternalRep) /* 638 */ +#define Tcl_StoreInternalRep \ + (tclStubsPtr->tcl_StoreInternalRep) /* 639 */ #define Tcl_HasStringRep \ (tclStubsPtr->tcl_HasStringRep) /* 640 */ #define Tcl_IncrRefCount \ diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index a0ce8a4..900974f 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -149,18 +149,18 @@ const Tcl_ObjType tclDictType = { SetDictFromAny /* setFromAnyProc */ }; -#define DictSetIntRep(objPtr, dictRepPtr) \ +#define DictSetInternalRep(objPtr, dictRepPtr) \ do { \ - Tcl_ObjIntRep ir; \ + Tcl_ObjInternalRep ir; \ ir.twoPtrValue.ptr1 = (dictRepPtr); \ ir.twoPtrValue.ptr2 = NULL; \ - Tcl_StoreIntRep((objPtr), &tclDictType, &ir); \ + Tcl_StoreInternalRep((objPtr), &tclDictType, &ir); \ } while (0) -#define DictGetIntRep(objPtr, dictRepPtr) \ +#define DictGetInternalRep(objPtr, dictRepPtr) \ do { \ - const Tcl_ObjIntRep *irPtr; \ - irPtr = TclFetchIntRep((objPtr), &tclDictType); \ + const Tcl_ObjInternalRep *irPtr; \ + irPtr = TclFetchInternalRep((objPtr), &tclDictType); \ (dictRepPtr) = irPtr ? (Dict *)irPtr->twoPtrValue.ptr1 : NULL; \ } while (0) @@ -362,7 +362,7 @@ DupDictInternalRep( Dict *oldDict, *newDict = (Dict *)ckalloc(sizeof(Dict)); ChainEntry *cPtr; - DictGetIntRep(srcPtr, oldDict); + DictGetInternalRep(srcPtr, oldDict); /* * Copy values across from the old hash table. @@ -395,7 +395,7 @@ DupDictInternalRep( * Store in the object. */ - DictSetIntRep(copyPtr, newDict); + DictSetInternalRep(copyPtr, newDict); } /* @@ -422,7 +422,7 @@ FreeDictInternalRep( { Dict *dict; - DictGetIntRep(dictPtr, dict); + DictGetInternalRep(dictPtr, dict); if (dict->refCount-- <= 1) { DeleteDict(dict); @@ -499,7 +499,7 @@ UpdateStringOfDict( int numElems; - DictGetIntRep(dictPtr, dict); + DictGetInternalRep(dictPtr, dict); assert (dict != NULL); @@ -610,7 +610,7 @@ SetDictFromAny( * the conversion from lists to dictionaries. */ - if (TclHasIntRep(objPtr, &tclListType)) { + if (TclHasInternalRep(objPtr, &tclListType)) { int objc, i; Tcl_Obj **objv; @@ -717,7 +717,7 @@ SetDictFromAny( dict->epoch = 1; dict->chain = NULL; dict->refCount = 1; - DictSetIntRep(objPtr, dict); + DictSetInternalRep(objPtr, dict); return TCL_OK; missingValue: @@ -739,12 +739,12 @@ GetDictFromObj( { Dict *dict; - DictGetIntRep(dictPtr, dict); + DictGetInternalRep(dictPtr, dict); if (dict == NULL) { if (SetDictFromAny(interp, dictPtr) != TCL_OK) { return NULL; } - DictGetIntRep(dictPtr, dict); + DictGetInternalRep(dictPtr, dict); } return dict; } @@ -792,12 +792,12 @@ TclTraceDictPath( Dict *dict, *newDict; int i; - DictGetIntRep(dictPtr, dict); + DictGetInternalRep(dictPtr, dict); if (dict == NULL) { if (SetDictFromAny(interp, dictPtr) != TCL_OK) { return NULL; } - DictGetIntRep(dictPtr, dict); + DictGetInternalRep(dictPtr, dict); } if (flags & DICT_PATH_UPDATE) { dict->chain = NULL; @@ -835,7 +835,7 @@ TclTraceDictPath( } else { tmpObj = (Tcl_Obj *)Tcl_GetHashValue(hPtr); - DictGetIntRep(tmpObj, newDict); + DictGetInternalRep(tmpObj, newDict); if (newDict == NULL) { if (SetDictFromAny(interp, tmpObj) != TCL_OK) { @@ -844,7 +844,7 @@ TclTraceDictPath( } } - DictGetIntRep(tmpObj, newDict); + DictGetInternalRep(tmpObj, newDict); if (flags & DICT_PATH_UPDATE) { if (Tcl_IsShared(tmpObj)) { TclDecrRefCount(tmpObj); @@ -852,7 +852,7 @@ TclTraceDictPath( Tcl_IncrRefCount(tmpObj); Tcl_SetHashValue(hPtr, tmpObj); dict->epoch++; - DictGetIntRep(tmpObj, newDict); + DictGetInternalRep(tmpObj, newDict); } newDict->chain = dictPtr; @@ -889,14 +889,14 @@ InvalidateDictChain( { Dict *dict; - DictGetIntRep(dictObj, dict); + DictGetInternalRep(dictObj, dict); assert( dict != NULL); do { dict->refCount++; TclInvalidateStringRep(dictObj); - TclFreeIntRep(dictObj); - DictSetIntRep(dictObj, dict); + TclFreeInternalRep(dictObj); + DictSetInternalRep(dictObj, dict); dict->epoch++; dictObj = dict->chain; @@ -904,7 +904,7 @@ InvalidateDictChain( break; } dict->chain = NULL; - DictGetIntRep(dictObj, dict); + DictGetInternalRep(dictObj, dict); } while (dict != NULL); } @@ -950,8 +950,8 @@ Tcl_DictObjPut( TclInvalidateStringRep(dictPtr); hPtr = CreateChainEntry(dict, keyPtr, &isNew); dict->refCount++; - TclFreeIntRep(dictPtr) - DictSetIntRep(dictPtr, dict); + TclFreeInternalRep(dictPtr) + DictSetInternalRep(dictPtr, dict); Tcl_IncrRefCount(valuePtr); if (!isNew) { Tcl_Obj *oldValuePtr = (Tcl_Obj *)Tcl_GetHashValue(hPtr); @@ -1306,7 +1306,7 @@ Tcl_DictObjPutKeyList( return TCL_ERROR; } - DictGetIntRep(dictPtr, dict); + DictGetInternalRep(dictPtr, dict); assert(dict != NULL); hPtr = CreateChainEntry(dict, keyv[keyc-1], &isNew); Tcl_IncrRefCount(valuePtr); @@ -1364,7 +1364,7 @@ Tcl_DictObjRemoveKeyList( return TCL_ERROR; } - DictGetIntRep(dictPtr, dict); + DictGetInternalRep(dictPtr, dict); assert(dict != NULL); DeleteChainEntry(dict, keyv[keyc-1]); InvalidateDictChain(dictPtr); @@ -1411,7 +1411,7 @@ Tcl_NewDictObj(void) dict->epoch = 1; dict->chain = NULL; dict->refCount = 1; - DictSetIntRep(dictPtr, dict); + DictSetInternalRep(dictPtr, dict); return dictPtr; #endif } @@ -1459,7 +1459,7 @@ Tcl_DbNewDictObj( dict->epoch = 1; dict->chain = NULL; dict->refCount = 1; - DictSetIntRep(dictPtr, dict); + DictSetInternalRep(dictPtr, dict); return dictPtr; } #else /* !TCL_MEM_DEBUG */ diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c index f5cc8b7..7bc1c97 100644 --- a/generic/tclDisassemble.c +++ b/generic/tclDisassemble.c @@ -44,17 +44,17 @@ static const Tcl_ObjType instNameType = { NULL, /* setFromAnyProc */ }; -#define InstNameSetIntRep(objPtr, inst) \ +#define InstNameSetInternalRep(objPtr, inst) \ do { \ - Tcl_ObjIntRep ir; \ + Tcl_ObjInternalRep ir; \ ir.wideValue = (inst); \ - Tcl_StoreIntRep((objPtr), &instNameType, &ir); \ + Tcl_StoreInternalRep((objPtr), &instNameType, &ir); \ } while (0) -#define InstNameGetIntRep(objPtr, inst) \ +#define InstNameGetInternalRep(objPtr, inst) \ do { \ - const Tcl_ObjIntRep *irPtr; \ - irPtr = TclFetchIntRep((objPtr), &instNameType); \ + const Tcl_ObjInternalRep *irPtr; \ + irPtr = TclFetchInternalRep((objPtr), &instNameType); \ assert(irPtr != NULL); \ (inst) = (size_t)irPtr->wideValue; \ } while (0) @@ -259,7 +259,7 @@ DisassembleByteCodeObj( Interp *iPtr; Tcl_Obj *bufferObj, *fileObj; - ByteCodeGetIntRep(objPtr, &tclByteCodeType, codePtr); + ByteCodeGetInternalRep(objPtr, &tclByteCodeType, codePtr); iPtr = (Interp *) *codePtr->interpHandle; @@ -761,7 +761,7 @@ TclGetInnerContext( int len; /* - * Reset while keeping the list intrep as much as possible. + * Reset while keeping the list internalrep as much as possible. */ Tcl_ListObjLength(interp, result, &len); @@ -808,7 +808,7 @@ TclNewInstNameObj( TclNewObj(objPtr); TclInvalidateStringRep(objPtr); - InstNameSetIntRep(objPtr, (long) inst); + InstNameSetInternalRep(objPtr, (long) inst); return objPtr; } @@ -830,7 +830,7 @@ UpdateStringOfInstName( size_t inst; /* NOTE: We know this is really an unsigned char */ char *dst; - InstNameGetIntRep(objPtr, inst); + InstNameGetInternalRep(objPtr, inst); if (inst > LAST_INST_OPCODE) { dst = Tcl_InitStringRep(objPtr, NULL, TCL_INTEGER_SPACE + 5); @@ -945,7 +945,7 @@ DisassembleByteCodeAsDicts( int codeOffset, codeLength, sourceOffset, sourceLength; int i, val, line; - ByteCodeGetIntRep(objPtr, &tclByteCodeType, codePtr); + ByteCodeGetInternalRep(objPtr, &tclByteCodeType, codePtr); /* * Get the literals from the bytecode. @@ -1368,7 +1368,7 @@ Tcl_DisassembleObjCmd( return TCL_ERROR; } - if (!TclHasIntRep(objv[2], &tclByteCodeType) && (TCL_OK + if (!TclHasInternalRep(objv[2], &tclByteCodeType) && (TCL_OK != TclSetByteCodeFromAny(interp, objv[2], NULL, NULL))) { return TCL_ERROR; } @@ -1419,7 +1419,7 @@ Tcl_DisassembleObjCmd( * Compile if necessary. */ - if (!TclHasIntRep(procPtr->bodyPtr, &tclByteCodeType)) { + if (!TclHasInternalRep(procPtr->bodyPtr, &tclByteCodeType)) { Command cmd; /* @@ -1484,7 +1484,7 @@ Tcl_DisassembleObjCmd( * Compile if necessary. */ - if (!TclHasIntRep(procPtr->bodyPtr, &tclByteCodeType)) { + if (!TclHasInternalRep(procPtr->bodyPtr, &tclByteCodeType)) { Command cmd; /* @@ -1569,7 +1569,7 @@ Tcl_DisassembleObjCmd( "METHODTYPE", NULL); return TCL_ERROR; } - if (!TclHasIntRep(procPtr->bodyPtr, &tclByteCodeType)) { + if (!TclHasInternalRep(procPtr->bodyPtr, &tclByteCodeType)) { Command cmd; /* @@ -1597,7 +1597,7 @@ Tcl_DisassembleObjCmd( * Do the actual disassembly. */ - ByteCodeGetIntRep(codeObjPtr, &tclByteCodeType, codePtr); + ByteCodeGetInternalRep(codeObjPtr, &tclByteCodeType, codePtr); if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) { Tcl_SetObjResult(interp, Tcl_NewStringObj( diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 9367863..61a931d 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -196,13 +196,13 @@ static unsigned short emptyPage[256]; */ static Tcl_EncodingConvertProc BinaryProc; -static Tcl_DupInternalRepProc DupEncodingIntRep; +static Tcl_DupInternalRepProc DupEncodingInternalRep; static Tcl_EncodingFreeProc EscapeFreeProc; static Tcl_EncodingConvertProc EscapeFromUtfProc; static Tcl_EncodingConvertProc EscapeToUtfProc; static void FillEncodingFileMap(void); static void FreeEncoding(Tcl_Encoding encoding); -static Tcl_FreeInternalRepProc FreeEncodingIntRep; +static Tcl_FreeInternalRepProc FreeEncodingInternalRep; static Encoding * GetTableEncoding(EscapeEncodingData *dataPtr, int state); static Tcl_Encoding LoadEncodingFile(Tcl_Interp *interp, @@ -226,25 +226,25 @@ static Tcl_EncodingConvertProc Iso88591ToUtfProc; /* * A Tcl_ObjType for holding a cached Tcl_Encoding in the twoPtrValue.ptr1 field - * of the intrep. This should help the lifetime of encodings be more useful. + * of the internalrep. This should help the lifetime of encodings be more useful. * See concerns raised in [Bug 1077262]. */ static const Tcl_ObjType encodingType = { - "encoding", FreeEncodingIntRep, DupEncodingIntRep, NULL, NULL + "encoding", FreeEncodingInternalRep, DupEncodingInternalRep, NULL, NULL }; -#define EncodingSetIntRep(objPtr, encoding) \ +#define EncodingSetInternalRep(objPtr, encoding) \ do { \ - Tcl_ObjIntRep ir; \ + Tcl_ObjInternalRep ir; \ ir.twoPtrValue.ptr1 = (encoding); \ ir.twoPtrValue.ptr2 = NULL; \ - Tcl_StoreIntRep((objPtr), &encodingType, &ir); \ + Tcl_StoreInternalRep((objPtr), &encodingType, &ir); \ } while (0) -#define EncodingGetIntRep(objPtr, encoding) \ +#define EncodingGetInternalRep(objPtr, encoding) \ do { \ - const Tcl_ObjIntRep *irPtr; \ - irPtr = TclFetchIntRep ((objPtr), &encodingType); \ + const Tcl_ObjInternalRep *irPtr; \ + irPtr = TclFetchInternalRep ((objPtr), &encodingType); \ (encoding) = irPtr ? (Tcl_Encoding)irPtr->twoPtrValue.ptr1 : NULL; \ } while (0) @@ -277,13 +277,13 @@ Tcl_GetEncodingFromObj( Tcl_Encoding encoding; const char *name = TclGetString(objPtr); - EncodingGetIntRep(objPtr, encoding); + EncodingGetInternalRep(objPtr, encoding); if (encoding == NULL) { encoding = Tcl_GetEncoding(interp, name); if (encoding == NULL) { return TCL_ERROR; } - EncodingSetIntRep(objPtr, encoding); + EncodingSetInternalRep(objPtr, encoding); } *encodingPtr = Tcl_GetEncoding(NULL, name); return TCL_OK; @@ -292,7 +292,7 @@ Tcl_GetEncodingFromObj( /* *---------------------------------------------------------------------- * - * FreeEncodingIntRep -- + * FreeEncodingInternalRep -- * * The Tcl_FreeInternalRepProc for the "encoding" Tcl_ObjType. * @@ -300,19 +300,19 @@ Tcl_GetEncodingFromObj( */ static void -FreeEncodingIntRep( +FreeEncodingInternalRep( Tcl_Obj *objPtr) { Tcl_Encoding encoding; - EncodingGetIntRep(objPtr, encoding); + EncodingGetInternalRep(objPtr, encoding); Tcl_FreeEncoding(encoding); } /* *---------------------------------------------------------------------- * - * DupEncodingIntRep -- + * DupEncodingInternalRep -- * * The Tcl_DupInternalRepProc for the "encoding" Tcl_ObjType. * @@ -320,12 +320,12 @@ FreeEncodingIntRep( */ static void -DupEncodingIntRep( +DupEncodingInternalRep( Tcl_Obj *srcPtr, Tcl_Obj *dupPtr) { Tcl_Encoding encoding = Tcl_GetEncoding(NULL, TclGetString(srcPtr)); - EncodingSetIntRep(dupPtr, encoding); + EncodingSetInternalRep(dupPtr, encoding); } /* diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 7d060b0..850d5d0 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -84,18 +84,18 @@ static const Tcl_ObjType ensembleCmdType = { NULL /* setFromAnyProc */ }; -#define ECRSetIntRep(objPtr, ecRepPtr) \ +#define ECRSetInternalRep(objPtr, ecRepPtr) \ do { \ - Tcl_ObjIntRep ir; \ + Tcl_ObjInternalRep ir; \ ir.twoPtrValue.ptr1 = (ecRepPtr); \ ir.twoPtrValue.ptr2 = NULL; \ - Tcl_StoreIntRep((objPtr), &ensembleCmdType, &ir); \ + Tcl_StoreInternalRep((objPtr), &ensembleCmdType, &ir); \ } while (0) -#define ECRGetIntRep(objPtr, ecRepPtr) \ +#define ECRGetInternalRep(objPtr, ecRepPtr) \ do { \ - const Tcl_ObjIntRep *irPtr; \ - irPtr = TclFetchIntRep((objPtr), &ensembleCmdType); \ + const Tcl_ObjInternalRep *irPtr; \ + irPtr = TclFetchInternalRep((objPtr), &ensembleCmdType); \ (ecRepPtr) = irPtr ? (EnsembleCmdRep *)irPtr->twoPtrValue.ptr1 : NULL; \ } while (0) @@ -1759,7 +1759,7 @@ NsEnsembleImplementationCmdNR( */ EnsembleCmdRep *ensembleCmd; - ECRGetIntRep(subObj, ensembleCmd); + ECRGetInternalRep(subObj, ensembleCmd); if (ensembleCmd) { if (ensembleCmd->epoch == ensemblePtr->epoch && ensembleCmd->token == (Command *)ensemblePtr->token) { @@ -2424,7 +2424,7 @@ MakeCachedEnsembleCommand( { EnsembleCmdRep *ensembleCmd; - ECRGetIntRep(objPtr, ensembleCmd); + ECRGetInternalRep(objPtr, ensembleCmd); if (ensembleCmd) { TclCleanupCommandMacro(ensembleCmd->token); if (ensembleCmd->fix) { @@ -2437,7 +2437,7 @@ MakeCachedEnsembleCommand( */ ensembleCmd = (EnsembleCmdRep *)ckalloc(sizeof(EnsembleCmdRep)); - ECRSetIntRep(objPtr, ensembleCmd); + ECRSetInternalRep(objPtr, ensembleCmd); } /* @@ -2847,7 +2847,7 @@ FreeEnsembleCmdRep( { EnsembleCmdRep *ensembleCmd; - ECRGetIntRep(objPtr, ensembleCmd); + ECRGetInternalRep(objPtr, ensembleCmd); TclCleanupCommandMacro(ensembleCmd->token); if (ensembleCmd->fix) { Tcl_DecrRefCount(ensembleCmd->fix); @@ -2881,8 +2881,8 @@ DupEnsembleCmdRep( EnsembleCmdRep *ensembleCmd; EnsembleCmdRep *ensembleCopy = (EnsembleCmdRep *)ckalloc(sizeof(EnsembleCmdRep)); - ECRGetIntRep(objPtr, ensembleCmd); - ECRSetIntRep(copyPtr, ensembleCopy); + ECRGetInternalRep(objPtr, ensembleCmd); + ECRSetInternalRep(copyPtr, ensembleCopy); ensembleCopy->epoch = ensembleCmd->epoch; ensembleCopy->token = ensembleCmd->token; diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 7e51c0d..73bd0e9 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -509,11 +509,11 @@ VarHashCreateVar( */ #define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \ - ((TclHasIntRep((objPtr), &tclIntType)) \ + ((TclHasInternalRep((objPtr), &tclIntType)) \ ? (*(tPtr) = TCL_NUMBER_INT, \ *(ptrPtr) = (ClientData) \ (&((objPtr)->internalRep.wideValue)), TCL_OK) : \ - TclHasIntRep((objPtr), &tclDoubleType) \ + TclHasInternalRep((objPtr), &tclDoubleType) \ ? (((TclIsNaN((objPtr)->internalRep.doubleValue)) \ ? (*(tPtr) = TCL_NUMBER_NAN) \ : (*(tPtr) = TCL_NUMBER_DOUBLE)), \ @@ -759,9 +759,9 @@ ReleaseDictIterator( { Tcl_DictSearch *searchPtr; Tcl_Obj *dictPtr; - const Tcl_ObjIntRep *irPtr; + const Tcl_ObjInternalRep *irPtr; - irPtr = TclFetchIntRep(objPtr, &dictIteratorType); + irPtr = TclFetchInternalRep(objPtr, &dictIteratorType); assert(irPtr != NULL); /* @@ -1474,7 +1474,7 @@ CompileExprObj( * is valid in the current context. */ - ByteCodeGetIntRep(objPtr, &exprCodeType, codePtr); + ByteCodeGetInternalRep(objPtr, &exprCodeType, codePtr); if (codePtr != NULL) { Namespace *namespacePtr = iPtr->varFramePtr->nsPtr; @@ -1484,7 +1484,7 @@ CompileExprObj( || (codePtr->nsPtr != namespacePtr) || (codePtr->nsEpoch != namespacePtr->resolverEpoch) || (codePtr->localCachePtr != iPtr->varFramePtr->localCachePtr)) { - Tcl_StoreIntRep(objPtr, &exprCodeType, NULL); + Tcl_StoreInternalRep(objPtr, &exprCodeType, NULL); codePtr = NULL; } } @@ -1538,7 +1538,7 @@ CompileExprObj( * DupExprCodeInternalRep -- * * Part of the Tcl object type implementation for Tcl expression - * bytecode. We do not copy the bytecode intrep. Instead, we return + * bytecode. We do not copy the bytecode internalrep. Instead, we return * without setting copyPtr->typePtr, so the copy is a plain string copy * of the expression value, and if it is to be used as a compiled * expression, it will just need a recompile. @@ -1547,7 +1547,7 @@ CompileExprObj( * usual (only?) time Tcl_DuplicateObj() will be called is when the copy * is about to be modified, which would invalidate any copied bytecode * anyway. The only reason it might make sense to copy the bytecode is if - * we had some modifying routines that operated directly on the intrep, + * we had some modifying routines that operated directly on the internalrep, * like we do for lists and dicts. * * Results: @@ -1590,7 +1590,7 @@ FreeExprCodeInternalRep( Tcl_Obj *objPtr) { ByteCode *codePtr; - ByteCodeGetIntRep(objPtr, &exprCodeType, codePtr); + ByteCodeGetInternalRep(objPtr, &exprCodeType, codePtr); assert(codePtr != NULL); TclReleaseByteCode(codePtr); @@ -1629,7 +1629,7 @@ TclCompileObj( * compilation). Otherwise, check that it is "fresh" enough. */ - ByteCodeGetIntRep(objPtr, &tclByteCodeType, codePtr); + ByteCodeGetInternalRep(objPtr, &tclByteCodeType, codePtr); if (codePtr != NULL) { /* * Make sure the Bytecode hasn't been invalidated by, e.g., someone @@ -1775,7 +1775,7 @@ TclCompileObj( iPtr->invokeWord = word; TclSetByteCodeFromAny(interp, objPtr, NULL, NULL); iPtr->invokeCmdFramePtr = NULL; - ByteCodeGetIntRep(objPtr, &tclByteCodeType, codePtr); + ByteCodeGetInternalRep(objPtr, &tclByteCodeType, codePtr); if (iPtr->varFramePtr->localCachePtr) { codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr; codePtr->localCachePtr->refCount++; @@ -4864,7 +4864,7 @@ TEBCresume( */ if ((TclListObjGetElements(interp, valuePtr, &objc, &objv) == TCL_OK) - && !TclHasIntRep(value2Ptr, &tclListType)) { + && !TclHasInternalRep(value2Ptr, &tclListType)) { int code; DECACHE_STACK_INFO(); @@ -5262,7 +5262,7 @@ TEBCresume( } else { length = Tcl_UtfToUpper(TclGetString(valuePtr)); Tcl_SetObjLength(valuePtr, length); - TclFreeIntRep(valuePtr); + TclFreeInternalRep(valuePtr); TRACE_APPEND(("\"%.20s\"\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); } @@ -5279,7 +5279,7 @@ TEBCresume( } else { length = Tcl_UtfToLower(TclGetString(valuePtr)); Tcl_SetObjLength(valuePtr, length); - TclFreeIntRep(valuePtr); + TclFreeInternalRep(valuePtr); TRACE_APPEND(("\"%.20s\"\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); } @@ -5296,7 +5296,7 @@ TEBCresume( } else { length = Tcl_UtfToTitle(TclGetString(valuePtr)); Tcl_SetObjLength(valuePtr, length); - TclFreeIntRep(valuePtr); + TclFreeInternalRep(valuePtr); TRACE_APPEND(("\"%.20s\"\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); } @@ -5610,8 +5610,8 @@ TEBCresume( * both. */ - if (TclHasIntRep(valuePtr, &tclStringType) - || TclHasIntRep(value2Ptr, &tclStringType)) { + if (TclHasInternalRep(valuePtr, &tclStringType) + || TclHasInternalRep(value2Ptr, &tclStringType)) { Tcl_UniChar *ustring1, *ustring2; ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length); @@ -6400,7 +6400,7 @@ TEBCresume( if (Tcl_IsShared(valuePtr)) { /* * Here we do some surgery within the Tcl_Obj internals. We want - * to copy the intrep, but not the string, so we temporarily hide + * to copy the internalrep, but not the string, so we temporarily hide * the string so we do not copy it. */ @@ -6425,7 +6425,7 @@ TEBCresume( case INST_TRY_CVT_TO_BOOLEAN: valuePtr = OBJ_AT_TOS; - if (TclHasIntRep(valuePtr, &tclBooleanType)) { + if (TclHasInternalRep(valuePtr, &tclBooleanType)) { objResultPtr = TCONST(1); } else { int res = (TclSetBooleanFromAny(NULL, valuePtr) == TCL_OK); @@ -7260,7 +7260,7 @@ TEBCresume( /* * dictPtr is no longer on the stack, and we're not - * moving it into the intrep of an iterator. We need + * moving it into the internalrep of an iterator. We need * to drop the refcount [Tcl Bug 9b352768e6]. */ @@ -7270,15 +7270,15 @@ TEBCresume( goto gotError; } { - Tcl_ObjIntRep ir; + Tcl_ObjInternalRep ir; TclNewObj(statePtr); ir.twoPtrValue.ptr1 = searchPtr; ir.twoPtrValue.ptr2 = dictPtr; - Tcl_StoreIntRep(statePtr, &dictIteratorType, &ir); + Tcl_StoreInternalRep(statePtr, &dictIteratorType, &ir); } varPtr = LOCAL(opnd); if (varPtr->value.objPtr) { - if (TclHasIntRep(varPtr->value.objPtr, &dictIteratorType)) { + if (TclHasInternalRep(varPtr->value.objPtr, &dictIteratorType)) { Tcl_Panic("mis-issued dictFirst!"); } TclDecrRefCount(varPtr->value.objPtr); @@ -7292,10 +7292,10 @@ TEBCresume( TRACE(("%u => ", opnd)); statePtr = (*LOCAL(opnd)).value.objPtr; { - const Tcl_ObjIntRep *irPtr; + const Tcl_ObjInternalRep *irPtr; if (statePtr && - (irPtr = TclFetchIntRep(statePtr, &dictIteratorType))) { + (irPtr = TclFetchInternalRep(statePtr, &dictIteratorType))) { searchPtr = (Tcl_DictSearch *)irPtr->twoPtrValue.ptr1; Tcl_DictObjNext(searchPtr, &keyPtr, &valuePtr, &done); } else { @@ -9852,7 +9852,7 @@ EvalStatsCmd( for (i = 0; i < globalTablePtr->numBuckets; i++) { for (entryPtr = globalTablePtr->buckets[i]; entryPtr != NULL; entryPtr = entryPtr->nextPtr) { - if (TclHasIntRep(entryPtr->objPtr, &tclByteCodeType)) { + if (TclHasInternalRep(entryPtr->objPtr, &tclByteCodeType)) { numByteCodeLits++; } (void) TclGetStringFromObj(entryPtr->objPtr, &length); diff --git a/generic/tclGet.c b/generic/tclGet.c index 3dbc545..970e093 100644 --- a/generic/tclGet.c +++ b/generic/tclGet.c @@ -53,7 +53,7 @@ Tcl_GetInt( if (obj.refCount > 1) { Tcl_Panic("invalid sharing of Tcl_Obj on C stack"); } - TclFreeIntRep(&obj); + TclFreeInternalRep(&obj); return code; } @@ -97,7 +97,7 @@ Tcl_GetDouble( if (obj.refCount > 1) { Tcl_Panic("invalid sharing of Tcl_Obj on C stack"); } - TclFreeIntRep(&obj); + TclFreeInternalRep(&obj); return code; } diff --git a/generic/tclIO.c b/generic/tclIO.c index d704d29..44568e4 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -324,30 +324,30 @@ typedef struct ResolvedChanName { size_t refCount; /* Share this struct among many Tcl_Obj. */ } ResolvedChanName; -static void DupChannelIntRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr); -static void FreeChannelIntRep(Tcl_Obj *objPtr); +static void DupChannelInternalRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr); +static void FreeChannelInternalRep(Tcl_Obj *objPtr); static const Tcl_ObjType chanObjType = { "channel", /* name for this type */ - FreeChannelIntRep, /* freeIntRepProc */ - DupChannelIntRep, /* dupIntRepProc */ + FreeChannelInternalRep, /* freeIntRepProc */ + DupChannelInternalRep, /* dupIntRepProc */ NULL, /* updateStringProc */ NULL /* setFromAnyProc */ }; -#define ChanSetIntRep(objPtr, resPtr) \ +#define ChanSetInternalRep(objPtr, resPtr) \ do { \ - Tcl_ObjIntRep ir; \ + Tcl_ObjInternalRep ir; \ (resPtr)->refCount++; \ ir.twoPtrValue.ptr1 = (resPtr); \ ir.twoPtrValue.ptr2 = NULL; \ - Tcl_StoreIntRep((objPtr), &chanObjType, &ir); \ + Tcl_StoreInternalRep((objPtr), &chanObjType, &ir); \ } while (0) -#define ChanGetIntRep(objPtr, resPtr) \ +#define ChanGetInternalRep(objPtr, resPtr) \ do { \ - const Tcl_ObjIntRep *irPtr; \ - irPtr = TclFetchIntRep((objPtr), &chanObjType); \ + const Tcl_ObjInternalRep *irPtr; \ + irPtr = TclFetchInternalRep((objPtr), &chanObjType); \ (resPtr) = irPtr ? (ResolvedChanName *)irPtr->twoPtrValue.ptr1 : NULL; \ } while (0) @@ -1524,7 +1524,7 @@ TclGetChannelFromObj( return TCL_ERROR; } - ChanGetIntRep(objPtr, resPtr); + ChanGetInternalRep(objPtr, resPtr); if (resPtr) { /* * Confirm validity of saved lookup results. @@ -1546,7 +1546,7 @@ TclGetChannelFromObj( if (chan == NULL) { if (resPtr) { - Tcl_StoreIntRep(objPtr, &chanObjType, NULL); + Tcl_StoreInternalRep(objPtr, &chanObjType, NULL); } return TCL_ERROR; } @@ -1560,7 +1560,7 @@ TclGetChannelFromObj( } else { resPtr = (ResolvedChanName *) ckalloc(sizeof(ResolvedChanName)); resPtr->refCount = 0; - ChanSetIntRep(objPtr, resPtr); /* Overwrites, if needed */ + ChanSetInternalRep(objPtr, resPtr); /* Overwrites, if needed */ } statePtr = ((Channel *)chan)->state; resPtr->statePtr = statePtr; @@ -11274,7 +11274,7 @@ Tcl_ChannelTruncateProc( /* *---------------------------------------------------------------------- * - * DupChannelIntRep -- + * DupChannelInternalRep -- * * Initialize the internal representation of a new Tcl_Obj to a copy of * the internal representation of an existing string object. @@ -11290,7 +11290,7 @@ Tcl_ChannelTruncateProc( */ static void -DupChannelIntRep( +DupChannelInternalRep( Tcl_Obj *srcPtr, /* Object with internal rep to copy. Must have * an internal rep of type "Channel". */ Tcl_Obj *copyPtr) /* Object with internal rep to set. Must not @@ -11298,15 +11298,15 @@ DupChannelIntRep( { ResolvedChanName *resPtr; - ChanGetIntRep(srcPtr, resPtr); + ChanGetInternalRep(srcPtr, resPtr); assert(resPtr); - ChanSetIntRep(copyPtr, resPtr); + ChanSetInternalRep(copyPtr, resPtr); } /* *---------------------------------------------------------------------- * - * FreeChannelIntRep -- + * FreeChannelInternalRep -- * * Release statePtr storage. * @@ -11320,12 +11320,12 @@ DupChannelIntRep( */ static void -FreeChannelIntRep( +FreeChannelInternalRep( Tcl_Obj *objPtr) /* Object with internal rep to free. */ { ResolvedChanName *resPtr; - ChanGetIntRep(objPtr, resPtr); + ChanGetInternalRep(objPtr, resPtr); assert(resPtr); if (resPtr->refCount-- > 1) { return; diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index c33caf8..c2812ea 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -122,7 +122,7 @@ Tcl_GetIndexFromObj( * the common case where the result is cached). */ - const Tcl_ObjIntRep *irPtr = TclFetchIntRep(objPtr, &indexType); + const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objPtr, &indexType); if (irPtr) { IndexRep *indexRep = (IndexRep *)irPtr->twoPtrValue.ptr1; @@ -270,7 +270,7 @@ Tcl_GetIndexFromObjStruct( const char *const *entryPtr; Tcl_Obj *resultPtr; IndexRep *indexRep; - const Tcl_ObjIntRep *irPtr; + const Tcl_ObjInternalRep *irPtr; /* Protect against invalid values, like -1 or 0. */ if (offset < (int)sizeof(char *)) { @@ -281,7 +281,7 @@ Tcl_GetIndexFromObjStruct( */ if (!(flags & TCL_INDEX_TEMP_TABLE)) { - irPtr = TclFetchIntRep(objPtr, &indexType); + irPtr = TclFetchInternalRep(objPtr, &indexType); if (irPtr) { indexRep = (IndexRep *)irPtr->twoPtrValue.ptr1; if (indexRep->tablePtr==tablePtr && indexRep->offset==offset) { @@ -345,15 +345,15 @@ Tcl_GetIndexFromObjStruct( */ if (!(flags & TCL_INDEX_TEMP_TABLE)) { - irPtr = TclFetchIntRep(objPtr, &indexType); + irPtr = TclFetchInternalRep(objPtr, &indexType); if (irPtr) { indexRep = (IndexRep *)irPtr->twoPtrValue.ptr1; } else { - Tcl_ObjIntRep ir; + Tcl_ObjInternalRep ir; indexRep = (IndexRep*)ckalloc(sizeof(IndexRep)); ir.twoPtrValue.ptr1 = indexRep; - Tcl_StoreIntRep(objPtr, &indexType, &ir); + Tcl_StoreInternalRep(objPtr, &indexType, &ir); } indexRep->tablePtr = (void *) tablePtr; indexRep->offset = offset; @@ -423,7 +423,7 @@ static void UpdateStringOfIndex( Tcl_Obj *objPtr) { - IndexRep *indexRep = (IndexRep *)TclFetchIntRep(objPtr, &indexType)->twoPtrValue.ptr1; + IndexRep *indexRep = (IndexRep *)TclFetchInternalRep(objPtr, &indexType)->twoPtrValue.ptr1; const char *indexStr = EXPAND_OF(indexRep); Tcl_InitStringRep(objPtr, indexStr, strlen(indexStr)); @@ -452,14 +452,14 @@ DupIndex( Tcl_Obj *srcPtr, Tcl_Obj *dupPtr) { - Tcl_ObjIntRep ir; + Tcl_ObjInternalRep ir; IndexRep *dupIndexRep = (IndexRep *)ckalloc(sizeof(IndexRep)); - memcpy(dupIndexRep, TclFetchIntRep(srcPtr, &indexType)->twoPtrValue.ptr1, + memcpy(dupIndexRep, TclFetchInternalRep(srcPtr, &indexType)->twoPtrValue.ptr1, sizeof(IndexRep)); ir.twoPtrValue.ptr1 = dupIndexRep; - Tcl_StoreIntRep(dupPtr, &indexType, &ir); + Tcl_StoreInternalRep(dupPtr, &indexType, &ir); } /* @@ -483,7 +483,7 @@ static void FreeIndex( Tcl_Obj *objPtr) { - ckfree(TclFetchIntRep(objPtr, &indexType)->twoPtrValue.ptr1); + ckfree(TclFetchInternalRep(objPtr, &indexType)->twoPtrValue.ptr1); objPtr->typePtr = NULL; } @@ -922,9 +922,9 @@ Tcl_WrongNumArgs( /* * Add the element, quoting it if necessary. */ - const Tcl_ObjIntRep *irPtr; + const Tcl_ObjInternalRep *irPtr; - if ((irPtr = TclFetchIntRep(origObjv[i], &indexType))) { + if ((irPtr = TclFetchInternalRep(origObjv[i], &indexType))) { IndexRep *indexRep = (IndexRep *)irPtr->twoPtrValue.ptr1; elementStr = EXPAND_OF(indexRep); @@ -971,9 +971,9 @@ Tcl_WrongNumArgs( * the correct error message even if the subcommand was abbreviated. * Otherwise, just use the string rep. */ - const Tcl_ObjIntRep *irPtr; + const Tcl_ObjInternalRep *irPtr; - if ((irPtr = TclFetchIntRep(objv[i], &indexType))) { + if ((irPtr = TclFetchInternalRep(objv[i], &indexType))) { IndexRep *indexRep = (IndexRep *)irPtr->twoPtrValue.ptr1; Tcl_AppendStringsToObj(objPtr, EXPAND_OF(indexRep), NULL); @@ -1418,7 +1418,7 @@ TclGetCompletionCodeFromObj( "ok", "error", "return", "break", "continue", NULL }; - if (!TclHasIntRep(value, &indexType) + if (!TclHasInternalRep(value, &indexType) && TclGetIntFromObj(NULL, value, codePtr) == TCL_OK) { return TCL_OK; } diff --git a/generic/tclInt.h b/generic/tclInt.h index 6c3a05d..08445a5 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3219,7 +3219,7 @@ MODULE_SCOPE int TclScanElement(const char *string, int length, char *flagPtr); MODULE_SCOPE void TclSetBgErrorHandler(Tcl_Interp *interp, Tcl_Obj *cmdPrefix); -MODULE_SCOPE void TclSetBignumIntRep(Tcl_Obj *objPtr, +MODULE_SCOPE void TclSetBignumInternalRep(Tcl_Obj *objPtr, void *bignumValue); MODULE_SCOPE int TclSetBooleanFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); @@ -4536,11 +4536,11 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, * representation. Does not actually reset the rep's bytes. The ANSI C * "prototype" for this macro is: * - * MODULE_SCOPE void TclFreeIntRep(Tcl_Obj *objPtr); + * MODULE_SCOPE void TclFreeInternalRep(Tcl_Obj *objPtr); *---------------------------------------------------------------- */ -#define TclFreeIntRep(objPtr) \ +#define TclFreeInternalRep(objPtr) \ if ((objPtr)->typePtr != NULL) { \ if ((objPtr)->typePtr->freeIntRepProc != NULL) { \ (objPtr)->typePtr->freeIntRepProc(objPtr); \ @@ -4548,6 +4548,10 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, (objPtr)->typePtr = NULL; \ } +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 8 +# define TclFreeIntRep(objPtr) TclFreeInternalRep(objPtr) +#endif + /* *---------------------------------------------------------------- * Macro used by the Tcl core to clean out an object's string representation. @@ -4758,10 +4762,10 @@ MODULE_SCOPE const TclFileAttrProcs tclpFileAttrProcs[]; MODULE_SCOPE int TclIsPureByteArray(Tcl_Obj *objPtr); #define TclIsPureDict(objPtr) \ (((objPtr)->bytes==NULL) && ((objPtr)->typePtr==&tclDictType)) -#define TclHasIntRep(objPtr, type) \ +#define TclHasInternalRep(objPtr, type) \ ((objPtr)->typePtr == (type)) -#define TclFetchIntRep(objPtr, type) \ - (TclHasIntRep((objPtr), (type)) ? &((objPtr)->internalRep) : NULL) +#define TclFetchInternalRep(objPtr, type) \ + (TclHasInternalRep((objPtr), (type)) ? &((objPtr)->internalRep) : NULL) /* @@ -4851,18 +4855,18 @@ MODULE_SCOPE Tcl_LibraryInitProc Procbodytest_SafeInit; #define TclSetIntObj(objPtr, i) \ do { \ - Tcl_ObjIntRep ir; \ + Tcl_ObjInternalRep ir; \ ir.wideValue = (Tcl_WideInt) i; \ TclInvalidateStringRep(objPtr); \ - Tcl_StoreIntRep(objPtr, &tclIntType, &ir); \ + Tcl_StoreInternalRep(objPtr, &tclIntType, &ir); \ } while (0) #define TclSetDoubleObj(objPtr, d) \ do { \ - Tcl_ObjIntRep ir; \ + Tcl_ObjInternalRep ir; \ ir.doubleValue = (double) d; \ TclInvalidateStringRep(objPtr); \ - Tcl_StoreIntRep(objPtr, &tclDoubleType, &ir); \ + Tcl_StoreInternalRep(objPtr, &tclDoubleType, &ir); \ } while (0) /* diff --git a/generic/tclLink.c b/generic/tclLink.c index 02b19aa..34ad67b 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -588,7 +588,7 @@ GetDouble( return 0; } else { #ifdef ACCEPT_NAN - Tcl_ObjIntRep *irPtr = TclFetchIntRep(objPtr, &tclDoubleType); + Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objPtr, &tclDoubleType); if (irPtr != NULL) { *dblPtr = irPtr->doubleValue; @@ -656,7 +656,7 @@ SetInvalidRealFromAny( double doubleValue = 0.0; Tcl_GetDoubleFromObj(NULL, objPtr, &doubleValue); - TclFreeIntRep(objPtr); + TclFreeInternalRep(objPtr); objPtr->typePtr = &invalidRealType; objPtr->internalRep.doubleValue = doubleValue; return TCL_OK; @@ -705,7 +705,7 @@ GetInvalidDoubleFromObj( { int intValue; - if (TclHasIntRep(objPtr, &invalidRealType)) { + if (TclHasInternalRep(objPtr, &invalidRealType)) { goto gotdouble; } if (GetInvalidIntFromObj(objPtr, &intValue) == TCL_OK) { diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 0cc1c11..c66fd1e 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -20,7 +20,7 @@ static List * AttemptNewList(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static List * NewListIntRep(int objc, Tcl_Obj *const objv[], int p); +static List * NewListInternalRep(int objc, Tcl_Obj *const objv[], int p); static void DupListInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); static void FreeListInternalRep(Tcl_Obj *listPtr); static int SetListFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); @@ -49,24 +49,24 @@ const Tcl_ObjType tclListType = { /* Macros to manipulate the List internal rep */ -#define ListSetIntRep(objPtr, listRepPtr) \ +#define ListSetInternalRep(objPtr, listRepPtr) \ do { \ - Tcl_ObjIntRep ir; \ + Tcl_ObjInternalRep ir; \ ir.twoPtrValue.ptr1 = (listRepPtr); \ ir.twoPtrValue.ptr2 = NULL; \ (listRepPtr)->refCount++; \ - Tcl_StoreIntRep((objPtr), &tclListType, &ir); \ + Tcl_StoreInternalRep((objPtr), &tclListType, &ir); \ } while (0) -#define ListGetIntRep(objPtr, listRepPtr) \ +#define ListGetInternalRep(objPtr, listRepPtr) \ do { \ - const Tcl_ObjIntRep *irPtr; \ - irPtr = TclFetchIntRep((objPtr), &tclListType); \ + const Tcl_ObjInternalRep *irPtr; \ + irPtr = TclFetchInternalRep((objPtr), &tclListType); \ (listRepPtr) = irPtr ? (List *)irPtr->twoPtrValue.ptr1 : NULL; \ } while (0) -#define ListResetIntRep(objPtr, listRepPtr) \ - TclFetchIntRep((objPtr), &tclListType)->twoPtrValue.ptr1 = (listRepPtr) +#define ListResetInternalRep(objPtr, listRepPtr) \ + TclFetchInternalRep((objPtr), &tclListType)->twoPtrValue.ptr1 = (listRepPtr) #ifndef TCL_MIN_ELEMENT_GROWTH #define TCL_MIN_ELEMENT_GROWTH TCL_MIN_GROWTH/sizeof(Tcl_Obj *) @@ -75,7 +75,7 @@ const Tcl_ObjType tclListType = { /* *---------------------------------------------------------------------- * - * NewListIntRep -- + * NewListInternalRep -- * * Creates a list internal rep with space for objc elements. objc * must be > 0. If objv!=NULL, initializes with the first objc values @@ -96,7 +96,7 @@ const Tcl_ObjType tclListType = { */ static List * -NewListIntRep( +NewListInternalRep( int objc, Tcl_Obj *const objv[], int p) @@ -104,7 +104,7 @@ NewListIntRep( List *listRepPtr; if (objc <= 0) { - Tcl_Panic("NewListIntRep: expects postive element count"); + Tcl_Panic("NewListInternalRep: expects postive element count"); } /* @@ -179,7 +179,7 @@ AttemptNewList( int objc, Tcl_Obj *const objv[]) { - List *listRepPtr = NewListIntRep(objc, objv, 0); + List *listRepPtr = NewListInternalRep(objc, objv, 0); if (interp != NULL && listRepPtr == NULL) { if (objc > LIST_MAX) { @@ -253,14 +253,14 @@ Tcl_NewListObj( * Create the internal rep. */ - listRepPtr = NewListIntRep(objc, objv, 1); + listRepPtr = NewListInternalRep(objc, objv, 1); /* * Now create the object. */ TclInvalidateStringRep(listPtr); - ListSetIntRep(listPtr, listRepPtr); + ListSetInternalRep(listPtr, listRepPtr); return listPtr; } #endif /* if TCL_MEM_DEBUG */ @@ -318,14 +318,14 @@ Tcl_DbNewListObj( * Create the internal rep. */ - listRepPtr = NewListIntRep(objc, objv, 1); + listRepPtr = NewListInternalRep(objc, objv, 1); /* * Now create the object. */ TclInvalidateStringRep(listPtr); - ListSetIntRep(listPtr, listRepPtr); + ListSetInternalRep(listPtr, listRepPtr); return listPtr; } @@ -381,7 +381,7 @@ Tcl_SetListObj( * Free any old string rep and any internal rep for the old type. */ - TclFreeIntRep(objPtr); + TclFreeInternalRep(objPtr); TclInvalidateStringRep(objPtr); /* @@ -391,8 +391,8 @@ Tcl_SetListObj( */ if (objc > 0) { - listRepPtr = NewListIntRep(objc, objv, 1); - ListSetIntRep(objPtr, listRepPtr); + listRepPtr = NewListInternalRep(objc, objv, 1); + ListSetInternalRep(objPtr, listRepPtr); } else { Tcl_InitStringRep(objPtr, NULL, 0); } @@ -428,7 +428,7 @@ TclListObjCopy( Tcl_Obj *copyPtr; List *listRepPtr; - ListGetIntRep(listPtr, listRepPtr); + ListGetInternalRep(listPtr, listRepPtr); if (NULL == listRepPtr) { if (SetListFromAny(interp, listPtr) != TCL_OK) { return NULL; @@ -566,7 +566,7 @@ Tcl_ListObjGetElements( { List *listRepPtr; - ListGetIntRep(listPtr, listRepPtr); + ListGetInternalRep(listPtr, listRepPtr); if (listRepPtr == NULL) { int result, length; @@ -581,7 +581,7 @@ Tcl_ListObjGetElements( if (result != TCL_OK) { return result; } - ListGetIntRep(listPtr, listRepPtr); + ListGetInternalRep(listPtr, listRepPtr); } *objcPtr = listRepPtr->elemCount; *objvPtr = &listRepPtr->elements; @@ -680,7 +680,7 @@ Tcl_ListObjAppendElement( Tcl_Panic("%s called with shared object", "Tcl_ListObjAppendElement"); } - ListGetIntRep(listPtr, listRepPtr); + ListGetInternalRep(listPtr, listRepPtr); if (listRepPtr == NULL) { int result, length; @@ -693,7 +693,7 @@ Tcl_ListObjAppendElement( if (result != TCL_OK) { return result; } - ListGetIntRep(listPtr, listRepPtr); + ListGetInternalRep(listPtr, listRepPtr); } numElems = listRepPtr->elemCount; @@ -713,7 +713,7 @@ Tcl_ListObjAppendElement( if (needGrow && !isShared) { /* - * Need to grow + unshared intrep => try to realloc + * Need to grow + unshared internalrep => try to realloc */ attempt = 2 * numRequired; @@ -741,8 +741,8 @@ Tcl_ListObjAppendElement( Tcl_Obj **dst, **src = &listRepPtr->elements; /* - * Either we have a shared intrep and we must copy to write, or we - * need to grow and realloc attempts failed. Attempt intrep copy. + * Either we have a shared internalrep and we must copy to write, or we + * need to grow and realloc attempts failed. Attempt internalrep copy. */ attempt = 2 * numRequired; @@ -773,7 +773,7 @@ Tcl_ListObjAppendElement( if (isShared) { /* - * The original intrep must remain undisturbed. Copy into the new + * The original internalrep must remain undisturbed. Copy into the new * one and bump refcounts */ while (numElems--) { @@ -783,7 +783,7 @@ Tcl_ListObjAppendElement( listRepPtr->refCount--; } else { /* - * Old intrep to be freed, re-use refCounts. + * Old internalrep to be freed, re-use refCounts. */ memcpy(dst, src, numElems * sizeof(Tcl_Obj *)); @@ -791,10 +791,10 @@ Tcl_ListObjAppendElement( } listRepPtr = newPtr; } - ListResetIntRep(listPtr, listRepPtr); + ListResetInternalRep(listPtr, listRepPtr); listRepPtr->refCount++; - TclFreeIntRep(listPtr); - ListSetIntRep(listPtr, listRepPtr); + TclFreeInternalRep(listPtr); + ListSetInternalRep(listPtr, listRepPtr); listRepPtr->refCount--; /* @@ -850,7 +850,7 @@ Tcl_ListObjIndex( { List *listRepPtr; - ListGetIntRep(listPtr, listRepPtr); + ListGetInternalRep(listPtr, listRepPtr); if (listRepPtr == NULL) { int result, length; @@ -863,7 +863,7 @@ Tcl_ListObjIndex( if (result != TCL_OK) { return result; } - ListGetIntRep(listPtr, listRepPtr); + ListGetInternalRep(listPtr, listRepPtr); } if ((index < 0) || (index >= listRepPtr->elemCount)) { @@ -905,7 +905,7 @@ Tcl_ListObjLength( { List *listRepPtr; - ListGetIntRep(listPtr, listRepPtr); + ListGetInternalRep(listPtr, listRepPtr); if (listRepPtr == NULL) { int result, length; @@ -918,7 +918,7 @@ Tcl_ListObjLength( if (result != TCL_OK) { return result; } - ListGetIntRep(listPtr, listRepPtr); + ListGetInternalRep(listPtr, listRepPtr); } *intPtr = listRepPtr->elemCount; @@ -981,7 +981,7 @@ Tcl_ListObjReplace( Tcl_Panic("%s called with shared object", "Tcl_ListObjReplace"); } - ListGetIntRep(listPtr, listRepPtr); + ListGetInternalRep(listPtr, listRepPtr); if (listRepPtr == NULL) { int length; @@ -998,7 +998,7 @@ Tcl_ListObjReplace( return result; } } - ListGetIntRep(listPtr, listRepPtr); + ListGetInternalRep(listPtr, listRepPtr); } /* @@ -1062,7 +1062,7 @@ Tcl_ListObjReplace( } if (newPtr) { listRepPtr = newPtr; - ListResetIntRep(listPtr, listRepPtr); + ListResetInternalRep(listPtr, listRepPtr); elemPtrs = &listRepPtr->elements; listRepPtr->maxElemCount = attempt; needGrow = numRequired > listRepPtr->maxElemCount; @@ -1135,7 +1135,7 @@ Tcl_ListObjReplace( } } - ListResetIntRep(listPtr, listRepPtr); + ListResetInternalRep(listPtr, listRepPtr); listRepPtr->refCount++; elemPtrs = &listRepPtr->elements; @@ -1213,8 +1213,8 @@ Tcl_ListObjReplace( */ listRepPtr->refCount++; - TclFreeIntRep(listPtr); - ListSetIntRep(listPtr, listRepPtr); + TclFreeInternalRep(listPtr); + ListSetInternalRep(listPtr, listRepPtr); listRepPtr->refCount--; TclInvalidateStringRep(listPtr); @@ -1240,7 +1240,7 @@ Tcl_ListObjReplace( * This procedure is implemented entirely as a wrapper around * TclLindexFlat. All it does is reconfigure the argument format into the * form required by TclLindexFlat, while taking care to manage shimmering - * in such a way that we tend to keep the most useful intreps and/or + * in such a way that we tend to keep the most useful internalreps and/or * avoid the most expensive conversions. * *---------------------------------------------------------------------- @@ -1263,7 +1263,7 @@ TclLindexList( * shimmering; see TIP#22 and TIP#33 for the details. */ - ListGetIntRep(argPtr, listRepPtr); + ListGetInternalRep(argPtr, listRepPtr); if ((listRepPtr == NULL) && TclGetIntForIndexM(NULL , argPtr, INT_MAX - 1, &index) == TCL_OK) { /* @@ -1295,7 +1295,7 @@ TclLindexList( return TclLindexFlat(interp, listPtr, 1, &argPtr); } - ListGetIntRep(indexListCopy, listRepPtr); + ListGetInternalRep(indexListCopy, listRepPtr); assert(listRepPtr != NULL); @@ -1418,7 +1418,7 @@ TclLindexFlat( * This procedure is implemented entirely as a wrapper around * TclLsetFlat. All it does is reconfigure the argument format into the * form required by TclLsetFlat, while taking care to manage shimmering - * in such a way that we tend to keep the most useful intreps and/or + * in such a way that we tend to keep the most useful internalreps and/or * avoid the most expensive conversions. * *---------------------------------------------------------------------- @@ -1444,7 +1444,7 @@ TclLsetList( * shimmering; see TIP #22 and #23 for details. */ - ListGetIntRep(indexArgPtr, listRepPtr); + ListGetInternalRep(indexArgPtr, listRepPtr); if (listRepPtr == NULL && TclGetIntForIndexM(NULL, indexArgPtr, INT_MAX - 1, &index) == TCL_OK) { /* @@ -1531,7 +1531,7 @@ TclLsetFlat( { int index, result, len; Tcl_Obj *subListPtr, *retValuePtr, *chainPtr; - Tcl_ObjIntRep *irPtr; + Tcl_ObjInternalRep *irPtr; /* * If there are no indices, simply return the new value. (Without @@ -1636,8 +1636,8 @@ TclLsetFlat( /* * Replace the original elemPtr[index] in parentList with a copy * we know to be unshared. This call will also deal with the - * situation where parentList shares its intrep with other - * Tcl_Obj's. Dealing with the shared intrep case can cause + * situation where parentList shares its internalrep with other + * Tcl_Obj's. Dealing with the shared internalrep case can cause * subListPtr to become shared again, so detect that case and make * and store another copy. */ @@ -1662,11 +1662,11 @@ TclLsetFlat( * variable. Later on, when we set valuePtr in its proper place, * then all containing lists will have their values changed, and * will need their string reps spoiled. We maintain a list of all - * those Tcl_Obj's (via a little intrep surgery) so we can spoil + * those Tcl_Obj's (via a little internalrep surgery) so we can spoil * them at that time. */ - irPtr = TclFetchIntRep(parentList, &tclListType); + irPtr = TclFetchInternalRep(parentList, &tclListType); irPtr->twoPtrValue.ptr2 = chainPtr; chainPtr = parentList; } @@ -1684,10 +1684,10 @@ TclLsetFlat( List *listRepPtr; /* - * Clear away our intrep surgery mess. + * Clear away our internalrep surgery mess. */ - irPtr = TclFetchIntRep(objPtr, &tclListType); + irPtr = TclFetchInternalRep(objPtr, &tclListType); listRepPtr = (List *)irPtr->twoPtrValue.ptr1; chainPtr = (Tcl_Obj *)irPtr->twoPtrValue.ptr2; @@ -1699,8 +1699,8 @@ TclLsetFlat( */ listRepPtr->refCount++; - TclFreeIntRep(objPtr); - ListSetIntRep(objPtr, listRepPtr); + TclFreeInternalRep(objPtr); + ListSetInternalRep(objPtr, listRepPtr); listRepPtr->refCount--; TclInvalidateStringRep(objPtr); @@ -1793,7 +1793,7 @@ TclListObjSetElement( Tcl_Panic("%s called with shared object", "TclListObjSetElement"); } - ListGetIntRep(listPtr, listRepPtr); + ListGetInternalRep(listPtr, listRepPtr); if (listRepPtr == NULL) { int result, length; @@ -1811,7 +1811,7 @@ TclListObjSetElement( if (result != TCL_OK) { return result; } - ListGetIntRep(listPtr, listRepPtr); + ListGetInternalRep(listPtr, listRepPtr); } elemCount = listRepPtr->elemCount; @@ -1857,7 +1857,7 @@ TclListObjSetElement( listRepPtr->refCount--; listRepPtr = newPtr; - ListResetIntRep(listPtr, listRepPtr); + ListResetInternalRep(listPtr, listRepPtr); } elemPtrs = &listRepPtr->elements; @@ -1880,13 +1880,13 @@ TclListObjSetElement( elemPtrs[index] = valuePtr; /* - * Invalidate outdated intreps. + * Invalidate outdated internalreps. */ - ListGetIntRep(listPtr, listRepPtr); + ListGetInternalRep(listPtr, listRepPtr); listRepPtr->refCount++; - TclFreeIntRep(listPtr); - ListSetIntRep(listPtr, listRepPtr); + TclFreeInternalRep(listPtr); + ListSetInternalRep(listPtr, listRepPtr); listRepPtr->refCount--; TclInvalidateStringRep(listPtr); @@ -1918,7 +1918,7 @@ FreeListInternalRep( { List *listRepPtr; - ListGetIntRep(listPtr, listRepPtr); + ListGetInternalRep(listPtr, listRepPtr); assert(listRepPtr != NULL); if (listRepPtr->refCount-- <= 1) { @@ -1956,9 +1956,9 @@ DupListInternalRep( { List *listRepPtr; - ListGetIntRep(srcPtr, listRepPtr); + ListGetInternalRep(srcPtr, listRepPtr); assert(listRepPtr != NULL); - ListSetIntRep(copyPtr, listRepPtr); + ListSetInternalRep(copyPtr, listRepPtr); } /* @@ -1996,7 +1996,7 @@ SetListFromAny( * describe duplicate keys). */ - if (!TclHasStringRep(objPtr) && TclHasIntRep(objPtr, &tclDictType)) { + if (!TclHasStringRep(objPtr) && TclHasInternalRep(objPtr, &tclDictType)) { Tcl_Obj *keyPtr, *valuePtr; Tcl_DictSearch search; int done, size; @@ -2099,7 +2099,7 @@ SetListFromAny( * Tcl_GetStringFromObj, to use the old internalRep. */ - ListSetIntRep(objPtr, listRepPtr); + ListSetInternalRep(objPtr, listRepPtr); return TCL_OK; } @@ -2136,7 +2136,7 @@ UpdateStringOfList( Tcl_Obj **elemPtrs; List *listRepPtr; - ListGetIntRep(listPtr, listRepPtr); + ListGetInternalRep(listPtr, listRepPtr); assert(listRepPtr != NULL); diff --git a/generic/tclLiteral.c b/generic/tclLiteral.c index fe1b00d..e1943a1 100644 --- a/generic/tclLiteral.c +++ b/generic/tclLiteral.c @@ -1045,7 +1045,7 @@ RebuildLiteralTable( * * Side effects: * Resets the internal representation of the CmdName Tcl_Obj - * using TclFreeIntRep(). + * using TclFreeInternalRep(). * *---------------------------------------------------------------------- */ @@ -1064,8 +1064,8 @@ TclInvalidateCmdLiteral( strlen(name), -1, NULL, nsPtr, 0, NULL); if (literalObjPtr != NULL) { - if (TclHasIntRep(literalObjPtr, &tclCmdNameType)) { - TclFreeIntRep(literalObjPtr); + if (TclHasInternalRep(literalObjPtr, &tclCmdNameType)) { + TclFreeInternalRep(literalObjPtr); } /* Balance the refcount effects of TclCreateLiteral() above */ Tcl_IncrRefCount(literalObjPtr); diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 2aed628..639dff2 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -133,19 +133,19 @@ static const Tcl_ObjType nsNameType = { SetNsNameFromAny /* setFromAnyProc */ }; -#define NsNameSetIntRep(objPtr, nnPtr) \ +#define NsNameSetInternalRep(objPtr, nnPtr) \ do { \ - Tcl_ObjIntRep ir; \ + Tcl_ObjInternalRep ir; \ (nnPtr)->refCount++; \ ir.twoPtrValue.ptr1 = (nnPtr); \ ir.twoPtrValue.ptr2 = NULL; \ - Tcl_StoreIntRep((objPtr), &nsNameType, &ir); \ + Tcl_StoreInternalRep((objPtr), &nsNameType, &ir); \ } while (0) -#define NsNameGetIntRep(objPtr, nnPtr) \ +#define NsNameGetInternalRep(objPtr, nnPtr) \ do { \ - const Tcl_ObjIntRep *irPtr; \ - irPtr = TclFetchIntRep((objPtr), &nsNameType); \ + const Tcl_ObjInternalRep *irPtr; \ + irPtr = TclFetchInternalRep((objPtr), &nsNameType); \ (nnPtr) = irPtr ? (ResolvedNsName *)irPtr->twoPtrValue.ptr1 : NULL; \ } while (0) @@ -2928,7 +2928,7 @@ GetNamespaceFromObj( { ResolvedNsName *resNamePtr; - NsNameGetIntRep(objPtr, resNamePtr); + NsNameGetInternalRep(objPtr, resNamePtr); if (resNamePtr) { Namespace *nsPtr, *refNsPtr; @@ -2945,10 +2945,10 @@ GetNamespaceFromObj( *nsPtrPtr = (Tcl_Namespace *) nsPtr; return TCL_OK; } - Tcl_StoreIntRep(objPtr, &nsNameType, NULL); + Tcl_StoreInternalRep(objPtr, &nsNameType, NULL); } if (SetNsNameFromAny(interp, objPtr) == TCL_OK) { - NsNameGetIntRep(objPtr, resNamePtr); + NsNameGetInternalRep(objPtr, resNamePtr); assert(resNamePtr != NULL); *nsPtrPtr = (Tcl_Namespace *) resNamePtr->nsPtr; return TCL_OK; @@ -4722,7 +4722,7 @@ FreeNsNameInternalRep( { ResolvedNsName *resNamePtr; - NsNameGetIntRep(objPtr, resNamePtr); + NsNameGetInternalRep(objPtr, resNamePtr); assert(resNamePtr != NULL); /* @@ -4768,9 +4768,9 @@ DupNsNameInternalRep( { ResolvedNsName *resNamePtr; - NsNameGetIntRep(srcPtr, resNamePtr); + NsNameGetInternalRep(srcPtr, resNamePtr); assert(resNamePtr != NULL); - NsNameSetIntRep(copyPtr, resNamePtr); + NsNameSetInternalRep(copyPtr, resNamePtr); } /* @@ -4833,7 +4833,7 @@ SetNsNameFromAny( resNamePtr->refNsPtr = (Namespace *) TclGetCurrentNamespace(interp); } resNamePtr->refCount = 0; - NsNameSetIntRep(objPtr, resNamePtr); + NsNameSetInternalRep(objPtr, resNamePtr); return TCL_OK; } @@ -5013,7 +5013,7 @@ TclLogCommandInfo( Tcl_ListObjLength(interp, iPtr->errorStack, &len); /* - * Reset while keeping the list intrep as much as possible. + * Reset while keeping the list internalrep as much as possible. */ Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, 0, NULL); @@ -5098,7 +5098,7 @@ TclErrorStackResetIf( Tcl_ListObjLength(interp, iPtr->errorStack, &len); /* - * Reset while keeping the list intrep as much as possible. + * Reset while keeping the list internalrep as much as possible. */ Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, 0, NULL); diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c index b7df93e..71db6c1 100644 --- a/generic/tclOOCall.c +++ b/generic/tclOOCall.c @@ -247,12 +247,12 @@ StashCallChain( Tcl_Obj *objPtr, CallChain *callPtr) { - Tcl_ObjIntRep ir; + Tcl_ObjInternalRep ir; callPtr->refCount++; TclGetString(objPtr); ir.twoPtrValue.ptr1 = callPtr; - Tcl_StoreIntRep(objPtr, &methodNameType, &ir); + Tcl_StoreInternalRep(objPtr, &methodNameType, &ir); } void @@ -280,7 +280,7 @@ DupMethodNameRep( Tcl_Obj *dstPtr) { StashCallChain(dstPtr, - (CallChain *)TclFetchIntRep(srcPtr, &methodNameType)->twoPtrValue.ptr1); + (CallChain *)TclFetchInternalRep(srcPtr, &methodNameType)->twoPtrValue.ptr1); } static void @@ -288,7 +288,7 @@ FreeMethodNameRep( Tcl_Obj *objPtr) { TclOODeleteChain( - (CallChain *)TclFetchIntRep(objPtr, &methodNameType)->twoPtrValue.ptr1); + (CallChain *)TclFetchInternalRep(objPtr, &methodNameType)->twoPtrValue.ptr1); } /* @@ -1189,16 +1189,16 @@ TclOOGetCallContext( * the object, and in the class). */ - const Tcl_ObjIntRep *irPtr; + const Tcl_ObjInternalRep *irPtr; const int reuseMask = (WANT_PUBLIC(flags) ? ~0 : ~PUBLIC_METHOD); - if ((irPtr = TclFetchIntRep(cacheInThisObj, &methodNameType))) { + if ((irPtr = TclFetchInternalRep(cacheInThisObj, &methodNameType))) { callPtr = (CallChain *)irPtr->twoPtrValue.ptr1; if (IsStillValid(callPtr, oPtr, flags, reuseMask)) { callPtr->refCount++; goto returnContext; } - Tcl_StoreIntRep(cacheInThisObj, &methodNameType, NULL); + Tcl_StoreInternalRep(cacheInThisObj, &methodNameType, NULL); } if (oPtr->flags & USE_CLASS_CACHE) { diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c index f111461..1903bb9 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.c @@ -859,7 +859,7 @@ PushMethodCallFrame( * alternative is *so* slow... */ - ByteCodeGetIntRep(pmPtr->procPtr->bodyPtr, &tclByteCodeType, codePtr); + ByteCodeGetInternalRep(pmPtr->procPtr->bodyPtr, &tclByteCodeType, codePtr); if (codePtr) { codePtr->nsPtr = nsPtr; } @@ -1338,7 +1338,7 @@ CloneProcedureMethod( bodyObj = Tcl_DuplicateObj(pmPtr->procPtr->bodyPtr); Tcl_GetString(bodyObj); - Tcl_StoreIntRep(pmPtr->procPtr->bodyPtr, &tclByteCodeType, NULL); + Tcl_StoreInternalRep(pmPtr->procPtr->bodyPtr, &tclByteCodeType, NULL); /* * Create the actual copy of the method record, manufacturing a new proc diff --git a/generic/tclObj.c b/generic/tclObj.c index 421c1da..e5ec838 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -1373,7 +1373,7 @@ TclFreeObj( PopObjToDelete(context, objToFree); TCL_DTRACE_OBJ_FREE(objToFree); - TclFreeIntRep(objToFree); + TclFreeInternalRep(objToFree); Tcl_MutexLock(&tclObjMutex); ckfree(objToFree); @@ -1592,7 +1592,7 @@ TclSetDuplicateObj( Tcl_Panic("%s called with shared object", "TclSetDuplicateObj"); } TclInvalidateStringRep(dupPtr); - TclFreeIntRep(dupPtr); + TclFreeInternalRep(dupPtr); SetDuplicateObj(dupPtr, objPtr); } @@ -1892,13 +1892,13 @@ Tcl_HasStringRep( /* *---------------------------------------------------------------------- * - * Tcl_StoreIntRep -- + * Tcl_StoreInternalRep -- * * This function is called to set the object's internal * representation to match a particular type. * * It is the caller's responsibility to guarantee that - * the value of the submitted IntRep is in agreement with + * the value of the submitted internalrep is in agreement with * the value of any existing string rep. * * Results: @@ -1912,17 +1912,17 @@ Tcl_HasStringRep( */ void -Tcl_StoreIntRep( +Tcl_StoreInternalRep( Tcl_Obj *objPtr, /* Object whose internal rep should be set. */ const Tcl_ObjType *typePtr, /* New type for the object */ - const Tcl_ObjIntRep *irPtr) /* New IntRep for the object */ + const Tcl_ObjInternalRep *irPtr) /* New internalrep for the object */ { - /* Clear out any existing IntRep ( "shimmer" ) */ - TclFreeIntRep(objPtr); + /* Clear out any existing internalrep ( "shimmer" ) */ + TclFreeInternalRep(objPtr); - /* When irPtr == NULL, just leave objPtr with no IntRep for typePtr */ + /* When irPtr == NULL, just leave objPtr with no internalrep for typePtr */ if (irPtr) { - /* Copy the new IntRep into place */ + /* Copy the new internalrep into place */ objPtr->internalRep = *irPtr; /* Set the type to match */ @@ -1933,13 +1933,13 @@ Tcl_StoreIntRep( /* *---------------------------------------------------------------------- * - * Tcl_FetchIntRep -- + * Tcl_FetchInternalRep -- * * This function is called to retrieve the object's internal * representation matching a requested type, if any. * * Results: - * A read-only pointer to the associated Tcl_ObjIntRep, or + * A read-only pointer to the associated Tcl_ObjInternalRep, or * NULL if no such internal representation exists. * * Side effects: @@ -1949,18 +1949,18 @@ Tcl_StoreIntRep( *---------------------------------------------------------------------- */ -Tcl_ObjIntRep * -Tcl_FetchIntRep( +Tcl_ObjInternalRep * +Tcl_FetchInternalRep( Tcl_Obj *objPtr, /* Object to fetch from. */ const Tcl_ObjType *typePtr) /* Requested type */ { - return TclFetchIntRep(objPtr, typePtr); + return TclFetchInternalRep(objPtr, typePtr); } /* *---------------------------------------------------------------------- * - * Tcl_FreeIntRep -- + * Tcl_FreeInternalRep -- * * This function is called to free an object's internal representation. * @@ -1975,10 +1975,10 @@ Tcl_FetchIntRep( */ void -Tcl_FreeIntRep( +Tcl_FreeInternalRep( Tcl_Obj *objPtr) /* Object whose internal rep should be freed. */ { - TclFreeIntRep(objPtr); + TclFreeInternalRep(objPtr); } /* @@ -2134,7 +2134,7 @@ Tcl_SetBooleanObj( * result unless "interp" is NULL. * * Side effects: - * The intrep of *objPtr may be changed. + * The internalrep of *objPtr may be changed. * *---------------------------------------------------------------------- */ @@ -2157,7 +2157,7 @@ Tcl_GetBooleanFromObj( if (objPtr->typePtr == &tclDoubleType) { /* * Caution: Don't be tempted to check directly for the "double" - * Tcl_ObjType and then compare the intrep to 0.0. This isn't + * Tcl_ObjType and then compare the internalrep to 0.0. This isn't * reliable because a "double" Tcl_ObjType can hold the NaN value. * Use the API Tcl_GetDoubleFromObj, which does the checking and * sets the proper error message for us. @@ -2357,13 +2357,13 @@ ParseBoolean( */ goodBoolean: - TclFreeIntRep(objPtr); + TclFreeInternalRep(objPtr); objPtr->internalRep.longValue = newBool; objPtr->typePtr = &tclBooleanType; return TCL_OK; numericBoolean: - TclFreeIntRep(objPtr); + TclFreeInternalRep(objPtr); objPtr->internalRep.wideValue = newBool; objPtr->typePtr = &tclIntType; return TCL_OK; @@ -3639,7 +3639,7 @@ GetBignumFromObj( } } else { TclUnpackBignum(objPtr, *bignumValue); - /* Optimized TclFreeIntRep */ + /* Optimized TclFreeInternalRep */ objPtr->internalRep.twoPtrValue.ptr1 = NULL; objPtr->internalRep.twoPtrValue.ptr2 = NULL; objPtr->typePtr = NULL; @@ -3793,14 +3793,14 @@ Tcl_SetBignumObj( return; tooLargeForWide: TclInvalidateStringRep(objPtr); - TclFreeIntRep(objPtr); - TclSetBignumIntRep(objPtr, bignumValue); + TclFreeInternalRep(objPtr); + TclSetBignumInternalRep(objPtr, bignumValue); } /* *---------------------------------------------------------------------- * - * TclSetBignumIntRep -- + * TclSetBignumInternalRep -- * * Install a bignum into the internal representation of an object. * @@ -3816,7 +3816,7 @@ Tcl_SetBignumObj( */ void -TclSetBignumIntRep( +TclSetBignumInternalRep( Tcl_Obj *objPtr, void *big) { @@ -4554,7 +4554,7 @@ SetCmdNameObj( } if (resPtr == NULL) { - TclFreeIntRep(objPtr); + TclFreeInternalRep(objPtr); objPtr->internalRep.twoPtrValue.ptr1 = fillPtr; objPtr->internalRep.twoPtrValue.ptr2 = NULL; diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index e4826ad..b5207a1 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.c @@ -85,13 +85,13 @@ typedef struct FsPath { * fields. */ -#define PATHOBJ(pathPtr) ((FsPath *) (TclFetchIntRep((pathPtr), &fsPathType)->twoPtrValue.ptr1)) +#define PATHOBJ(pathPtr) ((FsPath *) (TclFetchInternalRep((pathPtr), &fsPathType)->twoPtrValue.ptr1)) #define SETPATHOBJ(pathPtr,fsPathPtr) \ do { \ - Tcl_ObjIntRep ir; \ + Tcl_ObjInternalRep ir; \ ir.twoPtrValue.ptr1 = (void *) (fsPathPtr); \ ir.twoPtrValue.ptr2 = NULL; \ - Tcl_StoreIntRep((pathPtr), &fsPathType, &ir); \ + Tcl_StoreInternalRep((pathPtr), &fsPathType, &ir); \ } while (0) #define PATHFLAGS(pathPtr) (PATHOBJ(pathPtr)->flags) @@ -544,7 +544,7 @@ TclPathPart( Tcl_Obj *pathPtr, /* Path to take dirname of */ Tcl_PathPart portion) /* Requested portion of name */ { - if (TclHasIntRep(pathPtr, &fsPathType)) { + if (TclHasInternalRep(pathPtr, &fsPathType)) { FsPath *fsPathPtr = PATHOBJ(pathPtr); if (PATHFLAGS(pathPtr) != 0) { @@ -843,7 +843,7 @@ TclJoinPath( if (elements == 2) { Tcl_Obj *elt = objv[0]; - Tcl_ObjIntRep *eltIr = TclFetchIntRep(elt, &fsPathType); + Tcl_ObjInternalRep *eltIr = TclFetchInternalRep(elt, &fsPathType); /* * This is a special case where we can be much more efficient, where @@ -1149,13 +1149,13 @@ Tcl_FSConvertToPathType( * path. */ - if (TclHasIntRep(pathPtr, &fsPathType)) { + if (TclHasInternalRep(pathPtr, &fsPathType)) { if (TclFSEpochOk(PATHOBJ(pathPtr)->filesystemEpoch)) { return TCL_OK; } TclGetString(pathPtr); - Tcl_StoreIntRep(pathPtr, &fsPathType, NULL); + Tcl_StoreInternalRep(pathPtr, &fsPathType, NULL); } return SetFsPathFromAny(interp, pathPtr); @@ -1349,7 +1349,7 @@ AppendPath( * that use some character other than "/" as a path separator. I know * of no evidence that such a foolish thing exists. This solution was * chosen so that "JoinPath" operations that pass through either path - * intrep produce the same results; that is, bugward compatibility. If + * internalrep produce the same results; that is, bugward compatibility. If * we need to fix that bug here, it needs fixing in TclJoinPath() too. */ bytes = TclGetStringFromObj(tail, &numBytes); @@ -1391,7 +1391,7 @@ TclFSMakePathRelative( { int cwdLen, len; const char *tempStr; - Tcl_ObjIntRep *irPtr = TclFetchIntRep(pathPtr, &fsPathType); + Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(pathPtr, &fsPathType); if (irPtr) { FsPath *fsPathPtr = PATHOBJ(pathPtr); @@ -1461,7 +1461,7 @@ MakePathFromNormalized( { FsPath *fsPathPtr; - if (TclHasIntRep(pathPtr, &fsPathType)) { + if (TclHasInternalRep(pathPtr, &fsPathType)) { return TCL_OK; } @@ -1532,7 +1532,7 @@ Tcl_FSNewNativePath( * safe. */ - Tcl_StoreIntRep(pathPtr, &fsPathType, NULL); + Tcl_StoreInternalRep(pathPtr, &fsPathType, NULL); fsPathPtr = (FsPath *)ckalloc(sizeof(FsPath)); fsPathPtr->translatedPathPtr = NULL; @@ -1598,7 +1598,7 @@ Tcl_FSGetTranslatedPath( Tcl_Obj *translatedCwdPtr = Tcl_FSGetTranslatedPath(interp, srcFsPathPtr->cwdPtr); - Tcl_ObjIntRep *translatedCwdIrPtr; + Tcl_ObjInternalRep *translatedCwdIrPtr; if (translatedCwdPtr == NULL) { return NULL; @@ -1607,7 +1607,7 @@ Tcl_FSGetTranslatedPath( retObj = Tcl_FSJoinToPath(translatedCwdPtr, 1, &srcFsPathPtr->normPathPtr); Tcl_IncrRefCount(srcFsPathPtr->translatedPathPtr = retObj); - translatedCwdIrPtr = TclFetchIntRep(translatedCwdPtr, &fsPathType); + translatedCwdIrPtr = TclFetchInternalRep(translatedCwdPtr, &fsPathType); if (translatedCwdIrPtr) { srcFsPathPtr->filesystemEpoch = PATHOBJ(translatedCwdPtr)->filesystemEpoch; @@ -1802,7 +1802,7 @@ Tcl_FSGetNormalizedPath( if (fsPathPtr->cwdPtr != NULL) { if (!TclFSCwdPointerEquals(&fsPathPtr->cwdPtr)) { TclGetString(pathPtr); - Tcl_StoreIntRep(pathPtr, &fsPathType, NULL); + Tcl_StoreInternalRep(pathPtr, &fsPathType, NULL); if (SetFsPathFromAny(interp, pathPtr) != TCL_OK) { return NULL; } @@ -2048,7 +2048,7 @@ TclFSEnsureEpochOk( { FsPath *srcFsPathPtr; - if (!TclHasIntRep(pathPtr, &fsPathType)) { + if (!TclHasInternalRep(pathPtr, &fsPathType)) { return TCL_OK; } @@ -2062,7 +2062,7 @@ TclFSEnsureEpochOk( */ TclGetString(pathPtr); - Tcl_StoreIntRep(pathPtr, &fsPathType, NULL); + Tcl_StoreInternalRep(pathPtr, &fsPathType, NULL); if (SetFsPathFromAny(NULL, pathPtr) != TCL_OK) { return TCL_ERROR; } @@ -2106,7 +2106,7 @@ TclFSSetPathDetails( * Make sure pathPtr is of the correct type. */ - if (!TclHasIntRep(pathPtr, &fsPathType)) { + if (!TclHasInternalRep(pathPtr, &fsPathType)) { if (SetFsPathFromAny(NULL, pathPtr) != TCL_OK) { return; } @@ -2206,7 +2206,7 @@ SetFsPathFromAny( Tcl_Obj *transPtr; const char *name; - if (TclHasIntRep(pathPtr, &fsPathType)) { + if (TclHasInternalRep(pathPtr, &fsPathType)) { return TCL_OK; } @@ -2519,7 +2519,7 @@ TclNativePathInFilesystem( * semantics of Tcl (at present anyway), so we have to abide by them here. */ - if (TclHasIntRep(pathPtr, &fsPathType)) { + if (TclHasInternalRep(pathPtr, &fsPathType)) { if (pathPtr->bytes != NULL && pathPtr->bytes[0] == '\0') { /* * We reject the empty path "". diff --git a/generic/tclProc.c b/generic/tclProc.c index b3de29a..402b752 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -67,19 +67,19 @@ const Tcl_ObjType tclProcBodyType = { * should panic instead. */ }; -#define ProcSetIntRep(objPtr, procPtr) \ +#define ProcSetInternalRep(objPtr, procPtr) \ do { \ - Tcl_ObjIntRep ir; \ + Tcl_ObjInternalRep ir; \ (procPtr)->refCount++; \ ir.twoPtrValue.ptr1 = (procPtr); \ ir.twoPtrValue.ptr2 = NULL; \ - Tcl_StoreIntRep((objPtr), &tclProcBodyType, &ir); \ + Tcl_StoreInternalRep((objPtr), &tclProcBodyType, &ir); \ } while (0) -#define ProcGetIntRep(objPtr, procPtr) \ +#define ProcGetInternalRep(objPtr, procPtr) \ do { \ - const Tcl_ObjIntRep *irPtr; \ - irPtr = TclFetchIntRep((objPtr), &tclProcBodyType); \ + const Tcl_ObjInternalRep *irPtr; \ + irPtr = TclFetchInternalRep((objPtr), &tclProcBodyType); \ (procPtr) = irPtr ? (Proc *)irPtr->twoPtrValue.ptr1 : NULL; \ } while (0) @@ -113,19 +113,19 @@ static const Tcl_ObjType lambdaType = { SetLambdaFromAny /* setFromAnyProc */ }; -#define LambdaSetIntRep(objPtr, procPtr, nsObjPtr) \ +#define LambdaSetInternalRep(objPtr, procPtr, nsObjPtr) \ do { \ - Tcl_ObjIntRep ir; \ + Tcl_ObjInternalRep ir; \ ir.twoPtrValue.ptr1 = (procPtr); \ ir.twoPtrValue.ptr2 = (nsObjPtr); \ Tcl_IncrRefCount((nsObjPtr)); \ - Tcl_StoreIntRep((objPtr), &lambdaType, &ir); \ + Tcl_StoreInternalRep((objPtr), &lambdaType, &ir); \ } while (0) -#define LambdaGetIntRep(objPtr, procPtr, nsObjPtr) \ +#define LambdaGetInternalRep(objPtr, procPtr, nsObjPtr) \ do { \ - const Tcl_ObjIntRep *irPtr; \ - irPtr = TclFetchIntRep((objPtr), &lambdaType); \ + const Tcl_ObjInternalRep *irPtr; \ + irPtr = TclFetchInternalRep((objPtr), &lambdaType); \ (procPtr) = irPtr ? (Proc *)irPtr->twoPtrValue.ptr1 : NULL; \ (nsObjPtr) = irPtr ? (Tcl_Obj *)irPtr->twoPtrValue.ptr2 : NULL; \ } while (0) @@ -327,7 +327,7 @@ Tcl_ProcObjCmd( * of all procs whose argument list is just _args_ */ - if (TclHasIntRep(objv[3], &tclProcBodyType)) { + if (TclHasInternalRep(objv[3], &tclProcBodyType)) { goto done; } @@ -409,7 +409,7 @@ TclCreateProc( Tcl_Obj **argArray; int precompiled = 0; - ProcGetIntRep(bodyPtr, procPtr); + ProcGetInternalRep(bodyPtr, procPtr); if (procPtr != NULL) { /* * Because the body is a TclProProcBody, the actual body is already @@ -724,7 +724,7 @@ TclGetFrame( obj.length = strlen(name); obj.typePtr = NULL; result = TclObjGetFrame(interp, &obj, framePtrPtr); - TclFreeIntRep(&obj); + TclFreeInternalRep(&obj); return result; } @@ -762,7 +762,7 @@ TclObjGetFrame( { Interp *iPtr = (Interp *) interp; int curLevel, level, result; - const Tcl_ObjIntRep *irPtr; + const Tcl_ObjInternalRep *irPtr; const char *name = NULL; Tcl_WideInt w; @@ -788,7 +788,7 @@ TclObjGetFrame( level = curLevel - level; result = 1; } - } else if ((irPtr = TclFetchIntRep(objPtr, &levelReferenceType))) { + } else if ((irPtr = TclFetchInternalRep(objPtr, &levelReferenceType))) { level = irPtr->wideValue; result = 1; } else { @@ -798,10 +798,10 @@ TclObjGetFrame( if (level < 0 || (level > 0 && name[1] == '-')) { result = -1; } else { - Tcl_ObjIntRep ir; + Tcl_ObjInternalRep ir; ir.wideValue = level; - Tcl_StoreIntRep(objPtr, &levelReferenceType, &ir); + Tcl_StoreInternalRep(objPtr, &levelReferenceType, &ir); result = 1; } } else { @@ -1151,7 +1151,7 @@ TclInitCompiledLocals( ByteCode *codePtr; bodyPtr = framePtr->procPtr->bodyPtr; - ByteCodeGetIntRep(bodyPtr, &tclByteCodeType, codePtr); + ByteCodeGetInternalRep(bodyPtr, &tclByteCodeType, codePtr); if (codePtr == NULL) { Tcl_Panic("body object for proc attached to frame is not a byte code type"); } @@ -1327,7 +1327,7 @@ InitLocalCache( CompiledLocal *localPtr; int isNew; - ByteCodeGetIntRep(procPtr->bodyPtr, &tclByteCodeType, codePtr); + ByteCodeGetInternalRep(procPtr->bodyPtr, &tclByteCodeType, codePtr); /* * Cache the names and initial values of local variables; store the @@ -1400,7 +1400,7 @@ InitArgsAndLocals( int localCt = procPtr->numCompiledLocals, numArgs, argCt, i, imax; Tcl_Obj *const *argObjs; - ByteCodeGetIntRep(procPtr->bodyPtr, &tclByteCodeType, codePtr); + ByteCodeGetInternalRep(procPtr->bodyPtr, &tclByteCodeType, codePtr); /* * Make sure that the local cache of variable names and initial values has @@ -1576,7 +1576,7 @@ TclPushProcCallFrame( * local variables are found while compiling. */ - ByteCodeGetIntRep(procPtr->bodyPtr, &tclByteCodeType, codePtr); + ByteCodeGetInternalRep(procPtr->bodyPtr, &tclByteCodeType, codePtr); if (codePtr != NULL) { Interp *iPtr = (Interp *) interp; @@ -1786,7 +1786,7 @@ TclNRInterpProcCore( */ procPtr->refCount++; - ByteCodeGetIntRep(procPtr->bodyPtr, &tclByteCodeType, codePtr); + ByteCodeGetInternalRep(procPtr->bodyPtr, &tclByteCodeType, codePtr); TclNRAddCallback(interp, InterpProcNR2, procNameObj, errorProc, NULL, NULL); @@ -1920,7 +1920,7 @@ TclProcCompileProc( Tcl_CallFrame *framePtr; ByteCode *codePtr; - ByteCodeGetIntRep(bodyPtr, &tclByteCodeType, codePtr); + ByteCodeGetInternalRep(bodyPtr, &tclByteCodeType, codePtr); /* * If necessary, compile the procedure's body. The compiler will allocate @@ -1955,7 +1955,7 @@ TclProcCompileProc( codePtr->compileEpoch = iPtr->compileEpoch; codePtr->nsPtr = nsPtr; } else { - Tcl_StoreIntRep(bodyPtr, &tclByteCodeType, NULL); + Tcl_StoreInternalRep(bodyPtr, &tclByteCodeType, NULL); codePtr = NULL; } } @@ -2312,7 +2312,7 @@ TclNewProcBodyObj( TclNewObj(objPtr); if (objPtr) { - ProcSetIntRep(objPtr, procPtr); + ProcSetInternalRep(objPtr, procPtr); } return objPtr; @@ -2341,9 +2341,9 @@ ProcBodyDup( Tcl_Obj *dupPtr) /* Target object for the duplication. */ { Proc *procPtr; - ProcGetIntRep(srcPtr, procPtr); + ProcGetInternalRep(srcPtr, procPtr); - ProcSetIntRep(dupPtr, procPtr); + ProcSetInternalRep(dupPtr, procPtr); } /* @@ -2371,7 +2371,7 @@ ProcBodyFree( { Proc *procPtr; - ProcGetIntRep(objPtr, procPtr); + ProcGetInternalRep(objPtr, procPtr); if (procPtr->refCount-- <= 1) { TclProcCleanupProc(procPtr); @@ -2400,12 +2400,12 @@ DupLambdaInternalRep( Proc *procPtr; Tcl_Obj *nsObjPtr; - LambdaGetIntRep(srcPtr, procPtr, nsObjPtr); + LambdaGetInternalRep(srcPtr, procPtr, nsObjPtr); assert(procPtr != NULL); procPtr->refCount++; - LambdaSetIntRep(copyPtr, procPtr, nsObjPtr); + LambdaSetInternalRep(copyPtr, procPtr, nsObjPtr); } static void @@ -2416,7 +2416,7 @@ FreeLambdaInternalRep( Proc *procPtr; Tcl_Obj *nsObjPtr; - LambdaGetIntRep(objPtr, procPtr, nsObjPtr); + LambdaGetInternalRep(objPtr, procPtr, nsObjPtr); assert(procPtr != NULL); if (procPtr->refCount-- <= 1) { @@ -2590,7 +2590,7 @@ SetLambdaFromAny( * conversion to lambdaType. */ - LambdaSetIntRep(objPtr, procPtr, nsObjPtr); + LambdaSetInternalRep(objPtr, procPtr, nsObjPtr); return TCL_OK; } @@ -2603,13 +2603,13 @@ TclGetLambdaFromObj( Proc *procPtr; Tcl_Obj *nsObjPtr; - LambdaGetIntRep(objPtr, procPtr, nsObjPtr); + LambdaGetInternalRep(objPtr, procPtr, nsObjPtr); if (procPtr == NULL) { if (SetLambdaFromAny(interp, objPtr) != TCL_OK) { return NULL; } - LambdaGetIntRep(objPtr, procPtr, nsObjPtr); + LambdaGetInternalRep(objPtr, procPtr, nsObjPtr); } assert(procPtr != NULL); diff --git a/generic/tclRegexp.c b/generic/tclRegexp.c index f161782..b7fbb81 100644 --- a/generic/tclRegexp.c +++ b/generic/tclRegexp.c @@ -109,19 +109,19 @@ const Tcl_ObjType tclRegexpType = { SetRegexpFromAny /* setFromAnyProc */ }; -#define RegexpSetIntRep(objPtr, rePtr) \ +#define RegexpSetInternalRep(objPtr, rePtr) \ do { \ - Tcl_ObjIntRep ir; \ + Tcl_ObjInternalRep ir; \ (rePtr)->refCount++; \ ir.twoPtrValue.ptr1 = (rePtr); \ ir.twoPtrValue.ptr2 = NULL; \ - Tcl_StoreIntRep((objPtr), &tclRegexpType, &ir); \ + Tcl_StoreInternalRep((objPtr), &tclRegexpType, &ir); \ } while (0) -#define RegexpGetIntRep(objPtr, rePtr) \ +#define RegexpGetInternalRep(objPtr, rePtr) \ do { \ - const Tcl_ObjIntRep *irPtr; \ - irPtr = TclFetchIntRep((objPtr), &tclRegexpType); \ + const Tcl_ObjInternalRep *irPtr; \ + irPtr = TclFetchInternalRep((objPtr), &tclRegexpType); \ (rePtr) = irPtr ? (TclRegexp *)irPtr->twoPtrValue.ptr1 : NULL; \ } while (0) @@ -598,7 +598,7 @@ Tcl_GetRegExpFromObj( TclRegexp *regexpPtr; const char *pattern; - RegexpGetIntRep(objPtr, regexpPtr); + RegexpGetInternalRep(objPtr, regexpPtr); if ((regexpPtr == NULL) || (regexpPtr->flags != flags)) { pattern = TclGetStringFromObj(objPtr, &length); @@ -608,7 +608,7 @@ Tcl_GetRegExpFromObj( return NULL; } - RegexpSetIntRep(objPtr, regexpPtr); + RegexpSetInternalRep(objPtr, regexpPtr); } return (Tcl_RegExp) regexpPtr; } @@ -757,7 +757,7 @@ FreeRegexpInternalRep( { TclRegexp *regexpRepPtr; - RegexpGetIntRep(objPtr, regexpRepPtr); + RegexpGetInternalRep(objPtr, regexpRepPtr); assert(regexpRepPtr != NULL); @@ -794,11 +794,11 @@ DupRegexpInternalRep( { TclRegexp *regexpPtr; - RegexpGetIntRep(srcPtr, regexpPtr); + RegexpGetInternalRep(srcPtr, regexpPtr); assert(regexpPtr != NULL); - RegexpSetIntRep(copyPtr, regexpPtr); + RegexpSetInternalRep(copyPtr, regexpPtr); } /* diff --git a/generic/tclResult.c b/generic/tclResult.c index 5b7a8e5..dba57c1 100644 --- a/generic/tclResult.c +++ b/generic/tclResult.c @@ -1013,7 +1013,7 @@ ResetObjResult( objResultPtr->bytes = &tclEmptyString; objResultPtr->length = 0; } - TclFreeIntRep(objResultPtr); + TclFreeInternalRep(objResultPtr); } } @@ -1336,7 +1336,7 @@ TclProcessReturn( Tcl_ListObjLength(interp, iPtr->errorStack, &len); /* - * Reset while keeping the list intrep as much as possible. + * Reset while keeping the list internalrep as much as possible. */ Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, valueObjc, diff --git a/generic/tclScan.c b/generic/tclScan.c index f35b376..5568529 100644 --- a/generic/tclScan.c +++ b/generic/tclScan.c @@ -1017,8 +1017,8 @@ Tcl_ScanObjCmd( double dvalue; if (Tcl_GetDoubleFromObj(NULL, objPtr, &dvalue) != TCL_OK) { #ifdef ACCEPT_NAN - const Tcl_ObjIntRep *irPtr - = TclFetchIntRep(objPtr, &tclDoubleType); + const Tcl_ObjInternalRep *irPtr + = TclFetchInternalRep(objPtr, &tclDoubleType); if (irPtr) { dvalue = irPtr->doubleValue; } else diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c index b213bed..3cee154 100644 --- a/generic/tclStrToD.c +++ b/generic/tclStrToD.c @@ -553,11 +553,11 @@ TclParseNumber( if (bytes == NULL) { if (interp == NULL && endPtrPtr == NULL) { - if (TclHasIntRep(objPtr, &tclDictType)) { + if (TclHasInternalRep(objPtr, &tclDictType)) { /* A dict can never be a (single) number */ return TCL_ERROR; } - if (TclHasIntRep(objPtr, &tclListType)) { + if (TclHasInternalRep(objPtr, &tclListType)) { int length; /* A list can only be a (single) number if its length == 1 */ TclListObjLength(NULL, objPtr, &length); @@ -1295,7 +1295,7 @@ TclParseNumber( */ if (status == TCL_OK && objPtr != NULL) { - TclFreeIntRep(objPtr); + TclFreeInternalRep(objPtr); switch (acceptState) { case SIGNUM: case BAD_OCTAL: @@ -1405,7 +1405,7 @@ TclParseNumber( if (signum) { err = mp_neg(&octalSignificandBig, &octalSignificandBig); } - TclSetBignumIntRep(objPtr, &octalSignificandBig); + TclSetBignumInternalRep(objPtr, &octalSignificandBig); } if (err != MP_OKAY) { return TCL_ERROR; @@ -1441,7 +1441,7 @@ TclParseNumber( if (signum) { err = mp_neg(&significandBig, &significandBig); } - TclSetBignumIntRep(objPtr, &significandBig); + TclSetBignumInternalRep(objPtr, &significandBig); } if (err != MP_OKAY) { return TCL_ERROR; diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 508b280..91b632a 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -836,7 +836,7 @@ Tcl_SetStringObj( * Set the type to NULL and free any internal rep for the old type. */ - TclFreeIntRep(objPtr); + TclFreeInternalRep(objPtr); /* * Free any old string rep, then set the string rep to a copy of the @@ -1098,7 +1098,7 @@ Tcl_SetUnicodeObj( if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object", "Tcl_SetUnicodeObj"); } - TclFreeIntRep(objPtr); + TclFreeInternalRep(objPtr); SetUnicodeObj(objPtr, unicode, numChars); } @@ -1443,7 +1443,7 @@ Tcl_AppendObjToObj( * If appendObjPtr is not of the "String" type, don't convert it. */ - if (TclHasIntRep(appendObjPtr, &tclStringType)) { + if (TclHasInternalRep(appendObjPtr, &tclStringType)) { Tcl_UniChar *unicode = Tcl_GetUnicodeFromObj(appendObjPtr, &numChars); @@ -1464,7 +1464,7 @@ Tcl_AppendObjToObj( bytes = TclGetStringFromObj(appendObjPtr, &length); numChars = stringPtr->numChars; - if ((numChars >= 0) && TclHasIntRep(appendObjPtr, &tclStringType)) { + if ((numChars >= 0) && TclHasInternalRep(appendObjPtr, &tclStringType)) { String *appendStringPtr = GET_STRING(appendObjPtr); appendNumChars = appendStringPtr->numChars; @@ -2869,7 +2869,7 @@ TclGetStringStorage( { String *stringPtr; - if (!TclHasIntRep(objPtr, &tclStringType) || objPtr->bytes == NULL) { + if (!TclHasInternalRep(objPtr, &tclStringType) || objPtr->bytes == NULL) { return TclGetStringFromObj(objPtr, (int *)sizePtr); } @@ -2917,7 +2917,7 @@ TclStringRepeat( */ if (!binary) { - if (TclHasIntRep(objPtr, &tclStringType)) { + if (TclHasInternalRep(objPtr, &tclStringType)) { String *stringPtr = GET_STRING(objPtr); if (stringPtr->hasUnicode) { unichar = 1; @@ -3001,7 +3001,7 @@ TclStringRepeat( if (!inPlace || Tcl_IsShared(objPtr)) { objResultPtr = Tcl_NewStringObj(Tcl_GetString(objPtr), length); } else { - TclFreeIntRep(objPtr); + TclFreeInternalRep(objPtr); objResultPtr = objPtr; } if (0 == Tcl_AttemptSetObjLength(objResultPtr, count*length)) { @@ -3096,7 +3096,7 @@ TclStringCat( } else { /* assert (objPtr->typePtr != NULL) -- stork! */ binary = 0; - if (TclHasIntRep(objPtr, &tclStringType)) { + if (TclHasInternalRep(objPtr, &tclStringType)) { /* Have a pure Unicode value; ask to preserve it */ requestUniChar = 1; } else { @@ -3363,7 +3363,7 @@ TclStringCat( dst = Tcl_GetString(objResultPtr) + start; /* assert ( length > start ) */ - TclFreeIntRep(objResultPtr); + TclFreeInternalRep(objResultPtr); } else { TclNewObj(objResultPtr); /* PANIC? */ if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) { @@ -3449,8 +3449,8 @@ TclStringCmp( s1 = (char *) Tcl_GetByteArrayFromObj(value1Ptr, &s1len); s2 = (char *) Tcl_GetByteArrayFromObj(value2Ptr, &s2len); memCmpFn = memcmp; - } else if (TclHasIntRep(value1Ptr, &tclStringType) - && TclHasIntRep(value2Ptr, &tclStringType)) { + } else if (TclHasInternalRep(value1Ptr, &tclStringType) + && TclHasInternalRep(value2Ptr, &tclStringType)) { /* * Do a unicode-specific comparison if both of the args are of * String type. If the char length == byte length, we can do a @@ -4284,7 +4284,7 @@ SetStringFromAny( TCL_UNUSED(Tcl_Interp *), Tcl_Obj *objPtr) /* The object to convert. */ { - if (!TclHasIntRep(objPtr, &tclStringType)) { + if (!TclHasInternalRep(objPtr, &tclStringType)) { String *stringPtr = stringAlloc(0); /* @@ -4292,10 +4292,10 @@ SetStringFromAny( */ (void) TclGetString(objPtr); - TclFreeIntRep(objPtr); + TclFreeInternalRep(objPtr); /* - * Create a basic String intrep that just points to the UTF-8 string + * Create a basic String internalrep that just points to the UTF-8 string * already in place at objPtr->bytes. */ diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 137aea0..533e2c7 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -1920,10 +1920,10 @@ const TclStubs tclStubs = { TclZipfs_Unmount, /* 633 */ TclZipfs_TclLibrary, /* 634 */ TclZipfs_MountBuffer, /* 635 */ - Tcl_FreeIntRep, /* 636 */ + Tcl_FreeInternalRep, /* 636 */ Tcl_InitStringRep, /* 637 */ - Tcl_FetchIntRep, /* 638 */ - Tcl_StoreIntRep, /* 639 */ + Tcl_FetchInternalRep, /* 638 */ + Tcl_StoreInternalRep, /* 639 */ Tcl_HasStringRep, /* 640 */ Tcl_IncrRefCount, /* 641 */ Tcl_DecrRefCount, /* 642 */ diff --git a/generic/tclTest.c b/generic/tclTest.c index 5c08aa0..1ce11eb 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -1654,7 +1654,7 @@ TestdoubledigitsObjCmd( status = Tcl_GetDoubleFromObj(interp, objv[1], &d); if (status != TCL_OK) { doubleType = Tcl_GetObjType("double"); - if (Tcl_FetchIntRep(objv[1], doubleType) + if (Tcl_FetchInternalRep(objv[1], doubleType) && TclIsNaN(objv[1]->internalRep.doubleValue)) { status = TCL_OK; memcpy(&d, &(objv[1]->internalRep.doubleValue), sizeof(double)); @@ -1891,7 +1891,7 @@ TestencodingObjCmd( } Tcl_FreeEncoding(encoding); /* Free returned reference */ Tcl_FreeEncoding(encoding); /* Free to match CREATE */ - TclFreeIntRep(objv[2]); /* Free the cached ref */ + TclFreeInternalRep(objv[2]); /* Free the cached ref */ break; } return TCL_OK; diff --git a/generic/tclUtil.c b/generic/tclUtil.c index bbacbe2..32721f6 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -123,7 +123,7 @@ static int FindElement(Tcl_Interp *interp, const char *string, * represents a list index in the form, "end-offset". It is used as a * performance optimization in Tcl_GetIntForIndex. The internal rep is * stored directly in the wideValue, so no memory management is required - * for it. This is a caching intrep, keeping the result of a parse + * for it. This is a caching internalrep, keeping the result of a parse * around. This type is only created from a pre-existing string, so an * updateStringProc will never be called and need not exist. The type * is unregistered, so has no need of a setFromAnyProc either. @@ -2589,7 +2589,7 @@ TclStringMatchObj( trivial = nocase ? 0 : TclMatchIsTrivial(TclGetString(ptnObj)); */ - if (TclHasIntRep(strObj, &tclStringType) || (strObj->typePtr == NULL)) { + if (TclHasInternalRep(strObj, &tclStringType) || (strObj->typePtr == NULL)) { Tcl_UniChar *udata, *uptn; udata = Tcl_GetUnicodeFromObj(strObj, &length); @@ -3035,7 +3035,7 @@ Tcl_DStringGetResult( dsPtr->string = TclGetString(iPtr->objResultPtr); dsPtr->length = iPtr->objResultPtr->length; dsPtr->spaceAvl = dsPtr->length + 1; - TclFreeIntRep(iPtr->objResultPtr); + TclFreeInternalRep(iPtr->objResultPtr); iPtr->objResultPtr->bytes = &tclEmptyString; iPtr->objResultPtr->length = 0; } @@ -3752,12 +3752,12 @@ GetEndOffsetFromObj( Tcl_WideInt *widePtr) /* Location filled in with an integer * representing an index. */ { - Tcl_ObjIntRep *irPtr; + Tcl_ObjInternalRep *irPtr; Tcl_WideInt offset = -1; /* Offset in the "end-offset" expression - 1 */ ClientData cd; - while ((irPtr = TclFetchIntRep(objPtr, &endOffsetType)) == NULL) { - Tcl_ObjIntRep ir; + while ((irPtr = TclFetchInternalRep(objPtr, &endOffsetType)) == NULL) { + Tcl_ObjInternalRep ir; int length; const char *bytes = TclGetStringFromObj(objPtr, &length); @@ -3816,8 +3816,8 @@ GetEndOffsetFromObj( } } } - /* Clear invalid intreps left by TclParseNumber */ - TclFreeIntRep(objPtr); + /* Clear invalid internalreps left by TclParseNumber */ + TclFreeInternalRep(objPtr); if (t1 && t2) { /* We have both integer values */ @@ -3942,7 +3942,7 @@ GetEndOffsetFromObj( parseOK: /* Success. Store the new internal rep. */ ir.wideValue = offset; - Tcl_StoreIntRep(objPtr, &endOffsetType, &ir); + Tcl_StoreInternalRep(objPtr, &endOffsetType, &ir); } offset = irPtr->wideValue; @@ -4047,7 +4047,7 @@ TclIndexEncode( int idx; if (TCL_OK == GetWideForIndex(interp, objPtr, (unsigned)TCL_INDEX_END , &wide)) { - const Tcl_ObjIntRep *irPtr = TclFetchIntRep(objPtr, &endOffsetType); + const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objPtr, &endOffsetType); if (irPtr && irPtr->wideValue >= 0) { /* "int[+-]int" syntax, works the same here as "int" */ irPtr = NULL; @@ -4330,7 +4330,7 @@ TclSetProcessGlobalValue( /* * Fill the local thread copy directly with the Tcl_Obj value to avoid - * loss of the intrep. Increment newValue refCount early to handle case + * loss of the internalrep. Increment newValue refCount early to handle case * where we set a PGV to itself. */ diff --git a/generic/tclVar.c b/generic/tclVar.c index 51c51f8..d2b8227 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -253,20 +253,20 @@ static const Tcl_ObjType localVarNameType = { FreeLocalVarName, DupLocalVarName, NULL, NULL }; -#define LocalSetIntRep(objPtr, index, namePtr) \ +#define LocalSetInternalRep(objPtr, index, namePtr) \ do { \ - Tcl_ObjIntRep ir; \ + Tcl_ObjInternalRep ir; \ Tcl_Obj *ptr = (namePtr); \ if (ptr) {Tcl_IncrRefCount(ptr);} \ ir.twoPtrValue.ptr1 = ptr; \ ir.twoPtrValue.ptr2 = INT2PTR(index); \ - Tcl_StoreIntRep((objPtr), &localVarNameType, &ir); \ + Tcl_StoreInternalRep((objPtr), &localVarNameType, &ir); \ } while (0) -#define LocalGetIntRep(objPtr, index, name) \ +#define LocalGetInternalRep(objPtr, index, name) \ do { \ - const Tcl_ObjIntRep *irPtr; \ - irPtr = TclFetchIntRep((objPtr), &localVarNameType); \ + const Tcl_ObjInternalRep *irPtr; \ + irPtr = TclFetchInternalRep((objPtr), &localVarNameType); \ (name) = irPtr ? (Tcl_Obj *)irPtr->twoPtrValue.ptr1 : NULL; \ (index) = irPtr ? PTR2INT(irPtr->twoPtrValue.ptr2) : -1; \ } while (0) @@ -276,22 +276,22 @@ static const Tcl_ObjType parsedVarNameType = { FreeParsedVarName, DupParsedVarName, NULL, NULL }; -#define ParsedSetIntRep(objPtr, arrayPtr, elem) \ +#define ParsedSetInternalRep(objPtr, arrayPtr, elem) \ do { \ - Tcl_ObjIntRep ir; \ + Tcl_ObjInternalRep ir; \ Tcl_Obj *ptr1 = (arrayPtr); \ Tcl_Obj *ptr2 = (elem); \ if (ptr1) {Tcl_IncrRefCount(ptr1);} \ if (ptr2) {Tcl_IncrRefCount(ptr2);} \ ir.twoPtrValue.ptr1 = ptr1; \ ir.twoPtrValue.ptr2 = ptr2; \ - Tcl_StoreIntRep((objPtr), &parsedVarNameType, &ir); \ + Tcl_StoreInternalRep((objPtr), &parsedVarNameType, &ir); \ } while (0) -#define ParsedGetIntRep(objPtr, parsed, array, elem) \ +#define ParsedGetInternalRep(objPtr, parsed, array, elem) \ do { \ - const Tcl_ObjIntRep *irPtr; \ - irPtr = TclFetchIntRep((objPtr), &parsedVarNameType); \ + const Tcl_ObjInternalRep *irPtr; \ + irPtr = TclFetchInternalRep((objPtr), &parsedVarNameType); \ (parsed) = (irPtr != NULL); \ (array) = irPtr ? (Tcl_Obj *)irPtr->twoPtrValue.ptr1 : NULL; \ (elem) = irPtr ? (Tcl_Obj *)irPtr->twoPtrValue.ptr2 : NULL; \ @@ -615,7 +615,7 @@ TclObjLookupVarEx( *arrayPtrPtr = NULL; restart: - LocalGetIntRep(part1Ptr, localIndex, namePtr); + LocalGetInternalRep(part1Ptr, localIndex, namePtr); if (localIndex >= 0) { if (HasLocalVars(varFramePtr) && !(flags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY)) @@ -639,7 +639,7 @@ TclObjLookupVarEx( * If part1Ptr is a parsedVarNameType, retrieve the pre-parsed parts. */ - ParsedGetIntRep(part1Ptr, parsed, arrayPtr, elem); + ParsedGetInternalRep(part1Ptr, parsed, arrayPtr, elem); if (parsed && arrayPtr) { if (part2Ptr != NULL) { /* @@ -685,7 +685,7 @@ TclObjLookupVarEx( part2Ptr = Tcl_NewStringObj(part2 + 1, len - (part2 - part1) - 2); - ParsedSetIntRep(part1Ptr, arrayPtr, part2Ptr); + ParsedSetInternalRep(part1Ptr, arrayPtr, part2Ptr); part1Ptr = arrayPtr; } @@ -721,16 +721,16 @@ TclObjLookupVarEx( Tcl_Obj *cachedNamePtr = localName(varFramePtr, index); if (part1Ptr == cachedNamePtr) { - LocalSetIntRep(part1Ptr, index, NULL); + LocalSetInternalRep(part1Ptr, index, NULL); } else { /* * [80304238ac] Trickiness here. We will store and incr the * refcount on cachedNamePtr. Trouble is that it's possible - * (see test var-22.1) for cachedNamePtr to have an intrep + * (see test var-22.1) for cachedNamePtr to have an internalrep * that contains a stored and refcounted part1Ptr. This * would be a reference cycle which leads to a memory leak. * - * The solution here is to wipe away all intrep(s) in + * The solution here is to wipe away all internalrep(s) in * cachedNamePtr and leave it as string only. This is * radical and destructive, so a better idea would be welcome. */ @@ -739,24 +739,24 @@ TclObjLookupVarEx( * Firstly set cached local var reference (avoid free before set, * see [45b9faf103f2]) */ - LocalSetIntRep(part1Ptr, index, cachedNamePtr); + LocalSetInternalRep(part1Ptr, index, cachedNamePtr); /* Then wipe it */ - TclFreeIntRep(cachedNamePtr); + TclFreeInternalRep(cachedNamePtr); /* * Now go ahead and convert it the the "localVarName" type, * since we suspect at least some use of the value as a * varname and we want to resolve it quickly. */ - LocalSetIntRep(cachedNamePtr, index, NULL); + LocalSetInternalRep(cachedNamePtr, index, NULL); } } else { /* * At least mark part1Ptr as already parsed. */ - ParsedSetIntRep(part1Ptr, NULL, NULL); + ParsedSetInternalRep(part1Ptr, NULL, NULL); } donePart1: @@ -4115,7 +4115,7 @@ ArraySetCmd( */ arrayElemObj = objv[2]; - if (TclHasIntRep(arrayElemObj, &tclDictType) && arrayElemObj->bytes == NULL) { + if (TclHasInternalRep(arrayElemObj, &tclDictType) && arrayElemObj->bytes == NULL) { Tcl_Obj *keyPtr, *valuePtr; Tcl_DictSearch search; int done; @@ -5788,7 +5788,7 @@ FreeLocalVarName( int index; Tcl_Obj *namePtr; - LocalGetIntRep(objPtr, index, namePtr); + LocalGetInternalRep(objPtr, index, namePtr); index++; /* Compiler warning bait. */ if (namePtr) { @@ -5804,11 +5804,11 @@ DupLocalVarName( int index; Tcl_Obj *namePtr; - LocalGetIntRep(srcPtr, index, namePtr); + LocalGetInternalRep(srcPtr, index, namePtr); if (!namePtr) { namePtr = srcPtr; } - LocalSetIntRep(dupPtr, index, namePtr); + LocalSetInternalRep(dupPtr, index, namePtr); } /* @@ -5827,7 +5827,7 @@ FreeParsedVarName( Tcl_Obj *arrayPtr, *elem; int parsed; - ParsedGetIntRep(objPtr, parsed, arrayPtr, elem); + ParsedGetInternalRep(objPtr, parsed, arrayPtr, elem); parsed++; /* Silence compiler. */ if (arrayPtr != NULL) { @@ -5844,10 +5844,10 @@ DupParsedVarName( Tcl_Obj *arrayPtr, *elem; int parsed; - ParsedGetIntRep(srcPtr, parsed, arrayPtr, elem); + ParsedGetInternalRep(srcPtr, parsed, arrayPtr, elem); parsed++; /* Silence compiler. */ - ParsedSetIntRep(dupPtr, arrayPtr, elem); + ParsedSetInternalRep(dupPtr, arrayPtr, elem); } /* diff --git a/macosx/tclMacOSXFCmd.c b/macosx/tclMacOSXFCmd.c index a70a789..1717c3c 100644 --- a/macosx/tclMacOSXFCmd.c +++ b/macosx/tclMacOSXFCmd.c @@ -577,7 +577,7 @@ GetOSTypeFromObj( { int result = TCL_OK; - if (!TclHasIntRep(objPtr, &tclOSTypeType)) { + if (!TclHasInternalRep(objPtr, &tclOSTypeType)) { result = SetOSTypeFromAny(interp, objPtr); } *osTypePtr = (OSType) objPtr->internalRep.wideValue; @@ -659,7 +659,7 @@ SetOSTypeFromAny( (OSType) bytes[1] << 16 | (OSType) bytes[2] << 8 | (OSType) bytes[3]; - TclFreeIntRep(objPtr); + TclFreeInternalRep(objPtr); objPtr->internalRep.wideValue = (Tcl_WideInt) osType; objPtr->typePtr = &tclOSTypeType; } -- cgit v0.12 From 34e7d9999e042408f6eef02bbd690d43f25b9fde Mon Sep 17 00:00:00 2001 From: griffin Date: Wed, 13 Oct 2021 00:22:20 +0000 Subject: Corrected offset calculations --- generic/tclZipfs.c | 34 ++++++++++++++++++---------------- 1 file changed, 18 insertions(+), 16 deletions(-) diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c index da46acd..4d40da3 100644 --- a/generic/tclZipfs.c +++ b/generic/tclZipfs.c @@ -1187,11 +1187,10 @@ ZipFSFindTOC( int needZip, ZipFile *zf) { - size_t i; + size_t i, minoff; const unsigned char *p, *q; const unsigned char *start = zf->data; const unsigned char *end = zf->data + zf->length; - size_t pass_offset; /* * Scan backwards from the end of the file for the signature. This is @@ -1225,11 +1224,6 @@ ZipFSFindTOC( goto error; } - /* - * Remember passOffset - */ - pass_offset = p - zf->data; - /* * How many files in the archive? If that's bogus, we're done here. */ @@ -1251,6 +1245,8 @@ ZipFSFindTOC( q = zf->data + ZipReadInt(start, end, p + ZIP_CENTRAL_DIRSTART_OFFS); p -= ZipReadInt(start, end, p + ZIP_CENTRAL_DIRSIZE_OFFS); + zf->baseOffset = zf->passOffset = (p>q) ? p - q : 0; + zf->directoryOffset = q - zf->data + zf->baseOffset; if ((p < q) || (p < zf->data) || (p > zf->data + zf->length) || (q < zf->data) || (q > zf->data + zf->length)) { if (!needZip) { @@ -1266,11 +1262,11 @@ ZipFSFindTOC( * Read the central directory. */ - zf->baseOffset = zf->passOffset = p - q; - zf->directoryOffset = p - zf->data; q = p; + minoff = zf->length; for (i = 0; i < zf->numFiles; i++) { int pathlen, comlen, extra; + size_t localhdr_off = zf->length; if (q + ZIP_CENTRAL_HEADER_LEN > end) { ZIPFS_ERROR(interp, "wrong header length"); @@ -1285,16 +1281,27 @@ ZipFSFindTOC( pathlen = ZipReadShort(start, end, q + ZIP_CENTRAL_PATHLEN_OFFS); comlen = ZipReadShort(start, end, q + ZIP_CENTRAL_FCOMMENTLEN_OFFS); extra = ZipReadShort(start, end, q + ZIP_CENTRAL_EXTRALEN_OFFS); + localhdr_off = ZipReadInt(start, end, q + ZIP_CENTRAL_LOCALHDR_OFFS); + if (ZipReadInt(start, end, zf->data + zf->baseOffset + localhdr_off) != ZIP_LOCAL_HEADER_SIG) { + ZIPFS_ERROR(interp, "Failed to find local header"); + ZIPFS_ERROR_CODE(interp, "LCL_HDR"); + goto error; + } + if (localhdr_off < minoff) { + minoff = localhdr_off; + } q += pathlen + comlen + extra + ZIP_CENTRAL_HEADER_LEN; } + zf->passOffset = minoff + zf->baseOffset; + /* * If there's also an encoded password, extract that too (but don't decode * yet). */ - q = zf->data + zf->baseOffset; - if ((zf->baseOffset >= 6) && + q = zf->data + zf->passOffset; + if ((zf->passOffset >= 6) && (start < q-4) && (ZipReadInt(start, end, q - 4) == ZIP_PASSWORD_END_SIG)) { const unsigned char *passPtr; @@ -1307,11 +1314,6 @@ ZipFSFindTOC( } } - /* - * Restore passOffset - */ - zf->passOffset = pass_offset; - return TCL_OK; error: -- cgit v0.12 From be9f231fdaea85177d206ea98320c888b73f00d8 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 13 Oct 2021 13:33:43 +0000 Subject: First shot at [cef426ff2c]: Encoding UTF-32 missing --- generic/tclEncoding.c | 249 +++++++++++++++++++++++++++++++++++++++++++++++--- tests/encoding.test | 24 ++++- 2 files changed, 258 insertions(+), 15 deletions(-) diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 61a931d..4166e45 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -45,7 +45,9 @@ typedef struct { * If nullSize is 1, this is strlen; if * nullSize is 2, this is a function that * returns the number of bytes in a 0x0000 - * terminated string. */ + * terminated string; if nullSize is 4, this + * is a function that returns the number of bytes + * in a 0x00000000 terminated string. */ size_t refCount; /* Number of uses of this structure. */ Tcl_HashEntry *hPtr; /* Hash table entry that owns this encoding. */ } Encoding; @@ -216,7 +218,10 @@ static Tcl_Channel OpenEncodingFileChannel(Tcl_Interp *interp, static Tcl_EncodingFreeProc TableFreeProc; static Tcl_EncodingConvertProc TableFromUtfProc; static Tcl_EncodingConvertProc TableToUtfProc; +static size_t char16len(const char *src); static size_t unilen(const char *src); +static Tcl_EncodingConvertProc Utf32ToUtfProc; +static Tcl_EncodingConvertProc UtfToUtf32Proc; static Tcl_EncodingConvertProc Utf16ToUtfProc; static Tcl_EncodingConvertProc UtfToUtf16Proc; static Tcl_EncodingConvertProc UtfToUcs2Proc; @@ -577,6 +582,20 @@ TclInitEncodingSubsystem(void) type.clientData = INT2PTR(isLe.c); Tcl_CreateEncoding(&type); + type.toUtfProc = Utf32ToUtfProc; + type.fromUtfProc = UtfToUtf32Proc; + type.freeProc = NULL; + type.nullSize = 4; + type.encodingName = "utf-32le"; + type.clientData = INT2PTR(TCL_ENCODING_LE); + Tcl_CreateEncoding(&type); + type.encodingName = "utf-32be"; + type.clientData = INT2PTR(0); + Tcl_CreateEncoding(&type); + type.encodingName = "utf-32"; + type.clientData = INT2PTR(isLe.c); + Tcl_CreateEncoding(&type); + type.toUtfProc = Utf16ToUtfProc; type.fromUtfProc = UtfToUtf16Proc; type.freeProc = NULL; @@ -1057,10 +1076,12 @@ Tcl_CreateEncoding( encodingPtr->freeProc = typePtr->freeProc; encodingPtr->nullSize = typePtr->nullSize; encodingPtr->clientData = typePtr->clientData; - if (typePtr->nullSize == 1) { - encodingPtr->lengthProc = (LengthProc *) strlen; - } else { + if (typePtr->nullSize == 2) { + encodingPtr->lengthProc = (LengthProc *) char16len; + } else if (typePtr->nullSize == 4) { encodingPtr->lengthProc = (LengthProc *) unilen; + } else { + encodingPtr->lengthProc = (LengthProc *) strlen; } encodingPtr->refCount = 1; encodingPtr->hPtr = NULL; @@ -1343,10 +1364,10 @@ Tcl_UtfToExternalDString( src += srcRead; if (result != TCL_CONVERT_NOSPACE) { - if (encodingPtr->nullSize == 2) { - Tcl_DStringSetLength(dstPtr, soFar + 1); + int i = soFar + encodingPtr->nullSize - 1; + while (i >= soFar) { + Tcl_DStringSetLength(dstPtr, i--); } - Tcl_DStringSetLength(dstPtr, soFar); return Tcl_DStringValue(dstPtr); } @@ -1441,10 +1462,7 @@ Tcl_UtfToExternal( result = encodingPtr->fromUtfProc(encodingPtr->clientData, src, srcLen, flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr, dstCharsPtr); - if (encodingPtr->nullSize == 2) { - dst[*dstWrotePtr + 1] = '\0'; - } - dst[*dstWrotePtr] = '\0'; + memset(&dst[*dstWrotePtr], '\0', encodingPtr->nullSize); return result; } @@ -2335,6 +2353,198 @@ UtfToUtfProc( *dstCharsPtr = numChars; return result; } + +/* + *------------------------------------------------------------------------- + * + * Utf32ToUtfProc -- + * + * Convert from UTF-32 to UTF-8. + * + * Results: + * Returns TCL_OK if conversion was successful. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static int +Utf32ToUtfProc( + ClientData clientData, /* additional flags, e.g. TCL_ENCODING_LE */ + const char *src, /* Source string in Unicode. */ + int srcLen, /* Source string length in bytes. */ + int flags, /* Conversion control flags. */ + TCL_UNUSED(Tcl_EncodingState *), + char *dst, /* Output buffer in which converted string is + * stored. */ + int dstLen, /* The maximum length of output buffer in + * bytes. */ + int *srcReadPtr, /* Filled with the number of bytes from the + * source string that were converted. This may + * be less than the original source length if + * there was a problem converting some source + * characters. */ + int *dstWrotePtr, /* Filled with the number of bytes that were + * stored in the output buffer as a result of + * the conversion. */ + int *dstCharsPtr) /* Filled with the number of characters that + * correspond to the bytes stored in the + * output buffer. */ +{ + const char *srcStart, *srcEnd; + const char *dstEnd, *dstStart; + int result, numChars, charLimit = INT_MAX; + unsigned short ch; + + flags |= PTR2INT(clientData); + if (flags & TCL_ENCODING_CHAR_LIMIT) { + charLimit = *dstCharsPtr; + } + result = TCL_OK; + + /* + * Check alignment with utf-32 (4 == sizeof(UTF-32)) + */ + + if ((srcLen % 4) != 0) { + result = TCL_CONVERT_MULTIBYTE; + srcLen &= -4; + } + + srcStart = src; + srcEnd = src + srcLen; + + dstStart = dst; + dstEnd = dst + dstLen - TCL_UTF_MAX; + + for (numChars = 0; src < srcEnd && numChars <= charLimit; numChars++) { + if (dst > dstEnd) { + result = TCL_CONVERT_NOSPACE; + break; + } + + if (flags & TCL_ENCODING_LE) { + ch = (src[3] & 0xFF) << 24 | (src[2] & 0xFF) << 16 | (src[1] & 0xFF) << 8 | (src[0] & 0xFF); + } else { + ch = (src[0] & 0xFF) << 24 | (src[1] & 0xFF) << 16 | (src[2] & 0xFF) << 8 | (src[3] & 0xFF); + } + + /* + * Special case for 1-byte utf chars for speed. Make sure we work with + * unsigned short-size data. + */ + + if (ch && ch < 0x80) { + *dst++ = (ch & 0xFF); + } else { + dst += Tcl_UniCharToUtf(ch, dst); + } + src += sizeof(unsigned int); + } + + *srcReadPtr = src - srcStart; + *dstWrotePtr = dst - dstStart; + *dstCharsPtr = numChars; + return result; +} + +/* + *------------------------------------------------------------------------- + * + * UtfToUtf32Proc -- + * + * Convert from UTF-8 to UTF-32. + * + * Results: + * Returns TCL_OK if conversion was successful. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static int +UtfToUtf32Proc( + ClientData clientData, /* additional flags, e.g. TCL_ENCODING_LE */ + const char *src, /* Source string in UTF-8. */ + int srcLen, /* Source string length in bytes. */ + int flags, /* Conversion control flags. */ + TCL_UNUSED(Tcl_EncodingState *), + char *dst, /* Output buffer in which converted string is + * stored. */ + int dstLen, /* The maximum length of output buffer in + * bytes. */ + int *srcReadPtr, /* Filled with the number of bytes from the + * source string that were converted. This may + * be less than the original source length if + * there was a problem converting some source + * characters. */ + int *dstWrotePtr, /* Filled with the number of bytes that were + * stored in the output buffer as a result of + * the conversion. */ + int *dstCharsPtr) /* Filled with the number of characters that + * correspond to the bytes stored in the + * output buffer. */ +{ + const char *srcStart, *srcEnd, *srcClose, *dstStart, *dstEnd; + int result, numChars; + int ch, len; + + srcStart = src; + srcEnd = src + srcLen; + srcClose = srcEnd; + if ((flags & TCL_ENCODING_END) == 0) { + srcClose -= TCL_UTF_MAX; + } + + dstStart = dst; + dstEnd = dst + dstLen - sizeof(Tcl_UniChar); + flags |= PTR2INT(clientData); + + result = TCL_OK; + for (numChars = 0; src < srcEnd; numChars++) { + if ((src > srcClose) && (!Tcl_UtfCharComplete(src, srcEnd - src))) { + /* + * If there is more string to follow, this will ensure that the + * last UTF-8 character in the source buffer hasn't been cut off. + */ + + result = TCL_CONVERT_MULTIBYTE; + break; + } + if (dst > dstEnd) { + result = TCL_CONVERT_NOSPACE; + break; + } + len = TclUtfToUCS4(src, &ch); + if (!Tcl_UniCharIsUnicode(ch)) { + if (flags & TCL_ENCODING_STOPONERROR) { + result = TCL_CONVERT_UNKNOWN; + break; + } + ch = 0xFFFD; + } + src += len; + if (flags & TCL_ENCODING_LE) { + *dst++ = (ch & 0xFF); + *dst++ = ((ch >> 8) & 0xff); + *dst++ = ((ch >> 16) & 0xff); + *dst++ = ((ch >> 24) & 0xff); + } else { + *dst++ = ((ch >> 24) & 0xff); + *dst++ = ((ch >> 16) & 0xff); + *dst++ = ((ch >> 8) & 0xff); + *dst++ = (ch & 0xFF); + } + } + *srcReadPtr = src - srcStart; + *dstWrotePtr = dst - dstStart; + *dstCharsPtr = numChars; + return result; +} /* *------------------------------------------------------------------------- @@ -3628,7 +3838,7 @@ GetTableEncoding( /* *--------------------------------------------------------------------------- * - * unilen -- + * unilen/char16len -- * * A helper function for the Tcl_ExternalToUtf functions. This function * is similar to strlen for double-byte characters: it returns the number @@ -3644,7 +3854,7 @@ GetTableEncoding( */ static size_t -unilen( +char16len( const char *src) { unsigned short *p; @@ -3655,6 +3865,19 @@ unilen( } return (char *) p - src; } + +static size_t +unilen( + const char *src) +{ + unsigned int *p; + + p = (unsigned int *) src; + while (*p != 0x0000) { + p++; + } + return (char *) p - src; +} /* *------------------------------------------------------------------------- diff --git a/tests/encoding.test b/tests/encoding.test index 25d0827..c6f4e02 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -287,6 +287,12 @@ test encoding-11.8 {encoding: extended Unicode UTF-16} { test encoding-11.9 {encoding: extended Unicode UTF-16} { viewable [encoding convertto utf-16be 😹] } {Ø=Þ9 (\u00D8=\u00DE9)} +test encoding-11.10 {encoding: extended Unicode UTF-32} { + viewable [encoding convertto utf-32le 😹] +} "9\xF6\x01\x00 (9\\u00F6\\u0001\\u0000)" +test encoding-11.11 {encoding: extended Unicode UTF-32} { + viewable [encoding convertto utf-32be 😹] +} "\x00\x01\xF69 (\\u0000\\u0001\\u00F69)" # OpenEncodingFile is fully tested by the rest of the tests in this file. test encoding-12.1 {LoadTableEncoding: normal encoding} { @@ -461,10 +467,18 @@ test encoding-16.4 {Ucs2ToUtfProc} -body { set val [encoding convertfrom ucs-2 NN] list $val [format %x [scan $val %c]] } -result "乎 4e4e" -test encoding-16.4 {Ucs2ToUtfProc} -body { +test encoding-16.5 {Ucs2ToUtfProc} -body { set val [encoding convertfrom ucs-2 "\xD8\xD8\xDC\xDC"] list $val [format %x [scan $val %c]] } -result "\U460DC 460dc" +test encoding-16.6 {Utf32ToUtfProc} -body { + set val [encoding convertfrom utf-32le NN\0\0] + list $val [format %x [scan $val %c]] +} -result "乎 4e4e" +test encoding-16.7 {Utf32ToUtfProc} -body { + set val [encoding convertfrom utf-32be \0\0NN] + list $val [format %x [scan $val %c]] +} -result "乎 4e4e" test encoding-17.1 {UtfToUtf16Proc} -body { encoding convertto utf-16 "\U460DC" @@ -478,6 +492,12 @@ test encoding-17.3 {UtfToUtf16Proc} -body { test encoding-17.4 {UtfToUtf16Proc} -body { encoding convertto utf-16le "\uD8D8" } -result "\xFD\xFF" +test encoding-17.5 {UtfToUtf16Proc} -body { + encoding convertto utf-32le "\U460DC" +} -result "\xDC\x60\x04\x00" +test encoding-17.6 {UtfToUtf16Proc} -body { + encoding convertto utf-32be "\U460DC" +} -result "\x00\x04\x60\xDC" test encoding-18.1 {TableToUtfProc} { } {} @@ -777,7 +797,7 @@ test encoding-28.0 {all encodings load} -body { llength $name } return $count -} -result [expr {[info exists ::tcl_precision] ? 89 : 88}] +} -result [expr {[info exists ::tcl_precision] ? 92 : 91}] runtests -- cgit v0.12 From 82df0e7cc9a71bbd7eb06fe4bd1ee9e979b40a13 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 13 Oct 2021 13:51:26 +0000 Subject: Oops --- generic/tclEncoding.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 4166e45..5549874 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -2396,7 +2396,7 @@ Utf32ToUtfProc( const char *srcStart, *srcEnd; const char *dstEnd, *dstStart; int result, numChars, charLimit = INT_MAX; - unsigned short ch; + int ch; flags |= PTR2INT(clientData); if (flags & TCL_ENCODING_CHAR_LIMIT) { @@ -2436,7 +2436,7 @@ Utf32ToUtfProc( * unsigned short-size data. */ - if (ch && ch < 0x80) { + if ((ch > 0) && (ch < 0x80)) { *dst++ = (ch & 0xFF); } else { dst += Tcl_UniCharToUtf(ch, dst); -- cgit v0.12 From 2812109f17b5854a23b1f0b63d0fd99b1f56965a Mon Sep 17 00:00:00 2001 From: griffin Date: Wed, 13 Oct 2021 16:34:46 +0000 Subject: Remove unnecessary change --- generic/tclZipfs.c | 16 ---------------- 1 file changed, 16 deletions(-) diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c index 4d40da3..ae4c8c4 100644 --- a/generic/tclZipfs.c +++ b/generic/tclZipfs.c @@ -3122,22 +3122,6 @@ ZipFSMkZipOrImg( * Copy everything up to the ZIP-related suffix. */ - if (zf->passOffset == 0) { - /* - * Hmm, this mounted archive is local (in this image), but - * zf->passOffset does not have a valid value. Let's open - * this image and find the passOffset so as to copy the image - * correctly. - */ - - ZipFile zflocal; - memset(&zflocal, 0, sizeof(ZipFile)); - if (ZipFSOpenArchive(interp, imgName, 0, &zflocal) == TCL_OK) { - zf->passOffset = zflocal.passOffset; - ZipFSCloseArchive(interp, &zflocal); - } - } - if ((size_t) Tcl_Write(out, (char *) zf->data, zf->passOffset) != zf->passOffset) { memset(passBuf, 0, sizeof(passBuf)); -- cgit v0.12 From 7e82249b7fbe90827c600cfd7fd3977ba18a54e2 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 14 Oct 2021 14:32:39 +0000 Subject: Code/Comment cleanup --- generic/tclEncoding.c | 43 ++++++++++++++++++++++--------------------- 1 file changed, 22 insertions(+), 21 deletions(-) diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 5549874..fad9faa 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -37,7 +37,7 @@ typedef struct { * end-of-string in this encoding. This number * is used to determine the source string * length when the srcLen argument is - * negative. This number can be 1 or 2. */ + * negative. This number can be 1, 2, or 4. */ ClientData clientData; /* Arbitrary value associated with encoding * type. Passed to conversion functions. */ LengthProc *lengthProc; /* Function to compute length of @@ -46,8 +46,8 @@ typedef struct { * nullSize is 2, this is a function that * returns the number of bytes in a 0x0000 * terminated string; if nullSize is 4, this - * is a function that returns the number of bytes - * in a 0x00000000 terminated string. */ + * is a function that returns the number of + * bytes in a 0x00000000 terminated string. */ size_t refCount; /* Number of uses of this structure. */ Tcl_HashEntry *hPtr; /* Hash table entry that owns this encoding. */ } Encoding; @@ -218,8 +218,8 @@ static Tcl_Channel OpenEncodingFileChannel(Tcl_Interp *interp, static Tcl_EncodingFreeProc TableFreeProc; static Tcl_EncodingConvertProc TableFromUtfProc; static Tcl_EncodingConvertProc TableToUtfProc; -static size_t char16len(const char *src); -static size_t unilen(const char *src); +static size_t unilen(const char *src); +static size_t unilen4(const char *src); static Tcl_EncodingConvertProc Utf32ToUtfProc; static Tcl_EncodingConvertProc UtfToUtf32Proc; static Tcl_EncodingConvertProc Utf16ToUtfProc; @@ -1077,9 +1077,9 @@ Tcl_CreateEncoding( encodingPtr->nullSize = typePtr->nullSize; encodingPtr->clientData = typePtr->clientData; if (typePtr->nullSize == 2) { - encodingPtr->lengthProc = (LengthProc *) char16len; - } else if (typePtr->nullSize == 4) { encodingPtr->lengthProc = (LengthProc *) unilen; + } else if (typePtr->nullSize == 4) { + encodingPtr->lengthProc = (LengthProc *) unilen4; } else { encodingPtr->lengthProc = (LengthProc *) strlen; } @@ -1364,7 +1364,7 @@ Tcl_UtfToExternalDString( src += srcRead; if (result != TCL_CONVERT_NOSPACE) { - int i = soFar + encodingPtr->nullSize - 1; + int i = soFar + encodingPtr->nullSize - 1; while (i >= soFar) { Tcl_DStringSetLength(dstPtr, i--); } @@ -2501,7 +2501,7 @@ UtfToUtf32Proc( } dstStart = dst; - dstEnd = dst + dstLen - sizeof(Tcl_UniChar); + dstEnd = dst + dstLen - sizeof(Tcl_UniChar); flags |= PTR2INT(clientData); result = TCL_OK; @@ -2540,6 +2540,7 @@ UtfToUtf32Proc( *dst++ = (ch & 0xFF); } } + *srcReadPtr = src - srcStart; *dstWrotePtr = dst - dstStart; *dstCharsPtr = numChars; @@ -2861,7 +2862,7 @@ UtfToUcs2Proc( *dstCharsPtr = numChars; return result; } - + /* *------------------------------------------------------------------------- * @@ -3303,7 +3304,7 @@ TableFreeProc( ClientData clientData) /* TableEncodingData that specifies * encoding. */ { - TableEncodingData *dataPtr = (TableEncodingData *) clientData; + TableEncodingData *dataPtr = (TableEncodingData *)clientData; /* * Make sure we aren't freeing twice on shutdown. [Bug 219314] @@ -3361,7 +3362,7 @@ EscapeToUtfProc( * correspond to the bytes stored in the * output buffer. */ { - EscapeEncodingData *dataPtr = (EscapeEncodingData *) clientData; + EscapeEncodingData *dataPtr = (EscapeEncodingData *)clientData; const char *prefixBytes, *tablePrefixBytes, *srcStart, *srcEnd; const unsigned short *const *tableToUnicode; const Encoding *encodingPtr; @@ -3838,7 +3839,7 @@ GetTableEncoding( /* *--------------------------------------------------------------------------- * - * unilen/char16len -- + * unilen, unilen4 -- * * A helper function for the Tcl_ExternalToUtf functions. This function * is similar to strlen for double-byte characters: it returns the number @@ -3854,7 +3855,7 @@ GetTableEncoding( */ static size_t -char16len( +unilen( const char *src) { unsigned short *p; @@ -3867,13 +3868,13 @@ char16len( } static size_t -unilen( +unilen4( const char *src) { unsigned int *p; p = (unsigned int *) src; - while (*p != 0x0000) { + while (*p != 0x00000000) { p++; } return (char *) p - src; @@ -3909,7 +3910,7 @@ InitializeEncodingSearchPath( Tcl_Encoding *encodingPtr) { const char *bytes; - int i, numDirs; + int i, numDirs, numBytes; Tcl_Obj *libPathObj, *encodingObj, *searchPathObj; TclNewLiteralStringObj(encodingObj, "encoding"); @@ -3939,11 +3940,11 @@ InitializeEncodingSearchPath( if (*encodingPtr) { ((Encoding *)(*encodingPtr))->refCount++; } - bytes = TclGetString(searchPathObj); + bytes = Tcl_GetStringFromObj(searchPathObj, &numBytes); - *lengthPtr = searchPathObj->length; - *valuePtr = (char *)ckalloc(*lengthPtr + 1); - memcpy(*valuePtr, bytes, *lengthPtr + 1); + *lengthPtr = numBytes; + *valuePtr = (char *)ckalloc(numBytes + 1); + memcpy(*valuePtr, bytes, numBytes + 1); Tcl_DecrRefCount(searchPathObj); } -- 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 43d72b8d8e0d029c39b3c9abbb84f196aed496f5 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 18 Oct 2021 09:43:03 +0000 Subject: separate "testConstraint nodep" in tcltests.tcl --- tests/info.test | 2 +- tests/regexp.test | 3 +-- tests/regexpComp.test | 2 +- tests/string.test | 2 +- tests/stringObj.test | 2 +- tests/tcltests.tcl | 1 + 6 files changed, 6 insertions(+), 6 deletions(-) diff --git a/tests/info.test b/tests/info.test index ced4435..46f85e7 100644 --- a/tests/info.test +++ b/tests/info.test @@ -20,9 +20,9 @@ if {{::tcltest} ni [namespace children]} { namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands +package require tcltests 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..a44f2e3 100644 --- a/tests/regexp.test +++ b/tests/regexp.test @@ -17,9 +17,8 @@ if {"::tcltest" ni [namespace children]} { } unset -nocomplain foo - +package require tcltests 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..e78c0df 100644 --- a/tests/regexpComp.test +++ b/tests/regexpComp.test @@ -16,7 +16,7 @@ if {"::tcltest" ni [namespace children]} { namespace import -force ::tcltest::* } -testConstraint nodep [info exists tcl_precision] +package require tcltests # Procedure to evaluate a script within a proc, to test compilation # functionality diff --git a/tests/string.test b/tests/string.test index 822899c..6750a5c 100644 --- a/tests/string.test +++ b/tests/string.test @@ -19,6 +19,7 @@ if {"::tcltest" ni [namespace children]} { ::tcltest::loadTestedCommands catch [list package require -exact tcl::test [info patchlevel]] +package require tcltests # Helper commands to test various optimizations, code paths, and special cases. proc makeByteArray {s} {binary format a* $s} @@ -33,7 +34,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..4402185 100644 --- a/tests/stringObj.test +++ b/tests/stringObj.test @@ -19,12 +19,12 @@ if {"::tcltest" ni [namespace children]} { ::tcltest::loadTestedCommands catch [list package require -exact tcl::test [info patchlevel]] +package require tcltests 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 1ee37d3..f7407b4 100644 --- a/tests/tcltests.tcl +++ b/tests/tcltests.tcl @@ -15,6 +15,7 @@ if {[namespace which testdebug] ne {}} { [testConstraint purify] }] } +testConstraint nodep [info exists tcl_precision] testConstraint fcopy [llength [info commands fcopy]] testConstraint fileevent [llength [info commands fileevent]] testConstraint thread [ -- cgit v0.12 From 7f8b256581b9fa5564137271b2f24df3ccd5b9fa Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 20 Oct 2021 20:27:45 +0000 Subject: Code cleanup (comments, bracing) --- generic/tclEncoding.c | 30 +++++++++++++----------------- 1 file changed, 13 insertions(+), 17 deletions(-) diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index fad9faa..6fe81e8 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -517,7 +517,7 @@ FillEncodingFileMap(void) /* Those flags must not conflict with other TCL_ENCODING_* flags in tcl.h */ /* Since TCL_ENCODING_MODIFIED is only used for utf-8/cesu-8 and - * TCL_ENCODING_LE is only used for utf-16/ucs-2. re-use the same value */ + * TCL_ENCODING_LE is only used for utf-16/utf-32/ucs-2. re-use the same value */ #define TCL_ENCODING_MODIFIED 0x20 /* Converting NULL bytes to 0xC0 0x80 */ #define TCL_ENCODING_LE TCL_ENCODING_MODIFIED /* Little-endian encoding */ #define TCL_ENCODING_UTF 0x200 /* For UTF-8 encoding, allow 4-byte output sequences */ @@ -2253,15 +2253,15 @@ UtfToUtfProc( result = TCL_CONVERT_NOSPACE; break; } - if (UCHAR(*src) < 0x80 && !(UCHAR(*src) == 0 && (flags & TCL_ENCODING_MODIFIED))) { + if (UCHAR(*src) < 0x80 && !((UCHAR(*src) == 0) && (flags & TCL_ENCODING_MODIFIED))) { /* * Copy 7bit characters, but skip null-bytes when we are in input * mode, so that they get converted to 0xC080. */ *dst++ = *src++; - } else if (UCHAR(*src) == 0xC0 && (src + 1 < srcEnd) - && UCHAR(src[1]) == 0x80 && !(flags & TCL_ENCODING_MODIFIED)) { + } else if ((UCHAR(*src) == 0xC0) && (src + 1 < srcEnd) + && (UCHAR(src[1]) == 0x80) && !(flags & TCL_ENCODING_MODIFIED)) { /* * Convert 0xC080 to real nulls when we are in output mode. */ @@ -2353,7 +2353,7 @@ UtfToUtfProc( *dstCharsPtr = numChars; return result; } - + /* *------------------------------------------------------------------------- * @@ -2449,7 +2449,7 @@ Utf32ToUtfProc( *dstCharsPtr = numChars; return result; } - + /* *------------------------------------------------------------------------- * @@ -2530,13 +2530,13 @@ UtfToUtf32Proc( src += len; if (flags & TCL_ENCODING_LE) { *dst++ = (ch & 0xFF); - *dst++ = ((ch >> 8) & 0xff); - *dst++ = ((ch >> 16) & 0xff); - *dst++ = ((ch >> 24) & 0xff); + *dst++ = ((ch >> 8) & 0xFF); + *dst++ = ((ch >> 16) & 0xFF); + *dst++ = ((ch >> 24) & 0xFF); } else { - *dst++ = ((ch >> 24) & 0xff); - *dst++ = ((ch >> 16) & 0xff); - *dst++ = ((ch >> 8) & 0xff); + *dst++ = ((ch >> 24) & 0xFF); + *dst++ = ((ch >> 16) & 0xFF); + *dst++ = ((ch >> 8) & 0xFF); *dst++ = (ch & 0xFF); } } @@ -3048,11 +3048,7 @@ TableFromUtfProc( len = TclUtfToUniChar(src, &ch); #if TCL_UTF_MAX > 3 - /* - * This prevents a crash condition. More evaluation is required for - * full support of int Tcl_UniChar. [Bug 1004065] - */ - + /* Unicode chars > +U0FFFF cannot be represented in any table encoding */ if (ch & 0xFFFF0000) { word = 0; } else -- cgit v0.12 From 13223fbc3fca082c74336bb13dfb03e115d9f1cd Mon Sep 17 00:00:00 2001 From: griffin Date: Sun, 24 Oct 2021 18:19:16 +0000 Subject: These record locations are not relative offsets, but rather absolute locations. --- generic/tclZipfs.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c index ae4c8c4..f649588 100644 --- a/generic/tclZipfs.c +++ b/generic/tclZipfs.c @@ -3428,7 +3428,7 @@ SerializeCentralDirectoryEntry( ZipWriteShort(start, end, buf + ZIP_CENTRAL_IATTR_OFFS, 0); ZipWriteInt(start, end, buf + ZIP_CENTRAL_EATTR_OFFS, 0); ZipWriteInt(start, end, buf + ZIP_CENTRAL_LOCALHDR_OFFS, - z->offset - dataStartOffset); + z->offset); } static void @@ -3455,7 +3455,7 @@ SerializeCentralDirectorySuffix( ZipWriteInt(start, end, buf + ZIP_CENTRAL_DIRSIZE_OFFS, suffixStartOffset - directoryStartOffset); ZipWriteInt(start, end, buf + ZIP_CENTRAL_DIRSTART_OFFS, - directoryStartOffset - dataStartOffset); + directoryStartOffset); ZipWriteShort(start, end, buf + ZIP_CENTRAL_COMMENTLEN_OFFS, 0); } -- cgit v0.12 From e58d1a560fc2306653db113bdbc00944f1d493a8 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 25 Oct 2021 15:34:06 +0000 Subject: Revise outdated comments. --- generic/tclBinary.c | 107 +++++++++++++++++++++------------------------------- 1 file changed, 43 insertions(+), 64 deletions(-) diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 6a32250..a133ed1 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -2,7 +2,7 @@ * tclBinary.c -- * * This file contains the implementation of the "binary" Tcl built-in - * command and the Tcl binary data object. + * command and the Tcl value internal representation for binary data. * * Copyright © 1997 Sun Microsystems, Inc. * Copyright © 1998-1999 Scriptics Corporation. @@ -165,12 +165,11 @@ static const EnsembleImplMap decodeMap[] = { * images to name just two. * * It's strange to have two Tcl_ObjTypes in place for this task when one would - * do, so a bit of detail and history how we got to this point and where we - * might go from here. + * do, so a bit of detail and history will aid understanding. * * A bytearray is an ordered sequence of bytes. Each byte is an integer value * in the range [0-255]. To be a Tcl value type, we need a way to encode each - * value in the value set as a Tcl string. The simplest encoding is to + * value in the value set as a Tcl string. A simple encoding is to * represent each byte value as the same codepoint value. A bytearray of N * bytes is encoded into a Tcl string of N characters where the codepoint of * each character is the value of corresponding byte. This approach creates a @@ -181,9 +180,7 @@ static const EnsembleImplMap decodeMap[] = { * question arises what to do with strings outside that subset? That is, * those Tcl strings containing at least one codepoint greater than 255? The * obviously correct answer is to raise an error! That string value does not - * represent any valid bytearray value. Full Stop. The setFromAnyProc - * signature has a completion code return value for just this reason, to - * reject invalid inputs. + * represent any valid bytearray value. * * Unfortunately this was not the path taken by the authors of the original * tclByteArrayType. They chose to accept all Tcl string values as acceptable @@ -191,33 +188,10 @@ static const EnsembleImplMap decodeMap[] = { * high bits of any codepoint value at all. This meant that every bytearray * value had multiple accepted string representations. * - * The implications of this choice are truly ugly. When a Tcl value has a - * string representation, we are required to accept that as the true value. - * Bytearray values that possess a string representation cannot be processed - * as bytearrays because we cannot know which true value that bytearray - * represents. The consequence is that we drag around an internal rep that we - * cannot make any use of. This painful price is extracted at any point after - * a string rep happens to be generated for the value. This happens even when - * the troublesome codepoints outside the byte range never show up. This - * happens rather routinely in normal Tcl operations unless we burden the - * script writer with the cognitive burden of avoiding it. The price is also - * paid by callers of the C interface. The routine - * - * unsigned char *Tcl_GetByteArrayFromObj(objPtr, lenPtr) - * - * has a guarantee to always return a non-NULL value, but that value points to - * a byte sequence that cannot be used by the caller to process the Tcl value - * absent some sideband testing that objPtr is "pure". Tcl offers no public - * interface to perform this test, so callers either break encapsulation or - * are unavoidably buggy. Tcl has defined a public interface that cannot be - * used correctly. The Tcl source code itself suffers the same problem, and - * has been buggy, but progressively less so as more and more portions of the - * code have been retrofitted with the required "purity testing". The set of - * values able to pass the purity test can be increased via the introduction - * of a "canonical" flag marker, but the only way the broken interface itself - * can be discarded is to start over and define the Tcl_ObjType properly. - * Bytearrays should simply be usable as bytearrays without a kabuki dance of - * testing. + * The implications of this choice are truly ugly, and motivated the proposal + * of TIP 568 to migrate away from it and to the more sensible design where + * each bytearray value has only one string representation. Full details are + * recorded in that TIP for those who seek them. * * The Tcl_ObjType "properByteArrayType" is (nearly) a correct implementation * of bytearrays. Any Tcl value with the type properByteArrayType can have @@ -226,21 +200,24 @@ static const EnsembleImplMap decodeMap[] = { * implies a side testing burden -- past mistakes will not let us avoid that * immediately, but it is at least a conventional test of type, and can be * implemented entirely by examining the objPtr fields, with no need to query - * the internalrep, as a canonical flag would require. - * - * Until Tcl_GetByteArrayFromObj() and Tcl_SetByteArrayLength() can be revised - * to admit the possibility of returning NULL when the true value is not a - * valid bytearray, we need a mechanism to retain compatibility with the - * deployed callers of the broken interface. That's what the retained - * "tclByteArrayType" provides. In those unusual circumstances where we - * convert an invalid bytearray value to a bytearray type, it is to this - * legacy type. Essentially any time this legacy type gets used, it's a - * signal of a bug being ignored. A TIP should be drafted to remove this - * connection to the broken past so that Tcl 9 will no longer have any trace - * of it. Prescribing a migration path will be the key element of that work. - * The internal changes now in place are the limit of what can be done short - * of interface repair. They provide a great expansion of the histories over - * which bytearray values can be useful in the meanwhile. + * the internalrep, as a canonical flag would require. This benefit is made + * available to extensions through the public routine Tcl_GetBytesFromObj(), + * first available in Tcl 8.7. + * + * The public routines Tcl_GetByteArrayFromObj() and Tcl_SetByteArrayLength() + * must continue to follow their documented behavior through the 8.* series of + * releases. To support that legacy operation, we need a mechanism to retain + * compatibility with the deployed callers of the broken interface. That's + * what the retained "tclByteArrayType" provides. In those unusual + * circumstances where we convert an invalid bytearray value to a bytearray + * type, it is to this legacy type. Essentially any time this legacy type + * shows up, it's a signal of a bug being ignored. + * + * In Tcl 9, the incompatibility in the behavior of these public routines + * has been approved, and the legacy internal rep is no longer retained. + * The internal changes seen below are the limit of what can be done + * in a Tcl 8.* release. They provide a great expansion of the histories + * over which bytearray values can be useful. */ static const Tcl_ObjType properByteArrayType = { @@ -267,15 +244,16 @@ const Tcl_ObjType tclByteArrayType = { */ typedef struct ByteArray { - unsigned int bad; /* Index of the character that is a nonbyte. - * If all characters are bytes, bad = used, - * though then we should never read it. */ + unsigned int bad; /* Index of first character that is a nonbyte. + * If all characters are bytes, bad = used. */ unsigned int used; /* The number of bytes used in the byte - * array. */ - unsigned int allocated; /* The amount of space actually allocated - * minus 1 byte. */ - unsigned char bytes[TCLFLEXARRAY]; /* The array of bytes. The actual size of this - * field depends on the 'allocated' field + * array. Must be <= allocated. The bytes + * used to store the value are indexed from + * 0 to used-1. */ + unsigned int allocated; /* The number of bytes of space allocated. */ + unsigned char bytes[TCLFLEXARRAY]; + /* The array of bytes. The actual size of this + * field is stored in the 'allocated' field * above. */ } ByteArray; @@ -301,7 +279,7 @@ TclIsPureByteArray( * from the given array of bytes. * * Results: - * The newly create object is returned. This object will have no initial + * The newly created object is returned. This object has no initial * string representation. The returned object has a ref count of 0. * * Side effects: @@ -346,7 +324,7 @@ Tcl_NewByteArrayObj( * result of calling Tcl_NewByteArrayObj. * * Results: - * The newly create object is returned. This object will have no initial + * The newly created object is returned. This object has no initial * string representation. The returned object has a ref count of 0. * * Side effects: @@ -444,11 +422,11 @@ Tcl_SetByteArrayObj( * * Attempt to extract the value from objPtr in the representation * of a byte sequence. On success return the extracted byte sequence. - * On failures, return NULL and record error message and code in + * On failure, return NULL and record error message and code in * interp (if not NULL). * * Results: - * Pointer to array of bytes, or NULL. representing the ByteArray object. + * NULL or pointer to array of bytes representing the ByteArray object. * Writes number of bytes in array to *lengthPtr. * *---------------------------------------------------------------------- @@ -459,7 +437,7 @@ TclGetBytesFromObj( Tcl_Interp *interp, /* For error reporting */ Tcl_Obj *objPtr, /* Value to extract from */ int *lengthPtr) /* If non-NULL, filled with length of the - * array of bytes in the ByteArray object. */ + * returned array of bytes. */ { ByteArray *baPtr; const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objPtr, &properByteArrayType); @@ -599,6 +577,7 @@ TclGetByteArrayFromObj( #if TCL_MAJOR_VERSION > 8 *lengthPtr = baPtr->used; #else + /* TODO: What's going on here? Document or eliminate. */ *lengthPtr = ((size_t)(unsigned)(baPtr->used + 1)) - 1; #endif } @@ -2162,7 +2141,7 @@ CopyNumber( * * FormatNumber -- * - * This routine is called by Tcl_BinaryObjCmd to format a number into a + * This routine is called by BinaryFormatCmd to format a number into a * location pointed at by cursor. * * Results: @@ -2331,7 +2310,7 @@ FormatNumber( * * ScanNumber -- * - * This routine is called by Tcl_BinaryObjCmd to scan a number out of a + * This routine is called by BinaryScanCmd to scan a number out of a * buffer. * * Results: -- cgit v0.12 From 88129d2c87709cf17bab1c40ed7e01df9f99cd55 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 2 Nov 2021 16:40:29 +0000 Subject: Revise the interface routines for byte arrays to use "numBytes" rather than "length" as argument names. --- doc/ByteArrObj.3 | 51 +++++++++++++++-------------- generic/tcl.decls | 16 ++++----- generic/tclBinary.c | 94 ++++++++++++++++++++++++++++------------------------- generic/tclDecls.h | 32 +++++++++--------- 4 files changed, 99 insertions(+), 94 deletions(-) diff --git a/doc/ByteArrObj.3 b/doc/ByteArrObj.3 index a8b70eb..0703164 100644 --- a/doc/ByteArrObj.3 +++ b/doc/ByteArrObj.3 @@ -8,44 +8,44 @@ .so man.macros .BS .SH NAME -Tcl_NewByteArrayObj, Tcl_SetByteArrayObj, Tcl_GetByteArrayFromObj, Tcl_GetBytesFromObj, Tcl_SetByteArrayLength \- manipulate Tcl values as a arrays of bytes +Tcl_NewByteArrayObj, Tcl_SetByteArrayObj, Tcl_GetBytesFromObj, Tcl_GetByteArrayFromObj, Tcl_SetByteArrayLength \- manipulate a Tcl value as an array of bytes .SH SYNOPSIS .nf \fB#include \fR .sp Tcl_Obj * -\fBTcl_NewByteArrayObj\fR(\fIbytes, length\fR) +\fBTcl_NewByteArrayObj\fR(\fIbytes, numBytes\fR) .sp void -\fBTcl_SetByteArrayObj\fR(\fIobjPtr, bytes, length\fR) +\fBTcl_SetByteArrayObj\fR(\fIobjPtr, bytes, numBytes\fR) .sp .VS TIP568 unsigned char * -\fBTcl_GetBytesFromObj\fR(\fIinterp, objPtr, lengthPtr\fR) +\fBTcl_GetBytesFromObj\fR(\fIinterp, objPtr, numBytesPtr\fR) .VE TIP568 .sp unsigned char * -\fBTcl_GetByteArrayFromObj\fR(\fIobjPtr, lengthPtr\fR) +\fBTcl_GetByteArrayFromObj\fR(\fIobjPtr, numBytesPtr\fR) .sp unsigned char * -\fBTcl_SetByteArrayLength\fR(\fIobjPtr, length\fR) +\fBTcl_SetByteArrayLength\fR(\fIobjPtr, numBytes\fR) .SH ARGUMENTS -.AS "const unsigned char" *lengthPtr in/out -.AP Tcl_Interp *interp in -Interpreter to use for error reporting. +.AS "const unsigned char" *numBytesPtr in/out .AP "const unsigned char" *bytes in The array of bytes used to initialize or set a byte-array value. May be NULL -even if \fIlength\fR is non-zero. -.AP int length in -The length of the array of bytes. It must be >= 0. +even if \fInumBytes\fR is non-zero. +.AP int numBytes in +The number of bytes in the array. It must be >= 0. .AP Tcl_Obj *objPtr in/out For \fBTcl_SetByteArrayObj\fR, this points to an unshared value to be overwritten by a byte-array value. For \fBTcl_GetBytesFromObj\fR, \fBTcl_GetByteArrayFromObj\fR and \fBTcl_SetByteArrayLength\fR, this points -to the value from which to extract a byte-array value. -.AP "size_t | int" *lengthPtr out -Points to space to be filled with the length of the array of bytes extracted -from \fIobjPtr\fR. May be NULL when the caller does not need the length. +to the value from which to extract an array of bytes. +.AP Tcl_Interp *interp in +Interpreter to use for error reporting. +.AP "size_t | int" *numBytesPtr out +Points to space where the number of bytes in the array may be written. +Caller may pass NULL when it does not need this information. .BE .SH DESCRIPTION @@ -66,11 +66,11 @@ Modified UTF-8 encoding. .PP \fBTcl_NewByteArrayObj\fR and \fBTcl_SetByteArrayObj\fR create a new value or overwrite an existing unshared value, respectively, -to hold a byte-array value of \fIlength\fR bytes. \fBTcl_NewByteArrayObj\fR +to hold a byte-array value of \fInumBytes\fR bytes. \fBTcl_NewByteArrayObj\fR returns a pointer to the created value with a reference count of zero. \fBTcl_SetByteArrayObj\fR overwrites and invalidates any old contents as appropriate, and keeps the same reference count (0 or 1). When -the \fIbytes\fR argument passed to either routine is not NULL, \fIlength\fR +the \fIbytes\fR argument passed to either routine is not NULL, \fInumBytes\fR bytes are copied from \fIbytes\fR into the new value. When the \fIbytes\fR argument passed to either routine is NULL, the contents of the resulting byte array value are undefined. A \fIbytes\fR @@ -81,8 +81,8 @@ only on unshared values, and accompanied by all appropriate invalidations. .PP \fBTcl_GetByteArrayFromObj\fR converts a Tcl value to byte-array type and returns a pointer to the value's new internal representation as an array of -bytes. The length of this array is stored in \fIlengthPtr\fR if -\fIlengthPtr\fR is non-NULL. The storage for the array of bytes is owned by +bytes. The number of bytes in this array is stored in \fInumBytesPtr\fR if +\fInumBytesPtr\fR is non-NULL. The storage for the array of bytes is owned by the value and should not be freed. The contents of the array may be modified by the caller only if the value is not shared and the caller invalidates the string representation. @@ -92,11 +92,12 @@ the difference is that this function can error if the object contains characters > 255. If \fBinterp\fR is not NULL, an error-message will be left there. .PP \fBTcl_SetByteArrayLength\fR converts the Tcl value to byte-array type -and changes the length of the value's internal representation as an -array of bytes. If \fIlength\fR is greater than the space currently -allocated for the array, the array is reallocated to the new length; the -newly allocated bytes at the end of the array have arbitrary values. If -\fIlength\fR is less than the space currently allocated for the array, +and changes the number of bytes in the value's internal representation as an +array of bytes. If \fInumBytes\fR is greater than the space currently +allocated for the array, the array is reallocated be large enough to store +the larger number of bytes; the newly allocated bytes at the end of the +array have arbitrary values. If +\fInumBytes\fR is less than the space currently allocated for the array, the length of array is reduced to the new length. The return value is a pointer to the value's new array of bytes. diff --git a/generic/tcl.decls b/generic/tcl.decls index bf547c2..ffd2f95 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -108,7 +108,7 @@ declare 22 {deprecated {No longer in use, changed to macro}} { Tcl_Obj *Tcl_DbNewBooleanObj(int boolValue, const char *file, int line) } declare 23 { - Tcl_Obj *Tcl_DbNewByteArrayObj(const unsigned char *bytes, int length, + Tcl_Obj *Tcl_DbNewByteArrayObj(const unsigned char *bytes, int numBytes, const char *file, int line) } declare 24 { @@ -143,7 +143,7 @@ declare 32 { int *boolPtr) } declare 33 { - unsigned char *Tcl_GetByteArrayFromObj(Tcl_Obj *objPtr, int *lengthPtr) + unsigned char *Tcl_GetByteArrayFromObj(Tcl_Obj *objPtr, int *numBytesPtr) } declare 34 { int Tcl_GetDouble(Tcl_Interp *interp, const char *src, double *doublePtr) @@ -202,7 +202,7 @@ declare 49 {deprecated {No longer in use, changed to macro}} { Tcl_Obj *Tcl_NewBooleanObj(int boolValue) } declare 50 { - Tcl_Obj *Tcl_NewByteArrayObj(const unsigned char *bytes, int length) + Tcl_Obj *Tcl_NewByteArrayObj(const unsigned char *bytes, int numBytes) } declare 51 { Tcl_Obj *Tcl_NewDoubleObj(double doubleValue) @@ -226,11 +226,11 @@ declare 57 {deprecated {No longer in use, changed to macro}} { void Tcl_SetBooleanObj(Tcl_Obj *objPtr, int boolValue) } declare 58 { - unsigned char *Tcl_SetByteArrayLength(Tcl_Obj *objPtr, int length) + unsigned char *Tcl_SetByteArrayLength(Tcl_Obj *objPtr, int numBytes) } declare 59 { void Tcl_SetByteArrayObj(Tcl_Obj *objPtr, const unsigned char *bytes, - int length) + int numBytes) } declare 60 { void Tcl_SetDoubleObj(Tcl_Obj *objPtr, double doubleValue) @@ -2405,11 +2405,11 @@ declare 648 { # TIP #568 declare 649 { unsigned char *TclGetBytesFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, - int *lengthPtr) + int *numBytesPtr) } declare 650 { unsigned char *Tcl_GetBytesFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, - size_t *lengthPtr) + size_t *numBytesPtr) } # TIP #481 @@ -2420,7 +2420,7 @@ declare 652 { Tcl_UniChar *TclGetUnicodeFromObj(Tcl_Obj *objPtr, size_t *lengthPtr) } declare 653 { - unsigned char *TclGetByteArrayFromObj(Tcl_Obj *objPtr, size_t *lengthPtr) + unsigned char *TclGetByteArrayFromObj(Tcl_Obj *objPtr, size_t *numBytesPtr) } # TIP #575 diff --git a/generic/tclBinary.c b/generic/tclBinary.c index a133ed1..24f085b 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -294,16 +294,16 @@ Tcl_Obj * Tcl_NewByteArrayObj( const unsigned char *bytes, /* The array of bytes used to initialize the * new object. */ - int length) /* Length of the array of bytes, which must be - * >= 0. */ + int numBytes) /* Number of bytes in the array, + * must be >= 0. */ { #ifdef TCL_MEM_DEBUG - return Tcl_DbNewByteArrayObj(bytes, length, "unknown", 0); + return Tcl_DbNewByteArrayObj(bytes, numBytes, "unknown", 0); #else /* if not TCL_MEM_DEBUG */ Tcl_Obj *objPtr; TclNewObj(objPtr); - Tcl_SetByteArrayObj(objPtr, bytes, length); + Tcl_SetByteArrayObj(objPtr, bytes, numBytes); return objPtr; #endif /* TCL_MEM_DEBUG */ } @@ -338,8 +338,8 @@ Tcl_Obj * Tcl_DbNewByteArrayObj( const unsigned char *bytes, /* The array of bytes used to initialize the * new object. */ - int length, /* Length of the array of bytes, which must be - * >= 0. */ + int numBytes, /* Number of bytes in the array, + * must be >= 0. */ const char *file, /* The name of the source file calling this * procedure; used for debugging. */ int line) /* Line number in the source file; used for @@ -348,7 +348,7 @@ Tcl_DbNewByteArrayObj( Tcl_Obj *objPtr; TclDbNewObj(objPtr, file, line); - Tcl_SetByteArrayObj(objPtr, bytes, length); + Tcl_SetByteArrayObj(objPtr, bytes, numBytes); return objPtr; } #else /* if not TCL_MEM_DEBUG */ @@ -356,12 +356,12 @@ Tcl_Obj * Tcl_DbNewByteArrayObj( const unsigned char *bytes, /* The array of bytes used to initialize the * new object. */ - int length, /* Length of the array of bytes, which must be - * >= 0. */ + int numBytes, /* Number of bytes in the array, + * must be >= 0. */ TCL_UNUSED(const char *) /*file*/, TCL_UNUSED(int) /*line*/) { - return Tcl_NewByteArrayObj(bytes, length); + return Tcl_NewByteArrayObj(bytes, numBytes); } #endif /* TCL_MEM_DEBUG */ @@ -387,9 +387,9 @@ void Tcl_SetByteArrayObj( Tcl_Obj *objPtr, /* Object to initialize as a ByteArray. */ const unsigned char *bytes, /* The array of bytes to use as the new value. - * May be NULL even if length > 0. */ - int length) /* Length of the array of bytes, which must - * be >= 0. */ + * May be NULL even if numBytes > 0. */ + int numBytes) /* Number of bytes in the array, + * must be >= 0. */ { ByteArray *byteArrayPtr; Tcl_ObjInternalRep ir; @@ -399,16 +399,14 @@ Tcl_SetByteArrayObj( } TclInvalidateStringRep(objPtr); - if (length < 0) { - length = 0; - } - byteArrayPtr = (ByteArray *)ckalloc(BYTEARRAY_SIZE(length)); - byteArrayPtr->bad = length; - byteArrayPtr->used = length; - byteArrayPtr->allocated = length; + assert(numBytes >= 0); + byteArrayPtr = (ByteArray *)ckalloc(BYTEARRAY_SIZE(numBytes)); + byteArrayPtr->bad = numBytes; + byteArrayPtr->used = numBytes; + byteArrayPtr->allocated = numBytes; - if ((bytes != NULL) && (length > 0)) { - memcpy(byteArrayPtr->bytes, bytes, length); + if ((bytes != NULL) && (numBytes > 0)) { + memcpy(byteArrayPtr->bytes, bytes, numBytes); } SET_BYTEARRAY(&ir, byteArrayPtr); @@ -427,7 +425,7 @@ Tcl_SetByteArrayObj( * * Results: * NULL or pointer to array of bytes representing the ByteArray object. - * Writes number of bytes in array to *lengthPtr. + * Writes number of bytes in array to *numBytesPtr. * *---------------------------------------------------------------------- */ @@ -436,8 +434,8 @@ unsigned char * TclGetBytesFromObj( Tcl_Interp *interp, /* For error reporting */ Tcl_Obj *objPtr, /* Value to extract from */ - int *lengthPtr) /* If non-NULL, filled with length of the - * returned array of bytes. */ + int *numBytesPtr) /* If non-NULL, write the number of bytes + * in the array here */ { ByteArray *baPtr; const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objPtr, &properByteArrayType); @@ -465,8 +463,8 @@ TclGetBytesFromObj( } baPtr = GET_BYTEARRAY(irPtr); - if (lengthPtr != NULL) { - *lengthPtr = baPtr->used; + if (numBytesPtr != NULL) { + *numBytesPtr = baPtr->used; } return baPtr->bytes; } @@ -475,8 +473,8 @@ unsigned char * Tcl_GetBytesFromObj( Tcl_Interp *interp, /* For error reporting */ Tcl_Obj *objPtr, /* Value to extract from */ - size_t *lengthPtr) /* If non-NULL, filled with length of the - * array of bytes in the ByteArray object. */ + size_t *numBytesPtr) /* If non-NULL, write the number of bytes + * in the array here */ { ByteArray *baPtr; const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objPtr, &properByteArrayType); @@ -504,8 +502,8 @@ Tcl_GetBytesFromObj( } baPtr = GET_BYTEARRAY(irPtr); - if (lengthPtr != NULL) { - *lengthPtr = baPtr->used; + if (numBytesPtr != NULL) { + *numBytesPtr = baPtr->used; } return baPtr->bytes; } @@ -532,12 +530,12 @@ Tcl_GetBytesFromObj( unsigned char * Tcl_GetByteArrayFromObj( Tcl_Obj *objPtr, /* The ByteArray object. */ - int *lengthPtr) /* If non-NULL, filled with length of the - * array of bytes in the ByteArray object. */ + int *numBytesPtr) /* If non-NULL, write the number of bytes + * in the array here */ { ByteArray *baPtr; const Tcl_ObjInternalRep *irPtr; - unsigned char *result = TclGetBytesFromObj(NULL, objPtr, lengthPtr); + unsigned char *result = TclGetBytesFromObj(NULL, objPtr, numBytesPtr); if (result) { return result; @@ -548,8 +546,8 @@ Tcl_GetByteArrayFromObj( baPtr = GET_BYTEARRAY(irPtr); - if (lengthPtr != NULL) { - *lengthPtr = baPtr->used; + if (numBytesPtr != NULL) { + *numBytesPtr = baPtr->used; } return (unsigned char *) baPtr->bytes; } @@ -557,12 +555,12 @@ Tcl_GetByteArrayFromObj( unsigned char * TclGetByteArrayFromObj( Tcl_Obj *objPtr, /* The ByteArray object. */ - size_t *lengthPtr) /* If non-NULL, filled with length of the - * array of bytes in the ByteArray object. */ + size_t *numBytesPtr) /* If non-NULL, write the number of bytes + * in the array here */ { ByteArray *baPtr; const Tcl_ObjInternalRep *irPtr; - unsigned char *result = TclGetBytesFromObj(NULL, objPtr, (int *)NULL); + unsigned char *result = Tcl_GetBytesFromObj(NULL, objPtr, numBytesPtr); if (result) { return result; @@ -573,12 +571,12 @@ TclGetByteArrayFromObj( baPtr = GET_BYTEARRAY(irPtr); - if (lengthPtr != NULL) { + if (numBytesPtr != NULL) { #if TCL_MAJOR_VERSION > 8 - *lengthPtr = baPtr->used; + *numBytesPtr = baPtr->used; #else /* TODO: What's going on here? Document or eliminate. */ - *lengthPtr = ((size_t)(unsigned)(baPtr->used + 1)) - 1; + *numBytesPtr = ((size_t)(unsigned)(baPtr->used + 1)) - 1; #endif } return baPtr->bytes; @@ -609,14 +607,14 @@ TclGetByteArrayFromObj( unsigned char * Tcl_SetByteArrayLength( Tcl_Obj *objPtr, /* The ByteArray object. */ - int length) /* New length for internal byte array. */ + int numBytes) /* Number of bytes in resized array */ { ByteArray *byteArrayPtr; unsigned newLength; Tcl_ObjInternalRep *irPtr; - assert(length >= 0); - newLength = (unsigned int)length; + assert(numBytes >= 0); + newLength = (unsigned int)numBytes; if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object", "Tcl_SetByteArrayLength"); @@ -634,6 +632,9 @@ Tcl_SetByteArrayLength( } } + /* Note that during truncation, the implementation does not free + * memory that is no longer needed. */ + byteArrayPtr = GET_BYTEARRAY(irPtr); if (newLength > byteArrayPtr->allocated) { byteArrayPtr = (ByteArray *)ckrealloc(byteArrayPtr, BYTEARRAY_SIZE(newLength)); @@ -686,6 +687,9 @@ SetByteArrayFromAny( length = bad = objPtr->length; srcEnd = src + length; + /* Note the allocation is over-sized, possibly by a factor of four, + * or even a factor of two with a proper byte array value. */ + byteArrayPtr = (ByteArray *)ckalloc(BYTEARRAY_SIZE(length)); for (dst = byteArrayPtr->bytes; src < srcEnd; ) { src += TclUtfToUniChar(src, &ch); diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 8a361ce..e93e41d 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -124,7 +124,7 @@ Tcl_Obj * Tcl_DbNewBooleanObj(int boolValue, const char *file, int line); /* 23 */ EXTERN Tcl_Obj * Tcl_DbNewByteArrayObj(const unsigned char *bytes, - int length, const char *file, int line); + int numBytes, const char *file, int line); /* 24 */ EXTERN Tcl_Obj * Tcl_DbNewDoubleObj(double doubleValue, const char *file, int line); @@ -152,7 +152,7 @@ EXTERN int Tcl_GetBooleanFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int *boolPtr); /* 33 */ EXTERN unsigned char * Tcl_GetByteArrayFromObj(Tcl_Obj *objPtr, - int *lengthPtr); + int *numBytesPtr); /* 34 */ EXTERN int Tcl_GetDouble(Tcl_Interp *interp, const char *src, double *doublePtr); @@ -205,7 +205,7 @@ TCL_DEPRECATED("No longer in use, changed to macro") Tcl_Obj * Tcl_NewBooleanObj(int boolValue); /* 50 */ EXTERN Tcl_Obj * Tcl_NewByteArrayObj(const unsigned char *bytes, - int length); + int numBytes); /* 51 */ EXTERN Tcl_Obj * Tcl_NewDoubleObj(double doubleValue); /* 52 */ @@ -224,10 +224,10 @@ EXTERN Tcl_Obj * Tcl_NewStringObj(const char *bytes, int length); TCL_DEPRECATED("No longer in use, changed to macro") void Tcl_SetBooleanObj(Tcl_Obj *objPtr, int boolValue); /* 58 */ -EXTERN unsigned char * Tcl_SetByteArrayLength(Tcl_Obj *objPtr, int length); +EXTERN unsigned char * Tcl_SetByteArrayLength(Tcl_Obj *objPtr, int numBytes); /* 59 */ EXTERN void Tcl_SetByteArrayObj(Tcl_Obj *objPtr, - const unsigned char *bytes, int length); + const unsigned char *bytes, int numBytes); /* 60 */ EXTERN void Tcl_SetDoubleObj(Tcl_Obj *objPtr, double doubleValue); /* 61 */ @@ -1922,10 +1922,10 @@ EXTERN int * Tcl_UtfToUniCharDString(const char *src, int length, Tcl_DString *dsPtr); /* 649 */ EXTERN unsigned char * TclGetBytesFromObj(Tcl_Interp *interp, - Tcl_Obj *objPtr, int *lengthPtr); + Tcl_Obj *objPtr, int *numBytesPtr); /* 650 */ EXTERN unsigned char * Tcl_GetBytesFromObj(Tcl_Interp *interp, - Tcl_Obj *objPtr, size_t *lengthPtr); + Tcl_Obj *objPtr, size_t *numBytesPtr); /* 651 */ EXTERN char * TclGetStringFromObj(Tcl_Obj *objPtr, size_t *lengthPtr); @@ -1934,7 +1934,7 @@ EXTERN Tcl_UniChar * TclGetUnicodeFromObj(Tcl_Obj *objPtr, size_t *lengthPtr); /* 653 */ EXTERN unsigned char * TclGetByteArrayFromObj(Tcl_Obj *objPtr, - size_t *lengthPtr); + size_t *numBytesPtr); /* 654 */ EXTERN int Tcl_UtfCharComplete(const char *src, int length); /* 655 */ @@ -1998,7 +1998,7 @@ typedef struct TclStubs { void (*tcl_DbIncrRefCount) (Tcl_Obj *objPtr, const char *file, int line); /* 20 */ int (*tcl_DbIsShared) (Tcl_Obj *objPtr, const char *file, int line); /* 21 */ TCL_DEPRECATED_API("No longer in use, changed to macro") Tcl_Obj * (*tcl_DbNewBooleanObj) (int boolValue, const char *file, int line); /* 22 */ - Tcl_Obj * (*tcl_DbNewByteArrayObj) (const unsigned char *bytes, int length, const char *file, int line); /* 23 */ + Tcl_Obj * (*tcl_DbNewByteArrayObj) (const unsigned char *bytes, int numBytes, const char *file, int line); /* 23 */ Tcl_Obj * (*tcl_DbNewDoubleObj) (double doubleValue, const char *file, int line); /* 24 */ Tcl_Obj * (*tcl_DbNewListObj) (int objc, Tcl_Obj *const *objv, const char *file, int line); /* 25 */ TCL_DEPRECATED_API("No longer in use, changed to macro") Tcl_Obj * (*tcl_DbNewLongObj) (long longValue, const char *file, int line); /* 26 */ @@ -2008,7 +2008,7 @@ typedef struct TclStubs { void (*tclFreeObj) (Tcl_Obj *objPtr); /* 30 */ int (*tcl_GetBoolean) (Tcl_Interp *interp, const char *src, int *boolPtr); /* 31 */ int (*tcl_GetBooleanFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int *boolPtr); /* 32 */ - unsigned char * (*tcl_GetByteArrayFromObj) (Tcl_Obj *objPtr, int *lengthPtr); /* 33 */ + unsigned char * (*tcl_GetByteArrayFromObj) (Tcl_Obj *objPtr, int *numBytesPtr); /* 33 */ int (*tcl_GetDouble) (Tcl_Interp *interp, const char *src, double *doublePtr); /* 34 */ int (*tcl_GetDoubleFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, double *doublePtr); /* 35 */ TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_GetIndexFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, const char *const *tablePtr, const char *msg, int flags, int *indexPtr); /* 36 */ @@ -2025,7 +2025,7 @@ typedef struct TclStubs { int (*tcl_ListObjLength) (Tcl_Interp *interp, Tcl_Obj *listPtr, int *lengthPtr); /* 47 */ int (*tcl_ListObjReplace) (Tcl_Interp *interp, Tcl_Obj *listPtr, int first, int count, int objc, Tcl_Obj *const objv[]); /* 48 */ TCL_DEPRECATED_API("No longer in use, changed to macro") Tcl_Obj * (*tcl_NewBooleanObj) (int boolValue); /* 49 */ - Tcl_Obj * (*tcl_NewByteArrayObj) (const unsigned char *bytes, int length); /* 50 */ + Tcl_Obj * (*tcl_NewByteArrayObj) (const unsigned char *bytes, int numBytes); /* 50 */ Tcl_Obj * (*tcl_NewDoubleObj) (double doubleValue); /* 51 */ TCL_DEPRECATED_API("No longer in use, changed to macro") Tcl_Obj * (*tcl_NewIntObj) (int intValue); /* 52 */ Tcl_Obj * (*tcl_NewListObj) (int objc, Tcl_Obj *const objv[]); /* 53 */ @@ -2033,8 +2033,8 @@ typedef struct TclStubs { Tcl_Obj * (*tcl_NewObj) (void); /* 55 */ Tcl_Obj * (*tcl_NewStringObj) (const char *bytes, int length); /* 56 */ TCL_DEPRECATED_API("No longer in use, changed to macro") void (*tcl_SetBooleanObj) (Tcl_Obj *objPtr, int boolValue); /* 57 */ - unsigned char * (*tcl_SetByteArrayLength) (Tcl_Obj *objPtr, int length); /* 58 */ - void (*tcl_SetByteArrayObj) (Tcl_Obj *objPtr, const unsigned char *bytes, int length); /* 59 */ + unsigned char * (*tcl_SetByteArrayLength) (Tcl_Obj *objPtr, int numBytes); /* 58 */ + void (*tcl_SetByteArrayObj) (Tcl_Obj *objPtr, const unsigned char *bytes, int numBytes); /* 59 */ void (*tcl_SetDoubleObj) (Tcl_Obj *objPtr, double doubleValue); /* 60 */ TCL_DEPRECATED_API("No longer in use, changed to macro") void (*tcl_SetIntObj) (Tcl_Obj *objPtr, int intValue); /* 61 */ void (*tcl_SetListObj) (Tcl_Obj *objPtr, int objc, Tcl_Obj *const objv[]); /* 62 */ @@ -2632,11 +2632,11 @@ typedef struct TclStubs { int (*tcl_UtfToUniChar) (const char *src, int *chPtr); /* 646 */ char * (*tcl_UniCharToUtfDString) (const int *uniStr, int uniLength, Tcl_DString *dsPtr); /* 647 */ int * (*tcl_UtfToUniCharDString) (const char *src, int length, Tcl_DString *dsPtr); /* 648 */ - unsigned char * (*tclGetBytesFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int *lengthPtr); /* 649 */ - unsigned char * (*tcl_GetBytesFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, size_t *lengthPtr); /* 650 */ + unsigned char * (*tclGetBytesFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int *numBytesPtr); /* 649 */ + unsigned char * (*tcl_GetBytesFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, size_t *numBytesPtr); /* 650 */ char * (*tclGetStringFromObj) (Tcl_Obj *objPtr, size_t *lengthPtr); /* 651 */ Tcl_UniChar * (*tclGetUnicodeFromObj) (Tcl_Obj *objPtr, size_t *lengthPtr); /* 652 */ - unsigned char * (*tclGetByteArrayFromObj) (Tcl_Obj *objPtr, size_t *lengthPtr); /* 653 */ + unsigned char * (*tclGetByteArrayFromObj) (Tcl_Obj *objPtr, size_t *numBytesPtr); /* 653 */ int (*tcl_UtfCharComplete) (const char *src, int length); /* 654 */ const char * (*tcl_UtfNext) (const char *src); /* 655 */ const char * (*tcl_UtfPrev) (const char *src, const char *start); /* 656 */ -- cgit v0.12 From cf9ec4f29ada714b10771db9437f510c4f0a4c94 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 5 Nov 2021 19:47:03 +0000 Subject: Adapt documentation of the *ByteArray* routines to better match Tcl library functioning post-TIP 568. --- doc/ByteArrObj.3 | 148 +++++++++++++++++++++++++++++++++++++++---------------- 1 file changed, 105 insertions(+), 43 deletions(-) diff --git a/doc/ByteArrObj.3 b/doc/ByteArrObj.3 index 0703164..13aa012 100644 --- a/doc/ByteArrObj.3 +++ b/doc/ByteArrObj.3 @@ -50,57 +50,119 @@ Caller may pass NULL when it does not need this information. .SH DESCRIPTION .PP -These procedures are used to create, modify, and read Tcl byte-array values -from C code. Byte-array values are typically used to hold the -results of binary IO operations, data structures created with the -\fBbinary\fR command, or other information, such as encrypted data, -represented as arbitrary binary data. -A byte-array is an array of 8-bit quantities (the integer range 0 - 255) -with no inherent meaning. When a byte-array value must be processed as -a string, the sequence of \fBN\fR bytes is transformed into the corresponding -sequence of \fBN\fR characters, where each byte value transforms to the same +These routines are used to create, modify, store, transfer, and retrieve +arbitrary binary data in Tcl values. Specifically, data that can be +represented as a sequence of arbitrary byte values is supported. +This includes data read from binary channels, values created by the +\fBbinary\fR command, encrypted data, or other information representable as +a finite byte sequence. +.PP +A byte is an 8-bit quantity with no inherent meaning. When the 8 bits are +interpreted as an integer value, the range of possible values is (0-255). +The C type best suited to store a byte is the \fBunsigned char\fR. +An \fBunsigned char\fR array of size \fIN\fR stores an aribtrary binary +value of size \fIN\fR bytes. We call this representation a byte-array. +Here we document the routines that allow us to operate on Tcl values as +byte-arrays. +.PP +All Tcl values must correspond to a string representation. +When a byte-array value must be processed as a string, the sequence +of \fIN\fR bytes is transformed into the corresponding sequence +of \fIN\fR characters, where each byte value transforms to the same character codepoint value in the range (U+0000 - U+00FF). Obtaining the string representation of a byte-array value (by calling -\fBTcl_GetStringFromObj\fR) produces this string in Tcl's usual +\fBTcl_GetStringFromObj\fR) produces this string in Tcl's usual Modified UTF-8 encoding. .PP \fBTcl_NewByteArrayObj\fR and \fBTcl_SetByteArrayObj\fR create a new value or overwrite an existing unshared value, respectively, -to hold a byte-array value of \fInumBytes\fR bytes. \fBTcl_NewByteArrayObj\fR +to hold a byte-array value of \fInumBytes\fR bytes. When a caller +passes a non-NULL value of \fIbytes\fR, it must point to memory from +which \fInumBytes\fR bytes can be read. These routines +allocate \fInumBytes\fR bytes of memory, copy \fInumBytes\fR +bytes from \fIbytes\fR into it, and keep the result in the internal +representation of the new or overwritten value. +When the caller passes a NULL value of \fIbytes\fR, the data copying +step is skipped, and the bytes stored in the value are undefined. +A \fIbytes\fR value of NULL is useful only when the caller will arrange +to write known contents into the byte-array through a pointer retrieved +by a call to one of the routines explained below. \fBTcl_NewByteArrayObj\fR returns a pointer to the created value with a reference count of zero. \fBTcl_SetByteArrayObj\fR overwrites and invalidates any old contents -as appropriate, and keeps the same reference count (0 or 1). When -the \fIbytes\fR argument passed to either routine is not NULL, \fInumBytes\fR -bytes are copied from \fIbytes\fR into the new value. When -the \fIbytes\fR argument passed to either routine is NULL, the -contents of the resulting byte array value are undefined. A \fIbytes\fR -value of NULL is useful only when the caller will arrange to write -known contents into the byte array through a pointer retrieved by a call -to one of the routines explained below. Such manipulation must be performed -only on unshared values, and accompanied by all appropriate invalidations. +of the unshared \fIobjPtr\fR as appropriate, and keeps its reference +count (0 or 1) unchanged. The value produced by these routines has no +string representation. Any memory allocation failure may cause a panic. +Note that the type of the \fInumBytes\fR argument is \fBint\fR; consequently +the largest byte-array value that can be produced by these routines is one +holding \fBINT_MAX\fR bytes. Note also that the string representation of +any Tcl value is limited to \fBINT_MAX\fR bytes, so caution should be +taken with any byte-array of more than \fBINT_MAX / 2\fR bytes. .PP -\fBTcl_GetByteArrayFromObj\fR converts a Tcl value to byte-array type and -returns a pointer to the value's new internal representation as an array of -bytes. The number of bytes in this array is stored in \fInumBytesPtr\fR if -\fInumBytesPtr\fR is non-NULL. The storage for the array of bytes is owned by -the value and should not be freed. The contents of the array may be -modified by the caller only if the value is not shared and the caller -invalidates the string representation. +\fBTcl_GetBytesFromObj\fR performs the opposite function of +\fBTcl_SetByteArrayObj\fR, providing access to read a byte-array from +a Tcl value that was previously written into it. When \fIobjPtr\fR +is a value previously produced by \fBTcl_NewByteArrayObj\fR or +\fBTcl_SetByteArrayObj\fR, then \fBTcl_GetBytesFromObj\fR returns +a pointer to the byte-array kept in the value's internal representation. +If the caller provides a non-NULL value for \fInumBytesPtr\fR, it must +point to memory where \fBTcl_GetBytesFromObj\fR can write the number +of bytes in the value's internal byte-array. With both pieces of +information, the caller is able to retrieve any information about the +contents of that byte-array that it seeks. When \fIobjPtr\fR does +not already contain an internal byte-array, \fBTcl_GetBytesFromObj\fR +will try to create one from the value's string representation. Any +string value that does not include any character codepoints outside +the range (U+0000 - U+00FF) will successfully translate to a unique +byte-array value. With the created byte-array, the routine returns +as before. For any string representation which does contain +a forbidden character codepoint, the conversion fails, and +\fBTcl_GetBytesFromObj\fR returns NULL to signal that failure. On +failure, nothing will be written to \fInumBytesPtr\fR, and if +the \fIinterp\fR argument is non-NULL, then error messages and +codes are left in it recording the error. .PP -\fBTcl_GetBytesFromObj\fR does almost the same as \fBTcl_GetByteArrayFromObj\fR, -the difference is that this function can error if the object contains -characters > 255. If \fBinterp\fR is not NULL, an error-message will be left there. +\fBTcl_GetByteArrayFromObj\fR performs nearly the same function as +\fBTcl_GetBytesFromObj\fR. They differ only in the circumstance when +a byte-array internal value must be created by transformation of +a string representation, and that string representation contains a +character with codepoint greater than U+00FF. Instead of failing +the conversion, \fBTcl_GetByteArrayFromObj\fR will use the 8 least +significant bits of each codepoint to produce a valid byte value +from any character codepoint value. In any other circumstance, +\fBTcl_GetByteArrayFromObj\fR performs just as \fBTcl_GetBytesFromObj\fR +does. Since the conversion cannot fail, \fBTcl_GetByteArrayFromObj\fR +has no need for an \fIinterp\fR argument to record any errors and +the caller can assume \fBTcl_GetByteArrayFromObj\fR does not return NULL. .PP -\fBTcl_SetByteArrayLength\fR converts the Tcl value to byte-array type -and changes the number of bytes in the value's internal representation as an -array of bytes. If \fInumBytes\fR is greater than the space currently -allocated for the array, the array is reallocated be large enough to store -the larger number of bytes; the newly allocated bytes at the end of the -array have arbitrary values. If -\fInumBytes\fR is less than the space currently allocated for the array, -the length of array is reduced to the new length. The return value is a -pointer to the value's new array of bytes. - +\fBTcl_GetByteArrayFromObj\fR must be used with caution. Because of the +truncation on conversion, the byte-array made available to the caller +cannot reliably complete a round-trip back to the original string +representation. This creates opportunities for bugs due to blindness +to differences in values. This routine exists in this form primarily +for compatibility with codebases written for earlier releases of Tcl. +It is expected this routine will incompatibly change in Tcl 9 so that +it also signals failed conversions with a NULL return. +.PP +On success, both \fBTcl_GetByteFromObj\fR and \fBTcl_GetByteArrayFromObj\fR +return a pointer into the internal representation of a \fBTcl_Obj\fR. +That pointer must not be freed by the caller, and should not be retained +for use beyond the known time the internal representation of the value +has not been disturbed. The pointer may be used to overwrite the byte +contents of the internal representation, so long as the value is unshared +and any string representation is invalidated. +.PP +\fBTcl_SetByteArrayLength\fR enables a caller to change the size of a +byte-array in the internal representation of an unshared \fIobjPtr\fR to +become \fInumBytes\fR bytes. This is most often useful after the +bytes of the internal byte-array have been directly overwritten and it +has been discovered that the required size differs from the first +estimate used in the allocation. \fBTcl_SetByteArrayLength\fR returns +a pointer to the resized byte-array. Along with such resizing, any +string representation of \fIobjPtr\fR must be invalidated. If resizing +grows the byte-array, the new byte values are undefined. If \fIobjPtr\fR +does not already possess an internal byte-array, one is produced in the +same way that \fBTcl_GetByteArrayFromObj\fR does, with all the cautions +that go along with that. .SH "REFERENCE COUNT MANAGEMENT" .PP \fBTcl_NewByteArrayObj\fR always returns a zero-reference object, much @@ -110,11 +172,11 @@ like \fBTcl_NewObj\fR. reference count of their \fIobjPtr\fR arguments, but do require that the object be unshared. .PP -\fBTcl_GetByteArrayFromObj\fR does not modify the reference count of its -\fIobjPtr\fR argument; it only reads. +\fBTcl_GetBytesFromObj\fR and \fBTcl_GetByteArrayFromObj\fR do not modify +the reference count of \fIobjPtr\fR; they only read. .SH "SEE ALSO" Tcl_GetStringFromObj, Tcl_NewObj, Tcl_IncrRefCount, Tcl_DecrRefCount .SH KEYWORDS -value, binary data, byte array, utf, unicode, internationalization +value, binary data, byte array, utf, unicode -- cgit v0.12 From f096016a8e791b2cc0d577bfe29ef772ef7681b7 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sat, 6 Nov 2021 08:02:01 +0000 Subject: Eliminate unused variables/function-arguments --- doc/ByteArrObj.3 | 10 +++++----- generic/tclBinary.c | 8 ++++---- generic/tclZipfs.c | 23 +++++++---------------- 3 files changed, 16 insertions(+), 25 deletions(-) diff --git a/doc/ByteArrObj.3 b/doc/ByteArrObj.3 index 13aa012..cf033f8 100644 --- a/doc/ByteArrObj.3 +++ b/doc/ByteArrObj.3 @@ -74,14 +74,14 @@ string representation of a byte-array value (by calling \fBTcl_GetStringFromObj\fR) produces this string in Tcl's usual Modified UTF-8 encoding. .PP -\fBTcl_NewByteArrayObj\fR and \fBTcl_SetByteArrayObj\fR +\fBTcl_NewByteArrayObj\fR and \fBTcl_SetByteArrayObj\fR create a new value or overwrite an existing unshared value, respectively, to hold a byte-array value of \fInumBytes\fR bytes. When a caller -passes a non-NULL value of \fIbytes\fR, it must point to memory from +passes a non-NULL value of \fIbytes\fR, it must point to memory from which \fInumBytes\fR bytes can be read. These routines allocate \fInumBytes\fR bytes of memory, copy \fInumBytes\fR bytes from \fIbytes\fR into it, and keep the result in the internal -representation of the new or overwritten value. +representation of the new or overwritten value. When the caller passes a NULL value of \fIbytes\fR, the data copying step is skipped, and the bytes stored in the value are undefined. A \fIbytes\fR value of NULL is useful only when the caller will arrange @@ -115,11 +115,11 @@ string value that does not include any character codepoints outside the range (U+0000 - U+00FF) will successfully translate to a unique byte-array value. With the created byte-array, the routine returns as before. For any string representation which does contain -a forbidden character codepoint, the conversion fails, and +a forbidden character codepoint, the conversion fails, and \fBTcl_GetBytesFromObj\fR returns NULL to signal that failure. On failure, nothing will be written to \fInumBytesPtr\fR, and if the \fIinterp\fR argument is non-NULL, then error messages and -codes are left in it recording the error. +codes are left in it recording the error. .PP \fBTcl_GetByteArrayFromObj\fR performs nearly the same function as \fBTcl_GetBytesFromObj\fR. They differ only in the circumstance when diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 24f085b..7b12f4c 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -180,7 +180,7 @@ static const EnsembleImplMap decodeMap[] = { * question arises what to do with strings outside that subset? That is, * those Tcl strings containing at least one codepoint greater than 255? The * obviously correct answer is to raise an error! That string value does not - * represent any valid bytearray value. + * represent any valid bytearray value. * * Unfortunately this was not the path taken by the authors of the original * tclByteArrayType. They chose to accept all Tcl string values as acceptable @@ -211,11 +211,11 @@ static const EnsembleImplMap decodeMap[] = { * what the retained "tclByteArrayType" provides. In those unusual * circumstances where we convert an invalid bytearray value to a bytearray * type, it is to this legacy type. Essentially any time this legacy type - * shows up, it's a signal of a bug being ignored. - * + * shows up, it's a signal of a bug being ignored. + * * In Tcl 9, the incompatibility in the behavior of these public routines * has been approved, and the legacy internal rep is no longer retained. - * The internal changes seen below are the limit of what can be done + * The internal changes seen below are the limit of what can be done * in a Tcl 8.* release. They provide a great expansion of the histories * over which bytearray values can be useful. */ diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c index f649588..60d77f4 100644 --- a/generic/tclZipfs.c +++ b/generic/tclZipfs.c @@ -308,13 +308,11 @@ static inline int ListMountPoints(Tcl_Interp *interp); static void SerializeCentralDirectoryEntry( const unsigned char *start, const unsigned char *end, unsigned char *buf, - ZipEntry *z, size_t nameLength, - long long dataStartOffset); + ZipEntry *z, size_t nameLength); static void SerializeCentralDirectorySuffix( const unsigned char *start, const unsigned char *end, unsigned char *buf, - int entryCount, long long dataStartOffset, - long long directoryStartOffset, + int entryCount, long long directoryStartOffset, long long suffixStartOffset); static void SerializeLocalEntryHeader( const unsigned char *start, @@ -1191,7 +1189,7 @@ ZipFSFindTOC( const unsigned char *p, *q; const unsigned char *start = zf->data; const unsigned char *end = zf->data + zf->length; - + /* * Scan backwards from the end of the file for the signature. This is * necessary because ZIP archives aren't the only things that get tagged @@ -1294,7 +1292,7 @@ ZipFSFindTOC( } zf->passOffset = minoff + zf->baseOffset; - + /* * If there's also an encoded password, extract that too (but don't decode * yet). @@ -3005,8 +3003,6 @@ ZipFSMkZipOrImg( Tcl_Channel out; int pwlen = 0, slen = 0, count, ret = TCL_ERROR, lobjc; size_t len, i = 0; - long long dataStartOffset; /* The overall file offset of the start of the - * data section of the file. */ long long directoryStartOffset; /* The overall file offset of the start of the * central directory. */ @@ -3183,7 +3179,6 @@ ZipFSMkZipOrImg( */ Tcl_InitHashTable(&fileHash, TCL_STRING_KEYS); - dataStartOffset = Tcl_Tell(out); if (mappingList == NULL && stripPrefix != NULL) { strip = Tcl_GetStringFromObj(stripPrefix, &slen); if (!slen) { @@ -3224,7 +3219,7 @@ ZipFSMkZipOrImg( name = Tcl_UtfToExternalDString(ZipFS.utf8, z->name, -1, &ds); len = Tcl_DStringLength(&ds); SerializeCentralDirectoryEntry(start, end, (unsigned char *) buf, - z, len, dataStartOffset); + z, len); if ((Tcl_Write(out, buf, ZIP_CENTRAL_HEADER_LEN) != ZIP_CENTRAL_HEADER_LEN) || ((size_t) Tcl_Write(out, name, len) != len)) { @@ -3244,7 +3239,7 @@ ZipFSMkZipOrImg( Tcl_Flush(out); suffixStartOffset = Tcl_Tell(out); SerializeCentralDirectorySuffix(start, end, (unsigned char *) buf, - count, dataStartOffset, directoryStartOffset, suffixStartOffset); + count, directoryStartOffset, suffixStartOffset); if (Tcl_Write(out, buf, ZIP_CENTRAL_END_LEN) != ZIP_CENTRAL_END_LEN) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "write error: %s", Tcl_PosixError(interp))); @@ -3401,9 +3396,7 @@ SerializeCentralDirectoryEntry( const unsigned char *end, /* The end of writable memory. */ unsigned char *buf, /* Where to serialize to */ ZipEntry *z, /* The description of what to serialize. */ - size_t nameLength, /* The length of the name. */ - long long dataStartOffset) /* The overall file offset of the start of the - * data section of the file. */ + size_t nameLength) /* The length of the name. */ { ZipWriteInt(start, end, buf + ZIP_CENTRAL_SIG_OFFS, ZIP_CENTRAL_HEADER_SIG); @@ -3437,8 +3430,6 @@ SerializeCentralDirectorySuffix( const unsigned char *end, /* The end of writable memory. */ unsigned char *buf, /* Where to serialize to */ int entryCount, /* The number of entries in the directory */ - long long dataStartOffset, /* The overall file offset of the start of the - * data section of the file. */ long long directoryStartOffset, /* The overall file offset of the start of the * central directory. */ -- cgit v0.12 From 370e151c6988f658a43fa9a98afc99b5593fe195 Mon Sep 17 00:00:00 2001 From: dgp Date: Sat, 6 Nov 2021 22:45:26 +0000 Subject: typo --- doc/ByteArrObj.3 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/ByteArrObj.3 b/doc/ByteArrObj.3 index cf033f8..16e0ea8 100644 --- a/doc/ByteArrObj.3 +++ b/doc/ByteArrObj.3 @@ -143,7 +143,7 @@ for compatibility with codebases written for earlier releases of Tcl. It is expected this routine will incompatibly change in Tcl 9 so that it also signals failed conversions with a NULL return. .PP -On success, both \fBTcl_GetByteFromObj\fR and \fBTcl_GetByteArrayFromObj\fR +On success, both \fBTcl_GetBytesFromObj\fR and \fBTcl_GetByteArrayFromObj\fR return a pointer into the internal representation of a \fBTcl_Obj\fR. That pointer must not be freed by the caller, and should not be retained for use beyond the known time the internal representation of the value -- cgit v0.12 From 84ac71183dfabec3532a34011f88dc0d47f78118 Mon Sep 17 00:00:00 2001 From: dgp Date: Sun, 7 Nov 2021 03:20:54 +0000 Subject: More accurately describe the string rep invalidation performed by Tcl_SetByteArrayLength() --- doc/ByteArrObj.3 | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/doc/ByteArrObj.3 b/doc/ByteArrObj.3 index 16e0ea8..1702c3a 100644 --- a/doc/ByteArrObj.3 +++ b/doc/ByteArrObj.3 @@ -157,8 +157,9 @@ become \fInumBytes\fR bytes. This is most often useful after the bytes of the internal byte-array have been directly overwritten and it has been discovered that the required size differs from the first estimate used in the allocation. \fBTcl_SetByteArrayLength\fR returns -a pointer to the resized byte-array. Along with such resizing, any -string representation of \fIobjPtr\fR must be invalidated. If resizing +a pointer to the resized byte-array. Because resizing the byte-array +changes the internal representation, \fBTcl_SetByteArrayLength\fR +also invalidates any string representation in \fIobjPtr\fR. If resizing grows the byte-array, the new byte values are undefined. If \fIobjPtr\fR does not already possess an internal byte-array, one is produced in the same way that \fBTcl_GetByteArrayFromObj\fR does, with all the cautions -- cgit v0.12 From 6eceb08de21bddce6cacfd581a5b3bc08a1a431c Mon Sep 17 00:00:00 2001 From: dgp Date: Sun, 7 Nov 2021 20:39:32 +0000 Subject: Document the freedom to provide space of either type int or size_t. --- doc/ByteArrObj.3 | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/doc/ByteArrObj.3 b/doc/ByteArrObj.3 index 1702c3a..fd7f245 100644 --- a/doc/ByteArrObj.3 +++ b/doc/ByteArrObj.3 @@ -151,6 +151,14 @@ has not been disturbed. The pointer may be used to overwrite the byte contents of the internal representation, so long as the value is unshared and any string representation is invalidated. .PP +On success, both \fBTcl_GetBytesFromObj\fR and \fBTcl_GetByteArrayFromObj\fR +write the number of bytes in the byte-array value of \fIobjPtr\fR +to the space pointed to by \fInumBytesPtr\fR. This space may be of type +\fBsize_t\fR or of type \fBint\fR. In Tcl 8, the largest number of +bytes possible is \fBINT_MAX\fR, so either type can receive the value. +In codebases meant to migrate to Tcl 9, the option to write to a space +of type \fBsize_t\fR may aid in the migration. +.PP \fBTcl_SetByteArrayLength\fR enables a caller to change the size of a byte-array in the internal representation of an unshared \fIobjPtr\fR to become \fInumBytes\fR bytes. This is most often useful after the -- cgit v0.12 From a112105294460f178a371ba9116b11c263b29f00 Mon Sep 17 00:00:00 2001 From: dgp Date: Sun, 7 Nov 2021 22:39:40 +0000 Subject: Update and clarify usage of the TclInitStringRep macro. --- generic/tclInt.h | 18 ++++++++++++------ 1 file changed, 12 insertions(+), 6 deletions(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index 08445a5..03d005a 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4486,15 +4486,21 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, /* *---------------------------------------------------------------- * Macro used by the Tcl core to set a Tcl_Obj's string representation to a - * copy of the "len" bytes starting at "bytePtr". This code works even if the - * byte array contains NULLs as long as the length is correct. Because "len" - * is referenced multiple times, it should be as simple an expression as - * possible. The ANSI C "prototype" for this macro is: + * copy of the "len" bytes starting at "bytePtr". The value of "len" must + * not be negative. When "len" is 0, then it is acceptable to pass + * "bytePtr" = NULL. When "len" > 0, "bytePtr" must not be NULL, and it + * must point to a location from which "len" bytes may be read. These + * constraints are not checked here. The validity of the bytes copied + * as a value string representation is also not verififed. This macro + * must not be called while "objPtr" is being freed. The caller must use + * this macro properly. Improper use can lead to dangerous results. + * Because "len" is referenced multiple times, take care that it is an + * expression with the same value each use. + * + * The ANSI C "prototype" for this macro is: * * MODULE_SCOPE void TclInitStringRep(Tcl_Obj *objPtr, char *bytePtr, int len); * - * This macro should only be called on an unshared objPtr where - * objPtr->typePtr->freeIntRepProc == NULL *---------------------------------------------------------------- */ -- cgit v0.12 From 411fc46d4f5e5e93a7d69db7f50e42b53005e343 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 8 Nov 2021 00:06:27 +0000 Subject: [9899c273ab] Rewrite Tcl_InitStringRep to account for all encounters with the non-allocated empty string rep. --- generic/tclBinary.c | 1 - generic/tclDictObj.c | 1 + generic/tclInt.h | 3 ++- generic/tclObj.c | 51 +++++++++++++++++++++++++++++++++------------------ 4 files changed, 36 insertions(+), 20 deletions(-) diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 5eb5b54..a586f18 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -842,7 +842,6 @@ UpdateStringOfByteArray( for (i = 0; i < length; i++) { dst += Tcl_UniCharToUtf(src[i], dst); } - (void) Tcl_InitStringRep(objPtr, NULL, size); } } diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index 900974f..b4249b8 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -566,6 +566,7 @@ UpdateStringOfDict( dst += TclConvertElement(elem, length, dst, flagPtr[i+1]); *dst++ = ' '; } + /* Last space overwrote the terminating NUL; cal T_ISR again to restore */ (void)Tcl_InitStringRep(dictPtr, NULL, bytesNeeded - 1); if (flagPtr != localFlags) { diff --git a/generic/tclInt.h b/generic/tclInt.h index 03d005a..7b03502 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4492,7 +4492,8 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, * must point to a location from which "len" bytes may be read. These * constraints are not checked here. The validity of the bytes copied * as a value string representation is also not verififed. This macro - * must not be called while "objPtr" is being freed. The caller must use + * must not be called while "objPtr" is being freed or when "objPtr" + * already has a string representation. The caller must use * this macro properly. Improper use can lead to dangerous results. * Because "len" is referenced multiple times, take care that it is an * expression with the same value each use. diff --git a/generic/tclObj.c b/generic/tclObj.c index e5ec838..92c6655 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -1815,32 +1815,48 @@ Tcl_InitStringRep( Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } - /* Allocate */ if (objPtr->bytes == NULL) { - /* Allocate only as empty - extend later if bytes copied */ - objPtr->length = 0; - if (numBytes) { + /* Start with no string rep */ + if (numBytes == 0) { + TclInitStringRep(objPtr, NULL, 0); + return objPtr->bytes; + } else { objPtr->bytes = (char *)attemptckalloc(numBytes + 1); - if (objPtr->bytes == NULL) { - return NULL; - } - if (bytes) { - /* Copy */ - memcpy(objPtr->bytes, bytes, numBytes); + if (objPtr->bytes) { objPtr->length = (int) numBytes; + if (bytes) { + memcpy(objPtr->bytes, bytes, numBytes); + } + objPtr->bytes[objPtr->length] = '\0'; } + } + } else if (objPtr->bytes == &tclEmptyString) { + /* Start with empty string rep (not allocated) */ + if (numBytes == 0) { + return objPtr->bytes; } else { - TclInitStringRep(objPtr, NULL, 0); + objPtr->bytes = (char *)attemptckalloc(numBytes + 1); + if (objPtr->bytes) { + objPtr->length = (int) numBytes; + objPtr->bytes[objPtr->length] = '\0'; + } } } else { - /* objPtr->bytes != NULL bytes == NULL - Truncate */ - objPtr->bytes = (char *)ckrealloc(objPtr->bytes, numBytes + 1); - objPtr->length = (int)numBytes; + /* Start with non-empty string rep (allocated) */ + if (numBytes == 0) { + ckfree(objPtr->bytes); + TclInitStringRep(objPtr, NULL, 0); + return objPtr->bytes; + } else { + objPtr->bytes = (char *)attemptckrealloc(objPtr->bytes, + numBytes + 1); + if (objPtr->bytes) { + objPtr->length = (int) numBytes; + objPtr->bytes[objPtr->length] = '\0'; + } + } } - /* Terminate */ - objPtr->bytes[objPtr->length] = '\0'; - return objPtr->bytes; } @@ -3517,7 +3533,6 @@ UpdateStringOfBignum( if (MP_OKAY != mp_to_radix(&bignumVal, stringVal, size, NULL, 10)) { Tcl_Panic("conversion failure in UpdateStringOfBignum"); } - (void) Tcl_InitStringRep(objPtr, NULL, size - 1); } /* -- cgit v0.12 From 8bfcb2b80c3f401b2ef6307ccee7cbf19a8ad3a4 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 8 Nov 2021 13:43:07 +0000 Subject: Make "changes" file chronological (again) --- changes | 346 ++++++++++++++++++++++++++++--------------------------- generic/tclInt.h | 2 +- 2 files changed, 176 insertions(+), 172 deletions(-) diff --git a/changes b/changes index 5609dcb..3f7f12f 100644 --- a/changes +++ b/changes @@ -8990,178 +8990,10 @@ in this changeset (new minor version) rather than bug fixes: 2019-11-15 (bug)[135804] segfault in [next] after destroy (coulter,sebres) -- Released 8.6.10, Nov 21, 2019 - details at https://core.tcl-lang.org/tcl/ - - -2019-12-03 (bug)[3cd9be] Corner case in surrogate handling (nijtmans) - -2019-12-09 (new) Add tcltest::(Setup|Eval|Cleanup|)Test (coulter,sebres) -=> tcltest 2.5.2 - -2019-12-12 (new) Add 3 libtommath functions to stub table (nijtmans) - -2019-12-23 (bug)[ce3b9f] compilation errors with clang, windows msys2 (nijtmans) - -2019-12-27 (bug)[1de6b0] [expr 1e2147483648] => 0.0 (kbk) - -2020-01-04 (bug)[912886] tis-620 encoding fails to load (coulter) - -2020-01-13 (bug)[0b9332] Win: support system encoding init to utf-8 (jedlička) - -2020-01-17 (bug)[8cd2fe] [unload] corrupted list of loaded packages (berc) - -2020-01-17 (bug)[5d989f] segfault in lsort for large list length (sebres) - -2020-01-30 (bug) Reset WSAGetLastError()/errno in channel close (nijtmans) - -2020-02-17 (bug) Win: avoid create of legacy error-vars on init phase (sebres) - -2020-02-25 (bug) release refs when setting class's superclasses fails (dkf) - -2020-02-26 (bug) C++ compiler compatibility for registry and dde (nijtmans) -=> registry 1.3.5 -=> dde 1.4.3 - -2020-03-05 (new) Update to Unicode-13 (nijtmans) - -2020-03-16 (bug)[8f89e2] Win: env var encoding, env-2.5 (sebres, nijtmans) - -2020-03-27 (bug)[767e07] Tcl_Get(Range|UniChar) validate index inputs (nijtmans) - -2020-03-28 (bug)[8edfce] [binary encode base64] & multi-byte wrapchars (dgp) - -2020-03-28 (bug)[ffeb20] [binary decode base64] ignore invalid chars (dgp) -See RFC 2045 - *** POTENTIAL INCOMPATIBILITY *** - -2020-03-31 (bug)[b8e82d] some -maxlen values break uuencode round trip (dgp) - *** POTENTIAL INCOMPATIBILITY *** - -2020-04-01 (bug)[f58371] Fileevent run in proper thread (bron,sebres) - -2020-04-13 (bug)[afa4b2] TclNeedSpace bug; tests util-8.5 .. util-8.11 (dgp) - -2020-04-13 (bug)[085913] Tcl_DStringAppendElement # quoting precision (dgp) - *** POTENTIAL INCOMPATIBILITY *** - -2020-04-13 (bug)[a7f685] test util-5.52 (dgp) - -2020-04-13 (bug)[c61818] Tcl_UtfPrev regression (dgp) - -2020-04-15 (bug)[8af92d] zlib transform issue, bad inflate (sebres) - -2020-04-16 (bug)[5e6346] Tcl_UtfPrev handling of overlong sequences (dgp) - -2020-04-27 (bug)[45ca23] [string tolower] inconsistency (dgp) - -2020-04-30 (bug)[da2352] init [info hostname] with DNS, not NetBIOS (nadkarni) - -2020-05-11 (bug)[d402ff] Win32 potential crash when using main() (werner) - -2020-05-13 (bug)[81242a] revised documentation for Tcl_UtfAtIndex() (nijtmans) - *** POTENTIAL INCOMPATIBILITY *** - -2020-05-13 (bug)[ed2980] Tcl_UtfToUniChar reads > TCL_UTF_MAX bytes (nijtmans) - *** POTENTIAL INCOMPATIBILITY *** - -2020-06-02 (bug) prevent segfault in parser (sebres) - -2020-06-21 (bug)[f81bec] http POST a binary file (alakendu,nash) -=> http 2.9.2 - -2020-06-23 (bug)[41c985] auto_path nonsense in Safe Base (nash) - -2020-06-24 (bug)[f70ce1] zlib multi-stream inflate acts only on first (sebres) - -2020-07-09 (bug)[a1bd37] [clock scan] new ISO format (clock-34.(19-24)) (sebres) - *** POTENTIAL INCOMPATIBILITY *** - -2020-07-10 (bug)[501974] [clock scan] +time zone (clock-34.(53-68)) (sebres) - *** POTENTIAL INCOMPATIBILITY *** - -2020-07-15 (bug)[3c6e47] compiled [lappend] performance, avoid copy (sebres) - -2020-07-16 (bug)[5bbd04] Fix index underflow (schwab) - -2020-07-27 (bug)[cb0373] http::geturl -keepalive fixes (nash) -=> http 2.9.3 - -2020-08-10 (bug)[29e884] cmd resolution cycle (namespace-57.0) (coulter,sebres) - -2020-08-12 (bug)[e87000] Tcl_BadChannelOption tolerate NULL (werner,nijtmans) - -2020-08-31 (TIP #581) disfavor Master/Slave terminology (nijtmans) -=> opt 0.4.8 - -2020-09-11 (bug)[3bc0f4] UBSan complains about body.chars[] usage (nijtmans) - -2020-09-17 (bug)[835c93] Support TIP 525 exit code for -singleproc 1 (nijtmans) -=> tcltest 2.5.3 - -2020-09-25 (new) force -eofchar \032 when evaluating library scripts (nijtmans) - *** POTENTIAL INCOMPATIBILITY *** - -2020-09-29 (bug)[0063cb] http::geturl -headers must be dict (oehlmann,nijtmans) - -2020-10-19 (bug)[cb4582] Update install-sh script (stu,nijtmans) - -2020-10-22 (bug)[c97593] Usage of gnu_printf in latest mingw-w64 (nijtmans) - -2020-10-26 (new)[48898a] improve error message consistency (stu) - *** POTENTIAL INCOMPATIBILITY *** - -2020-11-06 (new) revised case of module names (nijtmans) - *** POTENTIAL INCOMPATIBILITY *** - -2020-12-10 (bug)[ed5be7] Win: recognize "comx:" as serial port (oehlmann) - -2020-12-11 (new) support for msys2, Big Sur (nijtmans) -=> platform 1.0.15 - -2020-12-23 tzdata updated to Olson's tzdata2020e (jima) - -- Released 8.6.11, Dec 31, 2020 - details at https://core.tcl-lang.org/tcl/ - - -2021-02-02 (new) support for MacOS Big Sur updates (nijtmans) -=> platform 1.0.17 - -2021-02-15 (bug)[d43f96] [string trim*] broken for Emoji (werner) - -2021-02-16 (bug)[22324b] [string reverse] broken for Emoji (werner) - -2021-02-19 (bug)[1dab71,7c64aa] BRE broken by uninitialized value use (lane) - -2021-03-09 (bug)[8419c5] Unix tty channels tolerate EINTR (nijtmans) - *** POTENTIAL INCOMPATIBILITY *** - -2021-03-10 (bug)[4c591f] [string compare] EIAS violation (nijtmans) - -2021-04-08 (new) dde package installation compatible with Tcl 9 (nijtmans) -=> dde 1.4.4 - -2021-04-14 (bug)[266494] [concat foo [list #]] EIAS violation (porter) - -2021-05-03 (bug)[24b918] Save IO buffers from modern optimizers (rupprecht) +2019-11-18 (bug)[13657a] application/json us text, not binary (noe,nijtmans) +=> http 2.9.1 -2021-05-06 (new) support for POSIX error EILSEQ (nijtmans) - -2021-05-17 (bug)[688fcc] segfault during traced delete of alias (coulter) - -2021-06-22 (bug)[bad6cc] More secure build tool. CVE-2021-35331 (nijtmans) - -2021-07-17 (bug)[592a25] Win: segfault in Tcl_PutEnv() (danckaert,nijtmans) - -2021-09-02 (bug)[ccc448] segfault in ensemble rewrite machinery (coulter) - -2021-09-14 (new) Update to Unicode-14 (nijtmans) - -2021-10-08 (bug)[a8579d] failed proc argument spec processing (russell,coulter) - -2021-10-27 (new) support for MacOS Monterey (nijtmans) -=> platform 1.0.18 - -2021-10-27 tzdata updated to Olson's tzdata2021e (nijtmans) - -- Released 8.6.12, Nov 5, 2021 - details at https://core.tcl-lang.org/tcl/ - +- Released 8.6.10, Nov 21, 2019 - details at https://core.tcl-lang.org/tcl/ - Changes to 8.7a3 include all changes to the 8.6 line through 8.6.10, plus the following, which focuses on the high-level feature changes @@ -9295,6 +9127,136 @@ in this changeset (new minor version) rather than bug fixes: - Released 8.7a3, Nov 21, 2019 --- http://core.tcl-lang.org/tcl/ for details - +2019-12-03 (bug)[3cd9be] Corner case in surrogate handling (nijtmans) + +2019-12-09 (new) Add tcltest::(Setup|Eval|Cleanup|)Test (coulter,sebres) +=> tcltest 2.5.2 + +2019-12-12 (new) Add 3 libtommath functions to stub table (nijtmans) + +2019-12-23 (bug)[ce3b9f] compilation errors with clang, windows msys2 (nijtmans) + +2019-12-27 (bug)[1de6b0] [expr 1e2147483648] => 0.0 (kbk) + +2020-01-04 (bug)[912886] tis-620 encoding fails to load (coulter) + +2020-01-13 (bug)[0b9332] Win: support system encoding init to utf-8 (jedlička) + +2020-01-17 (bug)[8cd2fe] [unload] corrupted list of loaded packages (berc) + +2020-01-17 (bug)[5d989f] segfault in lsort for large list length (sebres) + +2020-01-30 (bug) Reset WSAGetLastError()/errno in channel close (nijtmans) + +2020-02-17 (bug) Win: avoid create of legacy error-vars on init phase (sebres) + +2020-02-25 (bug) release refs when setting class's superclasses fails (dkf) + +2020-02-26 (bug) C++ compiler compatibility for registry and dde (nijtmans) +=> registry 1.3.5 +=> dde 1.4.3 + +2020-03-05 (new) Update to Unicode-13 (nijtmans) + +2020-03-16 (bug)[8f89e2] Win: env var encoding, env-2.5 (sebres, nijtmans) + +2020-03-27 (bug)[767e07] Tcl_Get(Range|UniChar) validate index inputs (nijtmans) + +2020-03-28 (bug)[8edfce] [binary encode base64] & multi-byte wrapchars (dgp) + +2020-03-28 (bug)[ffeb20] [binary decode base64] ignore invalid chars (dgp) +See RFC 2045 + *** POTENTIAL INCOMPATIBILITY *** + +2020-03-31 (bug)[b8e82d] some -maxlen values break uuencode round trip (dgp) + *** POTENTIAL INCOMPATIBILITY *** + +2020-04-01 (bug)[f58371] Fileevent run in proper thread (bron,sebres) + +2020-04-13 (bug)[afa4b2] TclNeedSpace bug; tests util-8.5 .. util-8.11 (dgp) + +2020-04-13 (bug)[085913] Tcl_DStringAppendElement # quoting precision (dgp) + *** POTENTIAL INCOMPATIBILITY *** + +2020-04-13 (bug)[a7f685] test util-5.52 (dgp) + +2020-04-13 (bug)[c61818] Tcl_UtfPrev regression (dgp) + +2020-04-15 (bug)[8af92d] zlib transform issue, bad inflate (sebres) + +2020-04-16 (bug)[5e6346] Tcl_UtfPrev handling of overlong sequences (dgp) + +2020-04-27 (bug)[45ca23] [string tolower] inconsistency (dgp) + +2020-04-30 (bug)[da2352] init [info hostname] with DNS, not NetBIOS (nadkarni) + +2020-05-11 (bug)[d402ff] Win32 potential crash when using main() (werner) + +2020-05-13 (bug)[81242a] revised documentation for Tcl_UtfAtIndex() (nijtmans) + *** POTENTIAL INCOMPATIBILITY *** + +2020-05-13 (bug)[ed2980] Tcl_UtfToUniChar reads > TCL_UTF_MAX bytes (nijtmans) + *** POTENTIAL INCOMPATIBILITY *** + +2020-06-02 (bug) prevent segfault in parser (sebres) + +2020-06-21 (bug)[f81bec] http POST a binary file (alakendu,nash) +=> http 2.9.2 + +2020-06-23 (bug)[41c985] auto_path nonsense in Safe Base (nash) + +2020-06-24 (bug)[f70ce1] zlib multi-stream inflate acts only on first (sebres) + +2020-07-09 (bug)[a1bd37] [clock scan] new ISO format (clock-34.(19-24)) (sebres) + *** POTENTIAL INCOMPATIBILITY *** + +2020-07-10 (bug)[501974] [clock scan] +time zone (clock-34.(53-68)) (sebres) + *** POTENTIAL INCOMPATIBILITY *** + +2020-07-15 (bug)[3c6e47] compiled [lappend] performance, avoid copy (sebres) + +2020-07-16 (bug)[5bbd04] Fix index underflow (schwab) + +2020-07-27 (bug)[cb0373] http::geturl -keepalive fixes (nash) +=> http 2.9.3 + +2020-08-10 (bug)[29e884] cmd resolution cycle (namespace-57.0) (coulter,sebres) + +2020-08-12 (bug)[e87000] Tcl_BadChannelOption tolerate NULL (werner,nijtmans) + +2020-08-31 (TIP #581) disfavor Master/Slave terminology (nijtmans) +=> opt 0.4.8 + +2020-09-11 (bug)[3bc0f4] UBSan complains about body.chars[] usage (nijtmans) + +2020-09-17 (bug)[835c93] Support TIP 525 exit code for -singleproc 1 (nijtmans) +=> tcltest 2.5.3 + +2020-09-25 (new) force -eofchar \032 when evaluating library scripts (nijtmans) + *** POTENTIAL INCOMPATIBILITY *** + +2020-09-29 (bug)[0063cb] http::geturl -headers must be dict (oehlmann,nijtmans) + +2020-10-19 (bug)[cb4582] Update install-sh script (stu,nijtmans) + +2020-10-22 (bug)[c97593] Usage of gnu_printf in latest mingw-w64 (nijtmans) + +2020-10-26 (new)[48898a] improve error message consistency (stu) + *** POTENTIAL INCOMPATIBILITY *** + +2020-11-06 (new) revised case of module names (nijtmans) + *** POTENTIAL INCOMPATIBILITY *** + +2020-12-10 (bug)[ed5be7] Win: recognize "comx:" as serial port (oehlmann) + +2020-12-11 (new) support for msys2, Big Sur (nijtmans) +=> platform 1.0.15 + +2020-12-23 tzdata updated to Olson's tzdata2020e (jima) + +- Released 8.6.11, Dec 31, 2020 - details at https://core.tcl-lang.org/tcl/ - + + Changes to 8.7a5 include all changes to the 8.6 line through 8.6.11, plus the following, which focuses on the high-level feature changes in this changeset (new minor version) rather than bug fixes: @@ -9372,3 +9334,45 @@ in this changeset (new minor version) rather than bug fixes: 2021-05-18 (bug)[688fcc,28027d] namespace teardown reform (coulter) - Released 8.7a5, Jun 18, 2021 --- http://core.tcl-lang.org/tcl/ for details - + +2021-02-02 (new) support for MacOS Big Sur updates (nijtmans) +=> platform 1.0.17 + +2021-02-15 (bug)[d43f96] [string trim*] broken for Emoji (werner) + +2021-02-16 (bug)[22324b] [string reverse] broken for Emoji (werner) + +2021-02-19 (bug)[1dab71,7c64aa] BRE broken by uninitialized value use (lane) + +2021-03-09 (bug)[8419c5] Unix tty channels tolerate EINTR (nijtmans) + *** POTENTIAL INCOMPATIBILITY *** + +2021-03-10 (bug)[4c591f] [string compare] EIAS violation (nijtmans) + +2021-04-08 (new) dde package installation compatible with Tcl 9 (nijtmans) +=> dde 1.4.4 + +2021-04-14 (bug)[266494] [concat foo [list #]] EIAS violation (porter) + +2021-05-03 (bug)[24b918] Save IO buffers from modern optimizers (rupprecht) + +2021-05-06 (new) support for POSIX error EILSEQ (nijtmans) + +2021-05-17 (bug)[688fcc] segfault during traced delete of alias (coulter) + +2021-06-22 (bug)[bad6cc] More secure build tool. CVE-2021-35331 (nijtmans) + +2021-07-17 (bug)[592a25] Win: segfault in Tcl_PutEnv() (danckaert,nijtmans) + +2021-09-02 (bug)[ccc448] segfault in ensemble rewrite machinery (coulter) + +2021-09-14 (new) Update to Unicode-14 (nijtmans) + +2021-10-08 (bug)[a8579d] failed proc argument spec processing (russell,coulter) + +2021-10-27 (new) support for MacOS Monterey (nijtmans) +=> platform 1.0.18 + +2021-10-27 tzdata updated to Olson's tzdata2021e (nijtmans) + +- Released 8.6.12, Nov 5, 2021 - details at https://core.tcl-lang.org/tcl/ - diff --git a/generic/tclInt.h b/generic/tclInt.h index 7b03502..4e26bf3 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4496,7 +4496,7 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, * already has a string representation. The caller must use * this macro properly. Improper use can lead to dangerous results. * Because "len" is referenced multiple times, take care that it is an - * expression with the same value each use. + * expression with the same value each use. * * The ANSI C "prototype" for this macro is: * -- cgit v0.12 From 6c20a6ff0d3a2aea218b48df0ff32aafeb23167d Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 12 Nov 2021 21:29:06 +0000 Subject: Starting with 8.7, don't bother Cygwin32 any more. Only Cygwin64 will be supported. --- unix/configure | 4 ++-- unix/tcl.m4 | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/unix/configure b/unix/configure index a11adaa..d7c117d 100755 --- a/unix/configure +++ b/unix/configure @@ -5903,9 +5903,9 @@ printf "%s\n" "$ac_cv_cygwin" >&6; } fi do64bit_ok=yes if test "x${SHARED_BUILD}" = "x1"; then - echo "running cd ../win; ${CONFIG_SHELL-/bin/sh} ./configure $ac_configure_args" + echo "running cd ../win; ${CONFIG_SHELL-/bin/sh} ./configure $ac_configure_args --enable-64bit --host=x86_64-w64-mingw32" # The eval makes quoting arguments work. - if cd ../win; eval ${CONFIG_SHELL-/bin/sh} ./configure $ac_configure_args; cd ../unix + if cd ../win; eval ${CONFIG_SHELL-/bin/sh} ./configure $ac_configure_args --enable-64bit --host=x86_64-w64-mingw32; cd ../unix then : else { echo "configure: error: configure failed for ../win" 1>&2; exit 1; } diff --git a/unix/tcl.m4 b/unix/tcl.m4 index e2bf286..a5a4884 100644 --- a/unix/tcl.m4 +++ b/unix/tcl.m4 @@ -1105,9 +1105,9 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ fi do64bit_ok=yes if test "x${SHARED_BUILD}" = "x1"; then - echo "running cd ../win; ${CONFIG_SHELL-/bin/sh} ./configure $ac_configure_args" + echo "running cd ../win; ${CONFIG_SHELL-/bin/sh} ./configure $ac_configure_args --enable-64bit --host=x86_64-w64-mingw32" # The eval makes quoting arguments work. - if cd ../win; eval ${CONFIG_SHELL-/bin/sh} ./configure $ac_configure_args; cd ../unix + if cd ../win; eval ${CONFIG_SHELL-/bin/sh} ./configure $ac_configure_args --enable-64bit --host=x86_64-w64-mingw32; cd ../unix then : else { echo "configure: error: configure failed for ../win" 1>&2; exit 1; } -- cgit v0.12 From bb2edf53775d20639bf171c51667cea8e21cfcea Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 17 Nov 2021 10:08:35 +0000 Subject: Fix [46291ba24d]: win: install: bashism in Makefile.in --- unix/Makefile.in | 6 ++---- win/Makefile.in | 10 ++++------ 2 files changed, 6 insertions(+), 10 deletions(-) diff --git a/unix/Makefile.in b/unix/Makefile.in index ab21404..40b9c5a 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -1033,10 +1033,8 @@ install-libraries: libraries $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"; \ done @echo "Installing package cookiejar 0.2 files to $(SCRIPT_INSTALL_DIR)/cookiejar0.2/" - @for i in $(TOP_DIR)/library/cookiejar/*.tcl; do \ - $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)/cookiejar0.2"; \ - done - @for i in $(TOP_DIR)/library/cookiejar/*.gz; do \ + @for i in $(TOP_DIR)/library/cookiejar/*.tcl \ + $(TOP_DIR)/library/cookiejar/*.gz; do \ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)/cookiejar0.2"; \ done @echo "Installing package http 2.10a1 as a Tcl Module" diff --git a/win/Makefile.in b/win/Makefile.in index 1e4b822..d31f91c 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -851,20 +851,18 @@ install-libraries: libraries install-tzdata install-msgs fi; \ done; @echo "Installing library files to $(SCRIPT_INSTALL_DIR)"; - @for i in $(ROOT_DIR)/library/*.tcl $(ROOT_DIR)/library/tclIndex; \ - do \ + @for i in $(ROOT_DIR)/library/*.tcl $(ROOT_DIR)/library/tclIndex; do \ $(COPY) "$$i" "$(SCRIPT_INSTALL_DIR)"; \ done; @echo "Installing package cookiejar 0.2" - @for j in $(ROOT_DIR)/library/cookiejar/*.{tcl,gz}; \ - do \ + @for j in $(ROOT_DIR)/library/cookiejar/*.tcl \ + $(ROOT_DIR)/library/cookiejar/*.gz; do \ $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/cookiejar0.2"; \ done; @echo "Installing package http 2.10a1 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/http/http.tcl "$(MODULE_INSTALL_DIR)/8.6/http-2.10a1.tm"; @echo "Installing package opt 0.4.7"; - @for j in $(ROOT_DIR)/library/opt/*.tcl; \ - do \ + @for j in $(ROOT_DIR)/library/opt/*.tcl; do \ $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/opt0.4"; \ done; @echo "Installing package msgcat 1.7.1 as a Tcl Module"; -- 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 ef0be5183b6d353c44f438a8ca006ed66c587465 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 28 Nov 2021 21:53:34 +0000 Subject: Fix [97b8e1d54b]: -mdynamic-no-pic not supported on Apple Silicon --- unix/configure | 1 - unix/configure.ac | 1 - 2 files changed, 2 deletions(-) diff --git a/unix/configure b/unix/configure index d7c117d..4a6ee81 100755 --- a/unix/configure +++ b/unix/configure @@ -10958,7 +10958,6 @@ printf "%s\n" "static library" >&6; } echo "$LDFLAGS " | grep -q -- '-prebind ' && TCL_SHLIB_LD_EXTRAS="${TCL_SHLIB_LD_EXTRAS}"' -seg1addr 0xA000000' TCL_SHLIB_LD_EXTRAS="${TCL_SHLIB_LD_EXTRAS}"' -sectcreate __TEXT __info_plist Tcl-Info.plist' EXTRA_TCLSH_LIBS='-sectcreate __TEXT __info_plist Tclsh-Info.plist' - EXTRA_APP_CC_SWITCHES='-mdynamic-no-pic' ac_config_files="$ac_config_files Tcl-Info.plist:../macosx/Tcl-Info.plist.in Tclsh-Info.plist:../macosx/Tclsh-Info.plist.in" TCL_YEAR="`date +%Y`" diff --git a/unix/configure.ac b/unix/configure.ac index b824ede..335c5a2 100644 --- a/unix/configure.ac +++ b/unix/configure.ac @@ -814,7 +814,6 @@ if test "`uname -s`" = "Darwin" ; then echo "$LDFLAGS " | grep -q -- '-prebind ' && TCL_SHLIB_LD_EXTRAS="${TCL_SHLIB_LD_EXTRAS}"' -seg1addr 0xA000000' TCL_SHLIB_LD_EXTRAS="${TCL_SHLIB_LD_EXTRAS}"' -sectcreate __TEXT __info_plist Tcl-Info.plist' EXTRA_TCLSH_LIBS='-sectcreate __TEXT __info_plist Tclsh-Info.plist' - EXTRA_APP_CC_SWITCHES='-mdynamic-no-pic' AC_CONFIG_FILES([Tcl-Info.plist:../macosx/Tcl-Info.plist.in Tclsh-Info.plist:../macosx/Tclsh-Info.plist.in]) TCL_YEAR="`date +%Y`" fi -- cgit v0.12 From 5d92b3dc112a0525e4c00cba1b4b9e9b5c29425d Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 9 Dec 2021 14:46:41 +0000 Subject: TIP #613: New INDEX_NULL_OK flag for Tcl_GetIndexFromObj*() --- doc/GetIndex.3 | 6 ++++-- generic/tcl.h | 3 +++ generic/tclIndexObj.c | 20 +++++++++++++++----- generic/tclTest.c | 17 ++++++++++------- tests/indexObj.test | 4 ++++ 5 files changed, 36 insertions(+), 14 deletions(-) diff --git a/doc/GetIndex.3 b/doc/GetIndex.3 index a788848..1af1663 100644 --- a/doc/GetIndex.3 +++ b/doc/GetIndex.3 @@ -54,7 +54,7 @@ Null-terminated string describing what is being looked up, such as .AP int flags in OR-ed combination of bits providing additional information for operation. The only bits that are currently defined are \fBTCL_EXACT\fR -and \fBTCL_INDEX_TEMP_TABLE\fR. +, \fBTCL_INDEX_TEMP_TABLE\fR, and \fBTCL_INDEX_NULL_OK\fR. .AP int *indexPtr out The index of the string in \fItablePtr\fR that matches the value of \fIobjPtr\fR is returned here. @@ -91,7 +91,9 @@ operation. Note: \fBTcl_GetIndexFromObj\fR assumes that the entries in \fItablePtr\fR are static: they must not change between invocations. This caching mechanism can be disallowed by specifying the \fBTCL_INDEX_TEMP_TABLE\fR flag. -If the value of \fIobjPtr\fR is the empty string, +If the \fBTCL_INDEX_NULL_OK\fR flag was specified, objPtr is allowed +to be NULL or the empty string. The resulting index is -1. +Otherwise, if the value of \fIobjPtr\fR is the empty string, \fBTcl_GetIndexFromObj\fR will treat it as a non-matching value and return \fBTCL_ERROR\fR. .PP diff --git a/generic/tcl.h b/generic/tcl.h index 346b79c..b82cf0a 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -979,10 +979,13 @@ typedef struct Tcl_DString { * TCL_EXACT disallows abbreviated strings. * TCL_INDEX_TEMP_TABLE disallows caching of lookups. A possible use case is * a table that will not live long enough to make it worthwhile. + * TCL_INDEX_NULL_OK allows the empty string or NULL to return TCL_OK. + * The returned value will be -1; */ #define TCL_EXACT 1 #define TCL_INDEX_TEMP_TABLE 2 +#define TCL_INDEX_NULL_OK 4 /* *---------------------------------------------------------------------------- diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index c2812ea..e9c453a 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -261,7 +261,7 @@ Tcl_GetIndexFromObjStruct( int offset, /* The number of bytes between entries */ const char *msg, /* Identifying word to use in error * messages. */ - int flags, /* 0 or TCL_EXACT */ + int flags, /* 0, TCL_EXACT, TCL_INDEX_TEMP_TABLE or TCL_INDEX_NULL_OK */ int *indexPtr) /* Place to store resulting integer index. */ { int index, idx, numAbbrev; @@ -280,7 +280,10 @@ Tcl_GetIndexFromObjStruct( * See if there is a valid cached result from a previous lookup. */ - if (!(flags & TCL_INDEX_TEMP_TABLE)) { + if (!objPtr && (flags & TCL_INDEX_NULL_OK)) { + *indexPtr = -1; + return TCL_OK; + } else if (objPtr && !(flags & TCL_INDEX_TEMP_TABLE)) { irPtr = TclFetchInternalRep(objPtr, &indexType); if (irPtr) { indexRep = (IndexRep *)irPtr->twoPtrValue.ptr1; @@ -296,10 +299,14 @@ Tcl_GetIndexFromObjStruct( * abbreviations unless TCL_EXACT is set in flags. */ - key = TclGetString(objPtr); + key = objPtr ? TclGetString(objPtr) : ""; index = -1; numAbbrev = 0; + if (!*key && (flags & TCL_INDEX_NULL_OK)) { + *indexPtr = -1; + return TCL_OK; + } /* * Scan the table looking for one of: * - An exact match (always preferred) @@ -344,7 +351,7 @@ Tcl_GetIndexFromObjStruct( * operation. */ - if (!(flags & TCL_INDEX_TEMP_TABLE)) { + if (objPtr && !(flags & TCL_INDEX_TEMP_TABLE)) { irPtr = TclFetchInternalRep(objPtr, &indexType); if (irPtr) { indexRep = (IndexRep *)irPtr->twoPtrValue.ptr1; @@ -386,7 +393,7 @@ Tcl_GetIndexFromObjStruct( *entryPtr, NULL); entryPtr = NEXT_ENTRY(entryPtr, offset); while (*entryPtr != NULL) { - if (*NEXT_ENTRY(entryPtr, offset) == NULL) { + if ((*NEXT_ENTRY(entryPtr, offset) == NULL) && !(flags & TCL_INDEX_NULL_OK)) { Tcl_AppendStringsToObj(resultPtr, (count > 0 ? "," : ""), " or ", *entryPtr, NULL); } else if (**entryPtr) { @@ -395,6 +402,9 @@ Tcl_GetIndexFromObjStruct( } entryPtr = NEXT_ENTRY(entryPtr, offset); } + if ((flags & TCL_INDEX_NULL_OK)) { + Tcl_AppendStringsToObj(resultPtr, ", or \"\"", NULL); + } } Tcl_SetObjResult(interp, resultPtr); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", msg, key, NULL); diff --git a/generic/tclTest.c b/generic/tclTest.c index 46a1459..e18283d 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -6285,17 +6285,20 @@ TestGetIndexFromObjStructObjCmd( const char *const ary[] = { "a", "b", "c", "d", "e", "f", NULL, NULL }; - int idx,target; + int idx,target, flags = 0; - if (objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "argument targetvalue"); + if (objc != 3 && objc != 4) { + Tcl_WrongNumArgs(interp, 1, objv, "argument targetvalue ?flags?"); return TCL_ERROR; } - if (Tcl_GetIndexFromObjStruct(interp, objv[1], ary, 2*sizeof(char *), - "dummy", 0, &idx) != TCL_OK) { + if (Tcl_GetIntFromObj(interp, objv[2], &target) != TCL_OK) { return TCL_ERROR; } - if (Tcl_GetIntFromObj(interp, objv[2], &target) != TCL_OK) { + if ((objc > 3) && (Tcl_GetIntFromObj(interp, objv[3], &flags) != TCL_OK)) { + return TCL_ERROR; + } + if (Tcl_GetIndexFromObjStruct(interp, (Tcl_GetString(objv[1])[0] ? objv[1] : NULL), ary, 2*sizeof(char *), + "dummy", flags, &idx) != TCL_OK) { return TCL_ERROR; } if (idx != target) { @@ -6307,7 +6310,7 @@ TestGetIndexFromObjStructObjCmd( Tcl_AppendResult(interp, " when ", buffer, " expected", NULL); return TCL_ERROR; } - Tcl_WrongNumArgs(interp, 3, objv, NULL); + Tcl_WrongNumArgs(interp, objc, objv, NULL); return TCL_OK; } diff --git a/tests/indexObj.test b/tests/indexObj.test index bd6a2c2..c615e15 100644 --- a/tests/indexObj.test +++ b/tests/indexObj.test @@ -131,6 +131,10 @@ test indexObj-6.4 {Tcl_GetIndexFromObjStruct} testindexobj { testgetindexfromobjstruct $x 1 testgetindexfromobjstruct $x 1 } "wrong # args: should be \"testgetindexfromobjstruct c 1\"" +test indexObj-6.5 {Tcl_GetIndexFromObjStruct} testindexobj { + set x "" + testgetindexfromobjstruct $x -1 4 +} "wrong # args: should be \"testgetindexfromobjstruct {} -1 4\"" test indexObj-7.1 {Tcl_ParseArgsObjv} testparseargs { testparseargs -- cgit v0.12 From ead6c0d0543e7a3ccb5a45d79554f7852d70a1df Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 20 Dec 2021 00:58:30 +0000 Subject: Unbreak windows build caused by [066a9b81b8|this] commit --- generic/tclExecute.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index bbb7dee..765b726 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -6020,7 +6020,7 @@ TEBCresume( if (((size_t) shift < CHAR_BIT*sizeof(long)) && !((w1>0 ? w1 : ~w1) & -(1UL<<(CHAR_BIT*sizeof(long) - 1 - shift)))) { - wResult = (unsigned long)w1 << shift; + wResult = (Tcl_WideUInt)w1 << shift; goto wideResultOfArithmetic; } } -- cgit v0.12 From 48cff4f47c0343d658ad32b1763b8461e9c71114 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 20 Dec 2021 14:10:05 +0000 Subject: formatting --- generic/tclTest.c | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/generic/tclTest.c b/generic/tclTest.c index 1c9e605..7b97a65 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -6286,7 +6286,7 @@ TestGetIndexFromObjStructObjCmd( "a", "b", "c", "d", "ee", "ff", NULL, NULL }; int target, flags = 0; - signed char idx[8]; + signed char idx[8]; if (objc != 3 && objc != 4) { Tcl_WrongNumArgs(interp, 1, objv, "argument targetvalue ?flags?"); @@ -6300,15 +6300,15 @@ TestGetIndexFromObjStructObjCmd( } memset(idx, 85, sizeof(idx)); if (Tcl_GetIndexFromObjStruct(interp, (Tcl_GetString(objv[1])[0] ? objv[1] : NULL), ary, 2*sizeof(char *), - "dummy", flags, &idx[0]) != TCL_OK) { + "dummy", flags, &idx[1]) != TCL_OK) { return TCL_ERROR; } - if (idx[1] != 85) { - Tcl_AppendResult(interp, "Tcl_GetIndexFromObjStruct overwrites size", NULL); + if (idx[0] != 85 || idx[2] != 85) { + Tcl_AppendResult(interp, "Tcl_GetIndexFromObjStruct overwrites bytes near index variable", NULL); return TCL_ERROR; - } else if (idx[0] != target) { + } else if (idx[1] != target) { char buffer[64]; - sprintf(buffer, "%d", idx[0]); + sprintf(buffer, "%d", idx[1]); Tcl_AppendResult(interp, "index value comparison failed: got ", buffer, NULL); sprintf(buffer, "%d", target); -- cgit v0.12 From c220ae0d43a2ad241eeedde1f7b0c14ed90d36b2 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 7 Jan 2022 17:17:09 +0000 Subject: Fix [0386e9a967]: Bitrot in tclZlib.c --- generic/tclZipfs.c | 106 ++++++++++++++++++++++++++++++++--------------------- generic/tclZlib.c | 12 +++--- 2 files changed, 70 insertions(+), 48 deletions(-) diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c index 98a2820..d9c6712 100644 --- a/generic/tclZipfs.c +++ b/generic/tclZipfs.c @@ -36,6 +36,39 @@ #include #endif +/* + * Macros to report errors only if an interp is present. + */ + +#define ZIPFS_ERROR(interp,errstr) \ + do { \ + if (interp) { \ + Tcl_SetObjResult(interp, Tcl_NewStringObj(errstr, -1)); \ + } \ + } while (0) +#define ZIPFS_MEM_ERROR(interp) \ + do { \ + if (interp) { \ + Tcl_SetObjResult(interp, Tcl_NewStringObj( \ + "out of memory", -1)); \ + Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL); \ + } \ + } while (0) +#define ZIPFS_POSIX_ERROR(interp,errstr) \ + do { \ + if (interp) { \ + Tcl_SetObjResult(interp, Tcl_ObjPrintf( \ + "%s: %s", errstr, Tcl_PosixError(interp))); \ + } \ + } while (0) +#define ZIPFS_ERROR_CODE(interp,errcode) \ + do { \ + if (interp) { \ + Tcl_SetErrorCode(interp, "TCL", "ZIPFS", errcode, NULL); \ + } \ + } while (0) + + #ifdef HAVE_ZLIB #include "zlib.h" #include "crypt.h" @@ -125,38 +158,6 @@ #define DEFAULT_WRITE_MAX_SIZE (2 * 1024 * 1024) /* - * Macros to report errors only if an interp is present. - */ - -#define ZIPFS_ERROR(interp,errstr) \ - do { \ - if (interp) { \ - Tcl_SetObjResult(interp, Tcl_NewStringObj(errstr, -1)); \ - } \ - } while (0) -#define ZIPFS_MEM_ERROR(interp) \ - do { \ - if (interp) { \ - Tcl_SetObjResult(interp, Tcl_NewStringObj( \ - "out of memory", -1)); \ - Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL); \ - } \ - } while (0) -#define ZIPFS_POSIX_ERROR(interp,errstr) \ - do { \ - if (interp) { \ - Tcl_SetObjResult(interp, Tcl_ObjPrintf( \ - "%s: %s", errstr, Tcl_PosixError(interp))); \ - } \ - } while (0) -#define ZIPFS_ERROR_CODE(interp,errcode) \ - do { \ - if (interp) { \ - Tcl_SetErrorCode(interp, "TCL", "ZIPFS", errcode, NULL); \ - } \ - } while (0) - -/* * Windows drive letters. */ @@ -5707,6 +5708,8 @@ TclZipfs_Init( #endif /* HAVE_ZLIB */ } +#ifdef HAVE_ZLIB + #if !defined(STATIC_BUILD) static int ZipfsAppHookFindTclInit( @@ -5791,7 +5794,7 @@ ZipfsMountExitHandler( } } - + /* *------------------------------------------------------------------------- * @@ -5927,7 +5930,7 @@ TclZipfs_AppHook( return version; } -#ifndef HAVE_ZLIB +#else /* !HAVE_ZLIB */ /* *------------------------------------------------------------------------- @@ -5942,9 +5945,9 @@ TclZipfs_AppHook( int TclZipfs_Mount( Tcl_Interp *interp, /* Current interpreter. */ - const char *mountPoint, /* Mount point path. */ - const char *zipname, /* Path to ZIP file to mount. */ - const char *passwd) /* Password for opening the ZIP, or NULL if + TCL_UNUSED(const char *), /* Mount point path. */ + TCL_UNUSED(const char *), /* Path to ZIP file to mount. */ + TCL_UNUSED(const char *)) /* Password for opening the ZIP, or NULL if * the ZIP is unprotected. */ { ZIPFS_ERROR(interp, "no zlib available"); @@ -5955,10 +5958,10 @@ TclZipfs_Mount( int TclZipfs_MountBuffer( Tcl_Interp *interp, /* Current interpreter. NULLable. */ - const char *mountPoint, /* Mount point path. */ - unsigned char *data, - size_t datalen, - int copy) + TCL_UNUSED(const char *), /* Mount point path. */ + TCL_UNUSED(unsigned char *), + TCL_UNUSED(size_t), + TCL_UNUSED(int)) { ZIPFS_ERROR(interp, "no zlib available"); ZIPFS_ERROR_CODE(interp, "NO_ZLIB"); @@ -5968,12 +5971,31 @@ TclZipfs_MountBuffer( int TclZipfs_Unmount( Tcl_Interp *interp, /* Current interpreter. */ - const char *mountPoint) /* Mount point path. */ + TCL_UNUSED(const char *)) /* Mount point path. */ { ZIPFS_ERROR(interp, "no zlib available"); ZIPFS_ERROR_CODE(interp, "NO_ZLIB"); return TCL_ERROR; } + +const char * +TclZipfs_AppHook( + TCL_UNUSED(int *), /*argcPtr*/ +#ifdef _WIN32 + TCL_UNUSED(WCHAR ***)) /* argvPtr */ +#else /* !_WIN32 */ + TCL_UNUSED(char ***)) /* Pointer to argv */ +#endif /* _WIN32 */ +{ + return NULL; +} + +Tcl_Obj * +TclZipfs_TclLibrary(void) +{ + return NULL; +} + #endif /* !HAVE_ZLIB */ /* diff --git a/generic/tclZlib.c b/generic/tclZlib.c index c9bc77f..daf2a91 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -4072,18 +4072,18 @@ Tcl_ZlibInflate( unsigned int Tcl_ZlibCRC32( - unsigned int crc, - const char *buf, - int len) + TCL_UNUSED(unsigned int), + TCL_UNUSED(const unsigned char *), + TCL_UNUSED(int)) { return 0; } unsigned int Tcl_ZlibAdler32( - unsigned int adler, - const char *buf, - int len) + TCL_UNUSED(unsigned int), + TCL_UNUSED(const unsigned char *), + TCL_UNUSED(int)) { return 0; } -- cgit v0.12 From 2161463b5bc87cbef712465067c0b4fde52a699d Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 9 Jan 2022 16:54:08 +0000 Subject: Rename "testConstraint nodep" to "testConstraint deprecated", making it the same as in Tk --- tests/info.test | 2 +- tests/regexp.test | 2 +- tests/regexpComp.test | 2 +- tests/string.test | 8 ++++---- tests/stringObj.test | 8 ++++---- tests/tcltests.tcl | 2 +- 6 files changed, 12 insertions(+), 12 deletions(-) diff --git a/tests/info.test b/tests/info.test index 46f85e7..c17588f 100644 --- a/tests/info.test +++ b/tests/info.test @@ -101,7 +101,7 @@ test info-2.5 {info body option, returning bytecompiled bodies} -body { # Fix for problem tested for in info-2.5 caused problems when # procedure body had no string rep (i.e. was not yet bytecode) # causing an empty string to be returned [Bug #545644] -test info-2.6 {info body option, returning list bodies} nodep { +test info-2.6 {info body option, returning list bodies} deprecated { proc foo args [list subst bar] list [string bytelength [info body foo]] \ [foo; string bytelength [info body foo]] diff --git a/tests/regexp.test b/tests/regexp.test index a44f2e3..f0f05a0 100644 --- a/tests/regexp.test +++ b/tests/regexp.test @@ -765,7 +765,7 @@ test regexp-19.2 {regsub null replacement} { string equal $result $expected } 1 -test regexp-20.1 {regsub shared object shimmering} -constraints nodep -body { +test regexp-20.1 {regsub shared object shimmering} -constraints deprecated -body { # Bug #461322 set a abcdefghijklmnopqurstuvwxyz set b $a diff --git a/tests/regexpComp.test b/tests/regexpComp.test index e78c0df..a556b7a 100644 --- a/tests/regexpComp.test +++ b/tests/regexpComp.test @@ -793,7 +793,7 @@ test regexpComp-19.1 {regsub null replacement} { } } "\0a\0hel\0a\0lo\0a\0 14" -test regexpComp-20.1 {regsub shared object shimmering} nodep { +test regexpComp-20.1 {regsub shared object shimmering} deprecated { evalInProc { # Bug #461322 set a abcdefghijklmnopqurstuvwxyz diff --git a/tests/string.test b/tests/string.test index 6750a5c..7da50e9 100644 --- a/tests/string.test +++ b/tests/string.test @@ -1036,16 +1036,16 @@ test string-7.16.$noComp {string last, start index} { run {string last Üa ÜadÜad end-1} } 3 -test string-8.1.$noComp {string bytelength} nodep { +test string-8.1.$noComp {string bytelength} deprecated { list [catch {run {string bytelength}} msg] $msg } {1 {wrong # args: should be "string bytelength string"}} -test string-8.2.$noComp {string bytelength} nodep { +test string-8.2.$noComp {string bytelength} deprecated { list [catch {run {string bytelength a b}} msg] $msg } {1 {wrong # args: should be "string bytelength string"}} -test string-8.3.$noComp {string bytelength} nodep { +test string-8.3.$noComp {string bytelength} deprecated { run {string bytelength "\xC7"} } 2 -test string-8.4.$noComp {string bytelength} nodep { +test string-8.4.$noComp {string bytelength} deprecated { run {string b ""} } 0 diff --git a/tests/stringObj.test b/tests/stringObj.test index 4402185..abe02b2 100644 --- a/tests/stringObj.test +++ b/tests/stringObj.test @@ -455,19 +455,19 @@ test stringObj-15.4 {Tcl_Append*ToObj: self appends} testobj { teststringobj set 1 foo teststringobj appendself 1 3 } foo -test stringObj-15.5 {Tcl_Append*ToObj: self appends} {testobj tip389 nodep} { +test stringObj-15.5 {Tcl_Append*ToObj: self appends} {testobj tip389 deprecated} { teststringobj set 1 foo teststringobj appendself2 1 0 } foofoo -test stringObj-15.6 {Tcl_Append*ToObj: self appends} {testobj tip389 nodep} { +test stringObj-15.6 {Tcl_Append*ToObj: self appends} {testobj tip389 deprecated} { teststringobj set 1 foo teststringobj appendself2 1 1 } foooo -test stringObj-15.7 {Tcl_Append*ToObj: self appends} {testobj tip389 nodep} { +test stringObj-15.7 {Tcl_Append*ToObj: self appends} {testobj tip389 deprecated} { teststringobj set 1 foo teststringobj appendself2 1 2 } fooo -test stringObj-15.8 {Tcl_Append*ToObj: self appends} {testobj tip389 nodep} { +test stringObj-15.8 {Tcl_Append*ToObj: self appends} {testobj tip389 deprecated} { teststringobj set 1 foo teststringobj appendself2 1 3 } foo diff --git a/tests/tcltests.tcl b/tests/tcltests.tcl index 61076f5..cc0d6a7 100644 --- a/tests/tcltests.tcl +++ b/tests/tcltests.tcl @@ -3,7 +3,7 @@ package require tcltest 2.5 namespace import ::tcltest::* testConstraint exec [llength [info commands exec]] -testConstraint nodep [expr {![tcl::build-info no-deprecate]}] +testConstraint deprecated [expr {![tcl::build-info no-deprecate]}] testConstraint debug [tcl::build-info debug] testConstraint purify [tcl::build-info purify] testConstraint debugpurify [ -- cgit v0.12 From c513699e2c1d661da77c76813d7bdac494bfae91 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 14 Jan 2022 15:44:02 +0000 Subject: Fix [b241e4ccc0]: Error while building with Tcl 8.7a5... --- generic/tclTomMathDecls.h | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/generic/tclTomMathDecls.h b/generic/tclTomMathDecls.h index 1b2c05f..8d12adf 100644 --- a/generic/tclTomMathDecls.h +++ b/generic/tclTomMathDecls.h @@ -167,11 +167,11 @@ MODULE_SCOPE mp_err TclBN_mp_set_int(mp_int *a, unsigned long b); #define s_mp_toom_sqr TclBN_mp_toom_sqr #endif /* !TCL_WITH_EXTERNAL_TOMMATH */ -#define mp_init_set_int(a,b) (MP_DEPRECATED_PRAGMA("replaced by mp_init_ul") TclBN_mp_init_u64(a,(unsigned int)(b))) -#define mp_set_int(a,b) (MP_DEPRECATED_PRAGMA("replaced by mp_set_ul") (TclBN_mp_set_u64((a),((unsigned int)(b))),MP_OKAY)) -#define mp_set_long(a,b) (MP_DEPRECATED_PRAGMA("replaced by mp_set_ul") (TclBN_mp_set_u64((a),(long)(b)),MP_OKAY)) -#define mp_set_long_long(a,b) (MP_DEPRECATED_PRAGMA("replaced by mp_set_u64") (TclBN_mp_set_u64((a),(b)),MP_OKAY)) -#define mp_unsigned_bin_size(mp) (MP_DEPRECATED_PRAGMA("replaced by mp_ubin_size") (int)TclBN_mp_ubin_size(mp)) +#define mp_init_set_int(a,b) (MP_DEPRECATED_PRAGMA("replaced by mp_init_ul") mp_init_u64(a,(unsigned int)(b))) +#define mp_set_int(a,b) (MP_DEPRECATED_PRAGMA("replaced by mp_set_ul") (mp_set_u64((a),((unsigned int)(b))),MP_OKAY)) +#define mp_set_long(a,b) (MP_DEPRECATED_PRAGMA("replaced by mp_set_ul") (mp_set_u64((a),(long)(b)),MP_OKAY)) +#define mp_set_long_long(a,b) (MP_DEPRECATED_PRAGMA("replaced by mp_set_u64") (mp_set_u64((a),(b)),MP_OKAY)) +#define mp_unsigned_bin_size(mp) (MP_DEPRECATED_PRAGMA("replaced by mp_ubin_size") (int)mp_ubin_size(mp)) #undef TCL_STORAGE_CLASS #ifdef BUILD_tcl -- cgit v0.12 From 9bcfb6703d6eaa02bfcaad401aa83ce48309d4a1 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 14 Jan 2022 22:34:06 +0000 Subject: Proposed fix for [6474fbd934]: Tcl 8.7a5: why utf-8 is different? --- generic/tclEncoding.c | 3 --- tests/encoding.test | 20 ++++++++++---------- 2 files changed, 10 insertions(+), 13 deletions(-) diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 57c6148..037beed 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -2323,9 +2323,6 @@ UtfToUtfProc( src = saveSrc; break; } - if (!(flags & TCL_ENCODING_MODIFIED)) { - ch = 0xFFFD; - } cesu8: *dst++ = (char) (((ch >> 12) | 0xE0) & 0xEF); *dst++ = (char) (((ch >> 6) | 0x80) & 0xBF); diff --git a/tests/encoding.test b/tests/encoding.test index c6f4e02..75e0dcc 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -349,61 +349,61 @@ test encoding-15.6 {UtfToUtfProc emoji character output} { set y [encoding convertto utf-8 \uDE02\uD83D\uDE02\uD83D] binary scan $y H* z list [string length $y] $z -} {10 efbfbdf09f9882efbfbd} +} {10 edb882f09f9882eda0bd} test encoding-15.7 {UtfToUtfProc emoji character output} { set x \uDE02\uD83D\uD83D set y [encoding convertto utf-8 \uDE02\uD83D\uD83D] binary scan $y H* z list [string length $x] [string length $y] $z -} {3 9 efbfbdefbfbdefbfbd} +} {3 9 edb882eda0bdeda0bd} test encoding-15.8 {UtfToUtfProc emoji character output} { set x \uDE02\uD83Dé set y [encoding convertto utf-8 \uDE02\uD83Dé] binary scan $y H* z list [string length $x] [string length $y] $z -} {3 8 efbfbdefbfbdc3a9} +} {3 8 edb882eda0bdc3a9} test encoding-15.9 {UtfToUtfProc emoji character output} { set x \uDE02\uD83DX set y [encoding convertto utf-8 \uDE02\uD83DX] binary scan $y H* z list [string length $x] [string length $y] $z -} {3 7 efbfbdefbfbd58} +} {3 7 edb882eda0bd58} test encoding-15.10 {UtfToUtfProc high surrogate character output} { set x \uDE02é set y [encoding convertto utf-8 \uDE02é] binary scan $y H* z list [string length $x] [string length $y] $z -} {2 5 efbfbdc3a9} +} {2 5 edb882c3a9} test encoding-15.11 {UtfToUtfProc low surrogate character output} { set x \uDA02é set y [encoding convertto utf-8 \uDA02é] binary scan $y H* z list [string length $x] [string length $y] $z -} {2 5 efbfbdc3a9} +} {2 5 eda882c3a9} test encoding-15.12 {UtfToUtfProc high surrogate character output} { set x \uDE02Y set y [encoding convertto utf-8 \uDE02Y] binary scan $y H* z list [string length $x] [string length $y] $z -} {2 4 efbfbd59} +} {2 4 edb88259} test encoding-15.13 {UtfToUtfProc low surrogate character output} { set x \uDA02Y set y [encoding convertto utf-8 \uDA02Y] binary scan $y H* z list [string length $x] [string length $y] $z -} {2 4 efbfbd59} +} {2 4 eda88259} test encoding-15.14 {UtfToUtfProc high surrogate character output} { set x \uDE02 set y [encoding convertto utf-8 \uDE02] binary scan $y H* z list [string length $x] [string length $y] $z -} {1 3 efbfbd} +} {1 3 edb882} test encoding-15.15 {UtfToUtfProc low surrogate character output} { set x \uDA02 set y [encoding convertto utf-8 \uDA02] binary scan $y H* z list [string length $x] [string length $y] $z -} {1 3 efbfbd} +} {1 3 eda882} test encoding-15.16 {UtfToUtfProc: Invalid 4-byte UTF-8, see [ed29806ba]} { set x \xF0\xA0\xA1\xC2 set y [encoding convertfrom utf-8 \xF0\xA0\xA1\xC2] -- cgit v0.12 From b563c159d7f63f0a4ca1e9190ec4111d5d4908d9 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 17 Jan 2022 17:07:14 +0000 Subject: Fix merge conflict previous commit --- generic/tclBasic.c | 3 +-- generic/tclCompExpr.c | 2 -- generic/tclCompile.c | 1 - generic/tclIOUtil.c | 1 - 4 files changed, 1 insertion(+), 6 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 35fd5a9..45a430f 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -901,8 +901,7 @@ Tcl_CreateInterp(void) iPtr->activeInterpTracePtr = NULL; iPtr->assocData = NULL; iPtr->execEnvPtr = NULL; /* Set after namespaces initialized. */ - TclNewObj(iPtr->emptyObjPtr); - /* Another empty object. */ + TclNewObj(iPtr->emptyObjPtr); /* Another empty object. */ Tcl_IncrRefCount(iPtr->emptyObjPtr); #ifndef TCL_NO_DEPRECATED iPtr->resultSpace[0] = 0; diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index 8248770..23d8711 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -1880,8 +1880,6 @@ Tcl_ParseExpr( numBytes = (start ? strlen(start) : 0); } - TclNewObj(litList); - TclNewObj(funcList); code = ParseExpr(interp, start, numBytes, &opTree, litList, funcList, exprParsePtr, 1 /* parseOnly */); Tcl_DecrRefCount(funcList); diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 650a6d4..f7479f0 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -2044,7 +2044,6 @@ CompileCommandTokens( int startCodeOffset = envPtr->codeNext - envPtr->codeStart; int depth = TclGetStackDepth(envPtr); - TclNewObj(cmdObj); assert (parsePtr->numWords > 0); /* Pre-Compile */ diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index 6b1dc3c..87e60c3 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -3775,7 +3775,6 @@ Tcl_FSListVolumes(void) FilesystemRecord *fsRecPtr; Tcl_Obj *resultPtr; - TclNewObj(resultPtr); /* * Call each "listVolumes" function of each registered filesystem in * succession. A non-NULL return value indicates the particular function -- cgit v0.12 From d0b286927306af8bde7031529ad180eaa07dcc73 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 18 Jan 2022 23:26:20 +0000 Subject: Update documentation for Tcl_GetRange() --- doc/StringObj.3 | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/doc/StringObj.3 b/doc/StringObj.3 index 772073e..90b53f2 100644 --- a/doc/StringObj.3 +++ b/doc/StringObj.3 @@ -111,10 +111,12 @@ If negative, all characters up to the first null character are used. The index of the Unicode character to return. .AP int first in The index of the first Unicode character in the Unicode range to be -returned as a new value. +returned as a new value. If negative, behave the same as if the +value was 0. .AP int last in The index of the last Unicode character in the Unicode range to be -returned as a new value. +returned as a new value. If negative, take all characters up to +the last one available. .AP Tcl_Obj *objPtr in/out Points to a value to manipulate. .AP Tcl_Obj *appendObjPtr in -- cgit v0.12 From b97786c85dbd70fd4445f8161b205d5dbc56e844 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 19 Jan 2022 14:21:38 +0000 Subject: (partial) fix for [https://core.tcl-lang.org/tk/tktview?name=a9929f112a|a9929f112a]. WIP --- generic/tclUtil.c | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 32721f6..86b6369 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -3647,12 +3647,15 @@ GetWideForIndex( if (numType == TCL_NUMBER_INT) { /* objPtr holds an integer in the signed wide range */ *widePtr = *(Tcl_WideInt *)cd; + if (*widePtr < -1) { + *widePtr = -1; + } return TCL_OK; } if (numType == TCL_NUMBER_BIG) { /* objPtr holds an integer outside the signed wide range */ /* Truncate to the signed wide range. */ - *widePtr = ((mp_isneg((mp_int *)cd)) ? WIDE_MIN : WIDE_MAX); + *widePtr = ((mp_isneg((mp_int *)cd)) ? -1 : WIDE_MAX); return TCL_OK; } } -- cgit v0.12 From e433c571581eae56161e5c4dc8dcae36e31d8039 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 21 Jan 2022 08:43:13 +0000 Subject: Add test-cases for Tcl_GetIntForIndex(). This reveals a minor bug --- generic/tclTest.c | 29 +++++++++++++++++++++++++++++ generic/tclUtil.c | 7 ++----- tests/indexObj.test | 47 +++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 78 insertions(+), 5 deletions(-) diff --git a/generic/tclTest.c b/generic/tclTest.c index 7ec3c41..95ef5b7 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -327,6 +327,7 @@ static Tcl_ObjCmdProc TestNumUtfCharsCmd; static Tcl_ObjCmdProc TestFindFirstCmd; static Tcl_ObjCmdProc TestFindLastCmd; static Tcl_ObjCmdProc TestHashSystemHashCmd; +static Tcl_ObjCmdProc TestGetIntForIndexCmd; static Tcl_NRPostProc NREUnwind_callback; static Tcl_ObjCmdProc TestNREUnwind; @@ -598,6 +599,8 @@ Tcltest_Init( TestFindFirstCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testfindlast", TestFindLastCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "testgetintforindex", + TestGetIntForIndexCmd, NULL, NULL); Tcl_CreateCommand(interp, "testsetplatform", TestsetplatformCmd, NULL, NULL); Tcl_CreateCommand(interp, "testsocket", TestSocketCmd, @@ -7036,6 +7039,32 @@ TestFindLastCmd( return TCL_OK; } +static int +TestGetIntForIndexCmd( + TCL_UNUSED(void *), + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + int result, endvalue; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "index endvalue"); + return TCL_ERROR; + } + + if (Tcl_GetIntFromObj(interp, objv[2], &endvalue) != TCL_OK) { + return TCL_ERROR; + } + if (Tcl_GetIntForIndex(interp, objv[1], endvalue, &result) != TCL_OK) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, Tcl_NewIntObj(result)); + return TCL_OK; +} + + + #if defined(HAVE_CPUID) || defined(_WIN32) /* *---------------------------------------------------------------------- diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 86b6369..10153fb 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -3647,15 +3647,12 @@ GetWideForIndex( if (numType == TCL_NUMBER_INT) { /* objPtr holds an integer in the signed wide range */ *widePtr = *(Tcl_WideInt *)cd; - if (*widePtr < -1) { - *widePtr = -1; - } return TCL_OK; } if (numType == TCL_NUMBER_BIG) { /* objPtr holds an integer outside the signed wide range */ /* Truncate to the signed wide range. */ - *widePtr = ((mp_isneg((mp_int *)cd)) ? -1 : WIDE_MAX); + *widePtr = ((mp_isneg((mp_int *)cd)) ? WIDE_MIN : WIDE_MAX); return TCL_OK; } } @@ -3706,7 +3703,7 @@ Tcl_GetIntForIndex( return TCL_ERROR; } if (indexPtr != NULL) { - if ((wide < 0) && (endValue > TCL_INDEX_END)) { + if ((wide < 0) && (endValue >= 0)) { *indexPtr = -1; } else if (wide > INT_MAX) { *indexPtr = INT_MAX; diff --git a/tests/indexObj.test b/tests/indexObj.test index 40418b3..9fd31b4 100644 --- a/tests/indexObj.test +++ b/tests/indexObj.test @@ -17,6 +17,7 @@ if {"::tcltest" ni [namespace children]} { catch [list package require -exact tcl::test [info patchlevel]] testConstraint testindexobj [llength [info commands testindexobj]] +testConstraint testgetintforindex [llength [info commands testgetintforindex]] testConstraint testparseargs [llength [info commands testparseargs]] test indexObj-1.1 {exact match} testindexobj { @@ -165,6 +166,52 @@ test indexObj-7.7 {Tcl_ParseArgsObjv memory management} testparseargs { testparseargs 1 2 3 4 5 6 7 8 9 0 -bool 1 2 3 4 5 6 7 8 9 0 } {1 21 {testparseargs 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0}} +test indexObj-8.1 {Tcl_GetIntForIndex integer} testgetintforindex { + testgetintforindex 0 0 +} 0 +test indexObj-8.2 {Tcl_GetIntForIndex integer} testgetintforindex { + testgetintforindex -1 0 +} -1 +test indexObj-8.3 {Tcl_GetIntForIndex integer} testgetintforindex { + testgetintforindex -2 0 +} -1 +test indexObj-8.4 {Tcl_GetIntForIndex INT_MAX} testgetintforindex { + testgetintforindex 2147483647 0 +} 2147483647 +test indexObj-8.5 {Tcl_GetIntForIndex INT_MAX+1} testgetintforindex { + testgetintforindex 2147483648 0 +} 2147483647 +test indexObj-8.6 {Tcl_GetIntForIndex end-1} testgetintforindex { + testgetintforindex end-1 2147483646 +} 2147483645 +test indexObj-8.7 {Tcl_GetIntForIndex end-1} testgetintforindex { + testgetintforindex end-1 2147483647 +} 2147483646 +test indexObj-8.8 {Tcl_GetIntForIndex end} testgetintforindex { + testgetintforindex end 2147483646 +} 2147483646 +test indexObj-8.9 {Tcl_GetIntForIndex end} testgetintforindex { + testgetintforindex end 2147483647 +} 2147483647 +test indexObj-8.10 {Tcl_GetIntForIndex end-1} testgetintforindex { + testgetintforindex end-1 -1 +} -2 +test indexObj-8.11 {Tcl_GetIntForIndex end-1} testgetintforindex { + testgetintforindex end-1 -2 +} -3 +test indexObj-8.12 {Tcl_GetIntForIndex end} testgetintforindex { + testgetintforindex end -1 +} -1 +test indexObj-8.13 {Tcl_GetIntForIndex end} testgetintforindex { + testgetintforindex end -2 +} -2 +test indexObj-8.14 {Tcl_GetIntForIndex end+1} testgetintforindex { + testgetintforindex end+1 -1 +} 0 +test indexObj-8.15 {Tcl_GetIntForIndex end+1} testgetintforindex { + testgetintforindex end+1 -2 +} -1 + # cleanup ::tcltest::cleanupTests return -- cgit v0.12 From 641cba82ec80d575338440d9d8bbf84f711eb12c Mon Sep 17 00:00:00 2001 From: pooryorick Date: Sat, 22 Jan 2022 14:47:29 +0000 Subject: Rewrite of documentation for [chan] --- doc/chan.n | 1106 +++++++++++++++++++++++++----------------------------------- 1 file changed, 466 insertions(+), 640 deletions(-) diff --git a/doc/chan.n b/doc/chan.n index f788bbf..aa8bbca 100644 --- a/doc/chan.n +++ b/doc/chan.n @@ -1,5 +1,6 @@ '\" '\" Copyright (c) 2005-2006 Donal K. Fellows +'\" Copyright (c) 2021 Nathan Coulter '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -8,761 +9,586 @@ .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME -chan \- Read, write and manipulate channels +chan \- Reads, writes and manipulates channels. .SH SYNOPSIS -\fBchan \fIoption\fR ?\fIarg arg ...\fR? +\fBchan \fIoperation\fR ?\fIarg arg ...\fR? .BE .SH DESCRIPTION .PP -This command provides several operations for reading from, writing to -and otherwise manipulating open channels (such as have been created -with the \fBopen\fR and \fBsocket\fR commands, or the default named -channels \fBstdin\fR, \fBstdout\fR or \fBstderr\fR which correspond to -the process's standard input, output and error streams respectively). -\fIOption\fR indicates what to do with the channel; any unique -abbreviation for \fIoption\fR is acceptable. Valid options are: -.TP -\fBchan blocked \fIchannelId\fR -. -This tests whether the last input operation on the channel called -\fIchannelId\fR failed because it would have otherwise caused the -process to block, and returns 1 if that was the case. It returns 0 -otherwise. Note that this only ever returns 1 when the channel has -been configured to be non-blocking; all Tcl channels have blocking -turned on by default. -.TP -\fBchan close \fIchannelId\fR ?\fIdirection\fR? -. -Close and destroy the channel called \fIchannelId\fR. Note that this -deletes all existing file-events registered on the channel. -If the \fIdirection\fR argument (which must be \fBread\fR or \fBwrite\fR or -any unique abbreviation of them) is present, the channel will only be -half-closed, so that it can go from being read-write to write-only or -read-only respectively. If a read-only channel is closed for reading, it is -the same as if the channel is fully closed, and respectively similar for -write-only channels. Without the \fIdirection\fR argument, the channel is -closed for both reading and writing (but only if those directions are -currently open). It is an error to close a read-only channel for writing, or a -write-only channel for reading. +\fBchan\fR provides several operations for reading from, writing to, and +otherwise manipulating channels, e.g. those created by \fBopen\fR and +\fBsocket\fR, or the default channels \fBstdin\fR, \fBstdout\fR or \fBstderr\fR +which correspond respectively to the standard input, output, and error streams +of the process. Any unique abbreviation for \fIoperation\fR is acceptable. +Available operations are: +.TP +\fBchan blocked \fIchannelName\fR +. +Returns 1 when the channel is in non-blocking mode and the last input operation +on the channel failed because it would have otherwise caused the process to +block, and 0 otherwise. Each Tcl channel is in blocking mode unless configured +otherwise. +.TP +\fBchan close \fIchannelName\fR ?\fIdirection\fR? +. +Closes and destroys the named channel, deleting any existing event handlers +established for the channel, and returns the empty string. If \fIdirection\fR is +given, it is +.QW\fBread\fR +or +.QW\fBwrite\fR +or any unique abbreviation of those words, and only that side of the channel is +closed. I.e. a read-write channel may become read-only or write-only. +Closing a read-only channel for reading, or closing a write-only channel for +writing is the same as simply closing the channel. It is an error to close a +read-only channel for writing or to close a write-only channel for reading. .RS .PP -As part of closing the channel, all buffered output is flushed to the -channel's output device (only if the channel is ceasing to be writable), any -buffered input is discarded (only if the channel is ceasing to be readable), -the underlying operating system resource is closed and \fIchannelId\fR becomes -unavailable for future use (both only if the channel is being completely -closed). -.PP -If the channel is blocking and the channel is ceasing to be writable, the -command does not return until all output is flushed. If the channel is -non-blocking and there is unflushed output, the channel remains open and the -command returns immediately; output will be flushed in the background and the -channel will be closed when all the flushing is complete. -.PP -If \fIchannelId\fR is a blocking channel for a command pipeline then -\fBchan close\fR waits for the child processes to complete. -.PP -If the channel is shared between interpreters, then \fBchan close\fR -makes \fIchannelId\fR unavailable in the invoking interpreter but has -no other effect until all of the sharing interpreters have closed the -channel. When the last interpreter in which the channel is registered -invokes \fBchan close\fR (or \fBclose\fR), the cleanup actions -described above occur. With half-closing, the half-close of the channel only -applies to the current interpreter's view of the channel until all channels -have closed it in that direction (or completely). -See the \fBinterp\fR command for a description of channel sharing. -.PP -Channels are automatically fully closed when an interpreter is destroyed and -when the process exits. Channels are switched to blocking mode, to -ensure that all output is correctly flushed before the process exits. -.PP -The command returns an empty string, and may generate an error if -an error occurs while flushing output. If a command in a command -pipeline created with \fBopen\fR returns an error, \fBchan close\fR -generates an error (similar to the \fBexec\fR command.) -.PP -Note that half-closes of sockets and command pipelines can have important side -effects because they result in a shutdown() or close() of the underlying -system resource, which can change how other processes or systems respond to -the Tcl program. +When a channel is closed for writing, any buffered output on the channel is +flushed. When a channel is closed for reading, any buffered input is discarded. +When a channel is destroyed the underlying resource is closed and the channel +is thereafter unavailable. +.PP +\fBchan close\fR fully flushes any output before closing the write side of a +channel unless it is non-blocking mode, where it returns immediately and the +channel is flushed in the background before finally being closed. +.PP +\fBchan close\fR may return an error if an error occurs while flushing +output. If a process in a command pipeline created by \fBopen\fR returns an +error, \fBchan close\fR generates an error in the same manner as \fBexec\fR. +.PP +Closing one side of a socket or command pipeline may lead to the shutdown() or +close() of the underlying system resource, leading to a reaction from whatever +is on the other side of the pipeline or socket. +.PP +If the channel for a command pipeline is in blocking mode, \fBchan close\fR +waits for the connected processes to complete. +.PP +\fBchan close\fR only affects the current interpreter. If the channel is open +in any other interpreter, its state is unchanged there. See \fBinterp\fR for a +description of channel sharing. +.PP +When the last interpreter sharing a channel is destroyed, the channel is +switched to blocking mode and fully flushed and then closed. .RE .TP -\fBchan configure \fIchannelId\fR ?\fIoptionName\fR? ?\fIvalue\fR? ?\fIoptionName value\fR?... +\fBchan configure \fIchannelName\fR ?\fIoptionName\fR? ?\fIvalue\fR? ?\fIoptionName value\fR?... . -Query or set the configuration options of the channel named -\fIchannelId\fR. +Configures or reports the configuration of \fIchannelName\fR. .RS .PP -If no \fIoptionName\fR or \fIvalue\fR arguments are supplied, the -command returns a list containing alternating option names and values -for the channel. If \fIoptionName\fR is supplied but no \fIvalue\fR -then the command returns the current value of the given option. If -one or more pairs of \fIoptionName\fR and \fIvalue\fR are supplied, -the command sets each of the named options to the corresponding -\fIvalue\fR; in this case the return value is an empty string. -.PP -The options described below are supported for all channels. In -addition, each channel type may add options that only it supports. See -the manual entry for the command that creates each type of channel -for the options supported by that specific type of channel. For -example, see the manual entry for the \fBsocket\fR command for additional -options for sockets, and the \fBopen\fR command for additional options for -serial devices. +If no \fIoptionName\fR or \fIvalue\fR arguments are given, +\fBchan configure\fR returns a dictionary of option names and +values for the channel. If \fIoptionName\fR is supplied without a \fIvalue\fR, +\fBchan configure\fR returns the current value of the named option. If one or +more pairs of \fIoptionName\fR and \fIvalue\fR are supplied, +\fBchan configure\fR sets each of the named options to the corresponding +\fIvalue\fR and returns the empty string. +.PP +The options described below are supported for all channels. Each type of +channel may provide additional options. Those options are described in the +relevant documentation. For example, additional options are documented for +\fBsocket\fR, and also for serial devices at \fBopen\fR. .TP \fB\-blocking\fR \fIboolean\fR . -The \fB\-blocking\fR option determines whether I/O operations on the -channel can cause the process to block indefinitely. The value of the -option must be a proper boolean value. Channels are normally in -blocking mode; if a channel is placed into non-blocking mode it will -affect the operation of the \fBchan gets\fR, \fBchan read\fR, \fBchan -puts\fR, \fBchan flush\fR, and \fBchan close\fR commands; see the -documentation for those commands for details. For non-blocking mode to -work correctly, the application must be using the Tcl event loop -(e.g. by calling \fBTcl_DoOneEvent\fR or invoking the \fBvwait\fR -command). +If \fB\-blocking\fR is set to \fBtrue\fR, which is the default, reading from or +writing to the channel may cause the process to block indefinitely. Otherwise, +operations such as \fBchan gets\fR, \fBchan read\fR, \fBchan puts\fR, \fBchan +flush\fR, and \fBchan close\fR take care not to block. Non-blocking mode in +generally requires that the event loop is entered, e.g. by calling +\fBTcl_DoOneEvent\fR or \fBvwait\fR or by using Tk, to give Tcl a chance to +process events on the channel. .TP \fB\-buffering\fR \fInewValue\fR . -If \fInewValue\fR is \fBfull\fR then the I/O system will buffer output -until its internal buffer is full or until the \fBchan flush\fR -command is invoked. If \fInewValue\fR is \fBline\fR, then the I/O -system will automatically flush output for the channel whenever a -newline character is output. If \fInewValue\fR is \fBnone\fR, the I/O -system will flush automatically after every output operation. The -default is for \fB\-buffering\fR to be set to \fBfull\fR except for -channels that connect to terminal-like devices; for these channels the -initial setting is \fBline\fR. Additionally, \fBstdin\fR and -\fBstdout\fR are initially set to \fBline\fR, and \fBstderr\fR is set -to \fBnone\fR. +If \fInewValue\fR is \fBfull\fR, which is the default, output is buffered +until the internal buffer is full or until \fBchan flush\fR is called. If +\fInewValue\fR is \fBline\fR, output is flushed each time a end-of-line +character is written. If \fInewValue\fR is \fBnone\fR, output is flushed after +every output operation. For \fBstdin\fR, \fBstdout\fR, and channels that +connect to terminal-like devices, the default value is \fBline\fR. For +\fBstderr\fR the default value is \fBnone\fR. .TP \fB\-buffersize\fR \fInewSize\fR . -\fINewvalue\fR must be an integer; its value is used to set the size -of buffers, in bytes, subsequently allocated for this channel to store -input or output. \fINewvalue\fR must be a number of no more than one -million, allowing buffers of up to one million bytes in size. -.TP -\fB\-encoding\fR \fIname\fR -. -This option is used to specify the encoding of the channel as one of -the named encodings returned by \fBencoding names\fR or the special -value \fBbinary\fR, so that the data can be converted to and from -Unicode for use in Tcl. For instance, in order for Tcl to read -characters from a Japanese file in \fBshiftjis\fR and properly process -and display the contents, the encoding would be set to \fBshiftjis\fR. -Thereafter, when reading from the channel, the bytes in the Japanese -file would be converted to Unicode as they are read. Writing is also -supported \- as Tcl strings are written to the channel they will -automatically be converted to the specified encoding on output. +\fInewSize\fR, an integer no greater than one million, is the size in bytes of +any input or output buffers subsequently allocated for this channel. +.TP +\fB\-encoding\fR ?\fIname\fR? +. +Sets the encoding of the channel. \fIname\fR is either one of the names +returned by \fBencoding names\fR, or +.QW \fBbinary\fR +\&. Input is converted from the encoding into Unicode, and output is converted +from Unicode to the encoding. .RS .PP -If a file contains pure binary data (for instance, a JPEG image), the -encoding for the channel should be configured to be \fBbinary\fR. Tcl -will then assign no interpretation to the data in the file and simply -read or write raw bytes. The Tcl \fBbinary\fR command can be used to -manipulate this byte-oriented data. It is usually better to set the -\fB\-translation\fR option to \fBbinary\fR when you want to transfer -binary data, as this turns off the other automatic interpretations of -the bytes in the stream as well. -.PP -The default encoding for newly opened channels is the same platform- -and locale-dependent system encoding used for interfacing with the -operating system, as returned by \fBencoding system\fR. +\fBbinary\fR is an alias for \fBiso8859-1\fR: Each byte read from the +channel becomes the Unicode character having the same value as that byte, and +each character written to the channel becomes a single byte in the output, +allowing Tcl to work seamlessly with binary data as long as each "character" in +the data remains in the range of 0 to 255 so that there is no distinction between +binary data and text. For example, A JPEG image can be read from a +\fBbinary\fR channel, manipulated, and then written back to a \fBbinary\fR +channel. + +For working with binary data \fB\-translation binary\fR is usually used +instead, as it sets the encoding to \fBbinary\fR and also disables other +translations on the channel. +.PP +The encoding of a new channel is the value of \fBencoding system\fR, +which returns the platform- and locale-dependent system encoding used to +interface with the operating system, .RE .TP \fB\-eofchar\fR \fIchar\fR .TP \fB\-eofchar\fR \fB{\fIinChar outChar\fB}\fR . -This option supports DOS file systems that use Control-z (\ex1A) as an -end of file marker. If \fIchar\fR is not an empty string, then this -character signals end-of-file when it is encountered during input. -For output, the end-of-file character is output when the channel is -closed. If \fIchar\fR is the empty string, then there is no special -end of file character marker. For read-write channels, a two-element -list specifies the end of file marker for input and output, -respectively. As a convenience, when setting the end-of-file -character for a read-write channel you can specify a single value that -will apply to both reading and writing. When querying the end-of-file -character of a read-write channel, a two-element list will always be -returned. The default value for \fB\-eofchar\fR is the empty string -in all cases except for files under Windows. In that case the -\fB\-eofchar\fR is Control-z (\ex1A) for reading and the empty string -for writing. -The acceptable range for \fB\-eofchar\fR values is \ex01 - \ex7f; -attempting to set \fB\-eofchar\fR to a value outside of this range will -generate an error. -.TP -\fB\-translation\fR \fImode\fR -.TP -\fB\-translation\fR \fB{\fIinMode outMode\fB}\fR -. -In Tcl scripts the end of a line is always represented using a single -newline character (\en). However, in actual files and devices the end -of a line may be represented differently on different platforms, or -even for different devices on the same platform. For example, under -UNIX newlines are used in files, whereas carriage-return-linefeed -sequences are normally used in network connections. On input (i.e., -with \fBchan gets\fR and \fBchan read\fR) the Tcl I/O system -automatically translates the external end-of-line representation into -newline characters. Upon output (i.e., with \fBchan puts\fR), the I/O -system translates newlines to the external end-of-line representation. -The default translation mode, \fBauto\fR, handles all the common cases -automatically, but the \fB\-translation\fR option provides explicit -control over the end of line translations. +\fIchar\fR signals the end of the data when it is encountered in the input. +For output, the character is added when the channel is closed. If \fIchar\fR +is the empty string, there is no special character that marks the end of the +data. For read-write channels, one end-of-file character for input and another +for output may be given. When only one end-of-file character is given it is +applied to both input and output. For a read-write channel two values are +returned even if they are are identical. + +The default value is the empty string, except that under Windows the default +value for reading is Control-z (\ex1A). The acceptable range is \ex01 - +\ex7f. A value outside this range results in an error. +.TP +\fB\-translation\fR \fItranslation\fR +.TP +\fB\-translation\fR \fB{\fIinTranslation outTranslation\fB}\fR +. +In Tcl a single line feed (\en) represents the end of a line. However, +at the destination the end of a line may be represented differently on +different platforms, or even for different devices on the same platform. For +example, under UNIX line feed is used in files and a +carriage-return-linefeed sequence is normally used in network connections. +Therefore, on input, e.g. with \fBchan gets\fR and \fBchan read\fR, each +external end-of-line character is translated into a line feed. On +output, e.g. with \fBchan puts\fR, each line feed is translated to the external +end-of-line character. The default translation, \fBauto\fR, handles all the common +cases, and \fB\-translation\fR provides explicit control over the end-of-line +character. .RS .PP -The value associated with \fB\-translation\fR is a single item for -read-only and write-only channels. The value is a two-element list for -read-write channels; the read translation mode is the first element of -the list, and the write translation mode is the second element. As a -convenience, when setting the translation mode for a read-write channel -you can specify a single value that will apply to both reading and -writing. When querying the translation mode of a read-write channel, a -two-element list will always be returned. The following values are -currently supported: +Returns the input translation for a read-only channel, the output translation +for a write-only channel, and both the input translation and the the output +translation for a read-write channel. When two translations are given, they +are the input and output translation, respectively. When only one translation +is given for a read-write channel, it is the translation for both input and +output. The following values are currently supported: .TP \fBauto\fR . -As the input translation mode, \fBauto\fR treats any of newline -(\fBlf\fR), carriage return (\fBcr\fR), or carriage return followed by -a newline (\fBcrlf\fR) as the end of line representation. The end of -line representation can even change from line-to-line, and all cases -are translated to a newline. As the output translation mode, -\fBauto\fR chooses a platform specific representation; for sockets on -all platforms Tcl chooses \fBcrlf\fR, for all Unix flavors, it chooses -\fBlf\fR, and for the various flavors of Windows it chooses -\fBcrlf\fR. The default setting for \fB\-translation\fR is \fBauto\fR -for both input and output. +The default. For input each occurrence of a line feed (\fBlf\fR), carriage +return (\fBcr\fR), or carriage return followed by a line feed (\fBcrlf\fR) is +translated into a line feed. For output, each line feed is translated into a +platform-specific representation: For all Unix variants it is \fBlf\fR, and +for all Windows variants it is \fBcrlf\fR, except that for sockets on all +platforms it is \fBcrlf\fR for both input and output. .TP \fBbinary\fR . -No end-of-line translations are performed. This is nearly identical -to \fBlf\fR mode, except that in addition \fBbinary\fR mode also sets -the end-of-file character to the empty string (which disables it) and -sets the encoding to \fBbinary\fR (which disables encoding filtering). -See the description of \fB\-eofchar\fR and \fB\-encoding\fR for more -information. +Like \fBlf\fR, no end-of-line translation is performed, but in addition, +\fB\-eofchar\fR is set to the empty string to disable it, and \fB\-encoding\fR +is set to \fBbinary\fR. With this one setting, a channel is fully configured +for binary input and output. .TP \fBcr\fR . -The end of a line in the underlying file or device is represented by a -single carriage return character. As the input translation mode, -\fBcr\fR mode converts carriage returns to newline characters. As the -output translation mode, \fBcr\fR mode translates newline characters -to carriage returns. +The end of a line is represented in the external data by a single carriage +return character. For input, each carriage return is translated to a line +feed, and for output each line feed character is translated to a carriage +return. .TP \fBcrlf\fR . -The end of a line in the underlying file or device is represented by a -carriage return character followed by a linefeed character. As the -input translation mode, \fBcrlf\fR mode converts -carriage-return-linefeed sequences to newline characters. As the -output translation mode, \fBcrlf\fR mode translates newline characters -to carriage-return-linefeed sequences. This mode is typically used on -Windows platforms and for network connections. +The end of a line is represented in the external data by a carriage return +character followed by a line feed. For input, each carriage-return-linefeed +sequence is translated to a line feed. For output, each line feed is +translated to a carriage-return-linefeed sequence. This translation is +typically used for network connections, and also on Windows systems. .TP \fBlf\fR . -The end of a line in the underlying file or device is represented by a -single newline (linefeed) character. In this mode no translations -occur during either input or output. This mode is typically used on -UNIX platforms. +The end of a line in the external data is represented by a line feed so no +translations occur during either input or output. This translation is +typically used on UNIX platforms, .RE .RE .TP \fBchan copy \fIinputChan outputChan\fR ?\fB\-size \fIsize\fR? ?\fB\-command \fIcallback\fR? . -Copy data from the channel \fIinputChan\fR, which must have been -opened for reading, to the channel \fIoutputChan\fR, which must have -been opened for writing. The \fBchan copy\fR command leverages the -buffering in the Tcl I/O system to avoid extra copies and to avoid -buffering too much data in main memory when copying large files to -slow destinations like network sockets. +Copies data from \fIinputChan\fR to \fIoutputChan\fR, leveraging internal +buffers to avoid extra copies and to avoid buffering too much data in main +memory when copying large files to slow destinations like network sockets. .RS .PP -The \fBchan copy\fR command transfers data from \fIinputChan\fR until -end of file or \fIsize\fR bytes or characters have been transferred; -\fIsize\fR is in bytes if the two channels are using the same encoding, -and is in characters otherwise. If no \fB\-size\fR argument is given, -then the copy goes until end of file. All the data read from -\fIinputChan\fR is copied to \fIoutputChan\fR. Without the -\fB\-command\fR option, \fBchan copy\fR blocks until the copy is -complete and returns the number of bytes or characters (using the same -rules as for the \fB\-size\fR option) written to \fIoutputChan\fR. -.PP -The \fB\-command\fR argument makes \fBchan copy\fR work in the -background. In this case it returns immediately and the -\fIcallback\fR is invoked later when the copy completes. The -\fIcallback\fR is called with one or two additional arguments that -indicates how many bytes were written to \fIoutputChan\fR. If an -error occurred during the background copy, the second argument is the -error string associated with the error. With a background copy, it is -not necessary to put \fIinputChan\fR or \fIoutputChan\fR into -non-blocking mode; the \fBchan copy\fR command takes care of that -automatically. However, it is necessary to enter the event loop by -using the \fBvwait\fR command or by using Tk. -.PP -You are not allowed to do other I/O operations with \fIinputChan\fR or -\fIoutputChan\fR during a background \fBchan copy\fR. If either -\fIinputChan\fR or \fIoutputChan\fR get closed while the copy is in -progress, the current copy is stopped and the command callback is -\fInot\fR made. If \fIinputChan\fR is closed, then all data already -queued for \fIoutputChan\fR is written out. -.PP -Note that \fIinputChan\fR can become readable during a background -copy. You should turn off any \fBchan event\fR or \fBfileevent\fR -handlers during a background copy so those handlers do not interfere -with the copy. Any I/O attempted by a \fBchan event\fR or -\fBfileevent\fR handler will get a -.QW "channel busy" -error. -.PP -\fBChan copy\fR translates end-of-line sequences in \fIinputChan\fR -and \fIoutputChan\fR according to the \fB\-translation\fR option for -these channels (see \fBchan configure\fR above). The translations -mean that the number of bytes read from \fIinputChan\fR can be -different than the number of bytes written to \fIoutputChan\fR. Only -the number of bytes written to \fIoutputChan\fR is reported, either as -the return value of a synchronous \fBchan copy\fR or as the argument -to the callback for an asynchronous \fBchan copy\fR. -.PP -\fBChan copy\fR obeys the encodings and character translations -configured for the channels. This means that the incoming characters -are converted internally first UTF-8 and then into the encoding of the -channel \fBchan copy\fR writes to (see \fBchan configure\fR above for -details on the \fB\-encoding\fR and \fB\-translation\fR options). No -conversion is done if both channels are set to encoding \fBbinary\fR -and have matching translations. If only the output channel is set to -encoding \fBbinary\fR the system will write the internal UTF-8 -representation of the incoming characters. If only the input channel -is set to encoding \fBbinary\fR the system will assume that the -incoming bytes are valid UTF-8 characters and convert them according -to the output encoding. The behaviour of the system for bytes which -are not valid UTF-8 characters is undefined in this case. +If \fB\-size\fR is given, the size is in bytes if the two channels have the +same encoding and in characters otherwise, and only that amount is copied. +Otherwise, all data until the end of the file is copied. + +\fBchan copy\fR blocks until the copy is complete and returns the number of +bytes or characters written to \fIoutputChan\fR. +.PP +If \fB\-command\fR is given, \fBchan copy\fR returns immediately, the copy is +carried out in the background, and then \fIcallback\fR is called with the +number of bytes written to \fIoutputChan\fR as its first argument, and the +error message for any error that occurred as its second argument. +\fIinputChan\fR and \fIoutputChan\fR are automatically configured for +non-blocking mode if needed. Background copying only works correctly if the +event loop is active, e.g. via \fBvwait\fR or Tk. +.PP +During a background copy no other read or write operation may be performed on +\fIinputChan\fR or \fIoutputChan\fR. If either \fIinputChan\fR or +\fIoutputChan\fR is closed while the copy is in progress copying ceases and +\fBno\fR callback is made. If \fIinputChan\fR is closed all data already queued +is written to \fIoutputChan\fR. +.PP +The should be no event handler established for \fIinputChan\fR because it may +become readable during a background copy. An attempt to read or write +from within an event handler results result in the error, "channel busy". +.PP +Due to end-of-line translation the number of bytes read from \fIinputChan\fR +may be different than the number of bytes written to \fIoutputChan\fR. Only +the number of bytes written to \fIoutputChan\fR is reported. +.PP +\fBChan copy\fR reads the data according to the \fB\-encoding\fR, +\fB\-translation\fR, and \fB\-eofchar\fR of the source and writes to the +destination according to the configuration for that channel. If the encoding +and translation of both channels is \fBbinary\fR and the \fB\-eofchar\fR of +both channels is the empty string, an identical copy is made. If only the +encoding of the destination is \fBbinary\fR, Tcl's internal modified UTF-8 +representation of the characters read from the source is written to the +destination. If only the encoding of the source is \fBbinary\fR, each byte read +becomes one Unicode character in the range of 0 to 255, and that character is +subject to the encoding and translation of the destination as it is written. .RE .TP \fBchan create \fImode cmdPrefix\fR . -This subcommand creates a new script level channel using the command -prefix \fIcmdPrefix\fR as its handler. Any such channel is called a -\fBreflected\fR channel. The specified command prefix, \fBcmdPrefix\fR, -must be a non-empty list, and should provide the API described in the -\fBrefchan\fR manual page. The handle of the new channel is -returned as the result of the \fBchan create\fR command, and the -channel is open. Use either \fBclose\fR or \fBchan close\fR to remove -the channel. +Creates a new channel, called a \fBreflected\fR channel, with \fIcmdPrefix\fR +as its handler, and returns the name of the channel. \fBcmdPrefix\fR is the +first words of a command that provides the interface for a \fBrefchan\fR. .RS .PP -The argument \fImode\fR specifies if the new channel is opened for -reading, writing, or both. It has to be a list containing any of the -strings +\fBImode\fR is a list of one or more of the strings .QW \fBread\fR or -.QW \fBwrite\fR . -The list must have at least one -element, as a channel you can neither write to nor read from makes no -sense. The handler command for the new channel must support the chosen -mode, or an error is thrown. -.PP -The command prefix is executed in the global namespace, at the top of -call stack, following the appending of arguments as described in the -\fBrefchan\fR manual page. Command resolution happens at the -time of the call. Renaming the command, or destroying it means that -the next call of a handler method may fail, causing the channel -command invoking the handler to fail as well. Depending on the -subcommand being invoked, the error message may not be able to explain -the reason for that failure. -.PP -Every channel created with this subcommand knows which interpreter it -was created in, and only ever executes its handler command in that -interpreter, even if the channel was shared with and/or was moved into -a different interpreter. Each reflected channel also knows the thread -it was created in, and executes its handler command only in that -thread, even if the channel was moved into a different thread. To this -end all invocations of the handler are forwarded to the original -thread by posting special events to it. This means that the original -thread (i.e. the thread that executed the \fBchan create\fR command) -must have an active event loop, i.e. it must be able to process such -events. Otherwise the thread sending them will \fIblock -indefinitely\fR. Deadlock may occur. -.PP -Note that this permits the creation of a channel whose two endpoints -live in two different threads, providing a stream-oriented bridge -between these threads. In other words, we can provide a way for -regular stream communication between threads instead of having to send -commands. -.PP -When a thread or interpreter is deleted, all channels created with -this subcommand and using this thread/interpreter as their computing -base are deleted as well, in all interpreters they have been shared -with or moved into, and in whatever thread they have been transferred -to. While this pulls the rug out under the other thread(s) and/or -interpreter(s), this cannot be avoided. Trying to use such a channel -will cause the generation of a regular error about unknown channel -handles. -.PP -This subcommand is \fBsafe\fR and made accessible to safe -interpreters. While it arranges for the execution of arbitrary Tcl -code the system also makes sure that the code is always executed -within the safe interpreter. +.QW \fBwrite\fR +, indicating whether the channel is a read channel, a write channel, or both. +It is an error if the handler does not support the chosen mode. +.PP +The handler is called as needed from the global namespace at the top level, and +command resolution happens there at the time of the call. If the handler is +renamed or deleted any subsequent attempt to call it is an error, which may +not be able to describe the failure. +.PP +The handler is always called in the interpreter and thread it was created in, +even if the channel was shared with or moved into a different interpreter in a +different thread. This is achieved through event dispatch, so if the event +loop is not entered, e.g. by calling \fBTcl_DoOneEvent\fR or \fBvwait\fR or +using Tk, the thread performing the channel operation \fIblocks +indefinitely\fR, resulting in deadlock. +.PP +One side of a channel may be in one thread while the other side is in a +different thread, providing a stream-oriented bridge between the threads. This +provides a method for regular stream communication between threads as an +alternative to sending commands. +.PP +When the interpreter the handler is in is deleted each channel associated with +the handler is deleted as well, regardless of which interpreter or thread it +is currently in or shared with. +.PP +\fBchan create\fR is \fBsafe\fR and is accessible to safe interpreters. The +handler is always called in the safe interpreter it was created in. .RE .TP -\fBchan eof \fIchannelId\fR -. -Test whether the last input operation on the channel called -\fIchannelId\fR failed because the end of the data stream was reached, -returning 1 if end-of-file was reached, and 0 otherwise. -.TP -\fBchan event \fIchannelId event\fR ?\fIscript\fR? -. -Arrange for the Tcl script \fIscript\fR to be installed as a \fIfile -event handler\fR to be called whenever the channel called -\fIchannelId\fR enters the state described by \fIevent\fR (which must -be either \fBreadable\fR or \fBwritable\fR); only one such handler may -be installed per event per channel at a time. If \fIscript\fR is the -empty string, the current handler is deleted (this also happens if the -channel is closed or the interpreter deleted). If \fIscript\fR is -omitted, the currently installed script is returned (or an empty -string if no such handler is installed). The callback is only -performed if the event loop is being serviced (e.g. via \fBvwait\fR or -\fBupdate\fR). -.RS -.PP -A file event handler is a binding between a channel and a script, such -that the script is evaluated whenever the channel becomes readable or -writable. File event handlers are most commonly used to allow data to -be received from another process on an event-driven basis, so that the -receiver can continue to interact with the user or with other channels -while waiting for the data to arrive. If an application invokes -\fBchan gets\fR or \fBchan read\fR on a blocking channel when there is -no input data available, the process will block; until the input data -arrives, it will not be able to service other events, so it will -appear to the user to -.QW "freeze up" . -With \fBchan event\fR, the -process can tell when data is present and only invoke \fBchan gets\fR -or \fBchan read\fR when they will not block. -.PP -A channel is considered to be readable if there is unread data -available on the underlying device. A channel is also considered to -be readable if there is unread data in an input buffer, except in the -special case where the most recent attempt to read from the channel -was a \fBchan gets\fR call that could not find a complete line in the -input buffer. This feature allows a file to be read a line at a time -in non-blocking mode using events. A channel is also considered to be -readable if an end of file or error condition is present on the -underlying file or device. It is important for \fIscript\fR to check -for these conditions and handle them appropriately; for example, if -there is no special check for end of file, an infinite loop may occur -where \fIscript\fR reads no data, returns, and is immediately invoked -again. -.PP -A channel is considered to be writable if at least one byte of data -can be written to the underlying file or device without blocking, or -if an error condition is present on the underlying file or device. -Note that client sockets opened in asynchronous mode become writable -when they become connected or if the connection fails. -.PP -Event-driven I/O works best for channels that have been placed into -non-blocking mode with the \fBchan configure\fR command. In blocking -mode, a \fBchan puts\fR command may block if you give it more data -than the underlying file or device can accept, and a \fBchan gets\fR -or \fBchan read\fR command will block if you attempt to read more data -than is ready; no events will be processed while the commands block. -In non-blocking mode \fBchan puts\fR, \fBchan read\fR, and \fBchan -gets\fR never block. -.PP -The script for a file event is executed at global level (outside the -context of any Tcl procedure) in the interpreter in which the \fBchan -event\fR command was invoked. If an error occurs while executing the -script then the command registered with \fBinterp bgerror\fR is used -to report the error. In addition, the file event handler is deleted -if it ever returns an error; this is done in order to prevent infinite -loops due to buggy handlers. -.RE +\fBchan eof \fIchannelName\fR +. +Returns 1 if the last read on the channel failed because the end of the data +was already reached, and 0 otherwise. .TP -\fBchan flush \fIchannelId\fR +\fBchan event \fIchannelName event\fR ?\fIscript\fR? . -Ensures that all pending output for the channel called \fIchannelId\fR -is written. +Arranges for the given script, called a \fBchannel event hndler\fR, to be +called whenever the given event, one of +.QW \fBreadable\fR +or +.QW \fBwritable\fR +occurs on the given channel, replacing any script that was previously set. If +\fIscript\fR is the empty string the current handler is deleted. It is also +deleted when the channel is closed. If \fIscript\fR is omitted, either the +existing script or the empty string is returned. The event loop must be +entered, e.g. via \fBvwait\fR or \fBupdate\fR, or by using Tk, for handlers to +be evaluated. + .RS .PP -If the channel is in blocking mode the command does not return until -all the buffered output has been flushed to the channel. If the -channel is in non-blocking mode, the command may return before all -buffered output has been flushed; the remainder will be flushed in the -background as fast as the underlying file or device is able to absorb -it. +\fIscript\fR is evaluated at the global level in the interpreter it was +established in. Any resulting error is handled in the background, i.e. via +\fBinterp bgerror\fR. In order to prevent an endless loop due to a buggy +handler, the handler is deleted if \fIscript\fR returns an error so that it is +not evaluated again. + +.PP +Without an event handler, \fBchan gets\fR or \fBchan read\fR on a channel in +blocking mode may block until data becomes available, become during which the +thread is unable to perform other work or respond to events on other channels. +This could cause the application to appear to +.QW "freeze up" +\&. +Channel event handlers allow events on the channel to direct channel handling +so that the reader or writer can continue to perform other processing while +waiting for a channel to become available and then handle channel operations +when the channel is ready for the operation. +.PP +A +.QW readable +event occurs when there is data that can be read from the channel and also when +there is an error on the channel. The handler must check for these conditions +and handle them appropriately. For example, a handler that does not check +whether the end of the data has been reached may be repeatedly evaluated in a +busy loop until the channel is closed. +.PP +A +.QW writable +event occurs when at least one byte of data can be written, or if there is an +error on the channel. A client socket opened in non-blocking mode becomes +writable when it becomes connected or if the connection fails. +.PP +Event-driven channel handling works best for channels in non-blocking mode. A +channel in blocking mode blocks when \fBchan puts\fR writes more data than the +channel can accept at the moment, and when \fBchan gets\fR or \fBchan read\fR +requests more data than is currently available. When a channel blocks, the +thread can not do any other processing or service any other events. A channel +in non-blocking mode allows a thread to carry on with other work and get back +to the channel at the right time. .RE .TP -\fBchan gets \fIchannelId\fR ?\fIvarName\fR? -. -Reads the next line from the channel called \fIchannelId\fR. If -\fIvarName\fR is not specified, the result of the command will be the -line that has been read (without a trailing newline character) or an -empty string upon end-of-file or, in non-blocking mode, if the data -available is exhausted. If \fIvarName\fR is specified, the line that -has been read will be written to the variable called \fIvarName\fR and -result will be the number of characters that have been read or -1 if -end-of-file was reached or, in non-blocking mode, if the data -available is exhausted. +\fBchan flush \fIchannelName\fR +. +For a channel in blocking mode, flushes all buffered output to the destination, +and then returns. For a channel in non-blocking mode, returns immediately +while all buffered output is flushed in the background as soon as possible. +.TP +\fBchan gets \fIchannelName\fR ?\fIvarName\fR? +. +Returns the next line from the channel, removing the trailing line feed, or if +\fIvarName\fR is given, assigns the line to that variable and returns the +number of characters read. +the line that was read, removing the trailing line feed, or returns the +empty string if there is no data to return and the end of the file has been +reached, or in non-blocking mode, if no complete line is currently available. +If \fIvarName\fR is given, assigns the line that was read to variable named +\fIvarName\fR and returns the number of characters that were read, or -1 if +there no data available and the end of the channel was reached or the channel +is in non-blocking mode. .RS .PP -If an end-of-file occurs while part way through reading a line, the -partial line will be returned (or written into \fIvarName\fR). When -\fIvarName\fR is not specified, the end-of-file case can be -distinguished from an empty line using the \fBchan eof\fR command, and -the partial-line-but-non-blocking case can be distinguished with the -\fBchan blocked\fR command. +If the end of the channel is reached the data read so far is returned or +assigned to \fIvarName\fR. When \fIvarName\fR is not given, \fBchan eof\fR may +indicate that the empty string means that the end of the data has been reached, +and \fBchan blocked\fR may indicate that that the empty string means there +isn't currently enough data do return the next line. .RE .TP \fBchan names\fR ?\fIpattern\fR? . -Produces a list of all channel names. If \fIpattern\fR is specified, -only those channel names that match it (according to the rules of -\fBstring match\fR) will be returned. +Returns a list of all channel names, or if \fIpattern\fR is given, only those +names that match according to the rules of \fBstring match\fR. .TP -\fBchan pending \fImode channelId\fR +\fBchan pending \fImode channelName\fR . -Depending on whether \fImode\fR is \fBinput\fR or \fBoutput\fR, -returns the number of -bytes of input or output (respectively) currently buffered -internally for \fIchannelId\fR (especially useful in a readable event -callback to impose application-specific limits on input line lengths to avoid -a potential denial-of-service attack where a hostile user crafts -an extremely long line that exceeds the available memory to buffer it). -Returns -1 if the channel was not opened for the mode in question. +Returns the number of bytes of input +when \fImode\fR is +.QW\fBinput\fR +, or output when \fImode\fR is +.QW\fBoutput\fR +, that are currently internally buffered for the channel. Useful in a readable +event callback to impose limits on input line length to avoid a potential +denial-of-service attack where an extremely long line exceeds the available +memory to buffer it. Returns -1 if the channel was not opened for the mode in +question. .TP \fBchan pipe\fR -Creates a standalone pipe whose read- and write-side channels are -returned as a 2-element list, the first element being the read side and -the second the write side. Can be useful e.g. to redirect -separately \fBstderr\fR and \fBstdout\fR from a subprocess. To do -this, spawn with "2>@" or -">@" redirection operators onto the write side of a pipe, and then -immediately close it in the parent. This is necessary to get an EOF on -the read side once the child has exited or otherwise closed its output. +Creates a pipe, i.e. a readable channel and a writable channel, and returns the +names of the readable channel and the writable channel. Data written to the +writable channel can be read from the readable channel. Because the pipe is a +real system-level pipe, it can be connected to other processes using +redirection. For example, to redirect \fBstderr\fR from a subprocess into one +channel, and \fBstdout\fR into another, \fBexec\fR with "2>@" and ">@", each +onto the writable side of a pipe, closing the writable side immediately +thereafter so that EOF is signaled on the read side once the subprocess has +closed its output, typically on exit. .RS .PP -Note that the pipe buffering semantics can vary at the operating system level -substantially; it is not safe to assume that a write performed on the output -side of the pipe will appear instantly to the input side. This is a -fundamental difference and Tcl cannot conceal it. The overall stream semantics -\fIare\fR compatible, so blocking reads and writes will not see most of the -differences, but the details of what exactly gets written when are not. This -is most likely to show up when using pipelines for testing; care should be -taken to ensure that deadlocks do not occur and that potential short reads are -allowed for. +Due to buffering, data written to one side of a pipe might not immediately +become available on the other side. Tcl's own buffers can be configured via +\fBchan configure -buffering\fR, but overall behaviour still depends on +operating system buffers outside of Tcl's control. Once the write side of the +channel is closed, any data remaining in the buffers is flushed through to the +read side. It may be useful to arrange for the connected process to flush at +some point after writing to the channel or to have it use some system-provided +mechanism to configure buffering. When two pipes are connected to the same +process, one to send data to the process, and one to read data from the +process, a deadlock may occur if the channels are in blocking mode: If +reading, the channel may block waiting for data that can never come because +buffers are only flushed on subsequent writes, and if writing, the channel may +block while waiting for the buffers to become free, which can never happen +because the reader can not read while the writer is blocking. To avoid this +issue, either put the channels into non-blocking mode and use event handlers, +or place the read channel and the write channel in separate interpreters in +separate threads. .RE .TP -\fBchan pop \fIchannelId\fR -Removes the topmost transformation from the channel \fIchannelId\fR, if there -is any. If there are no transformations added to \fIchannelId\fR, this is -equivalent to \fBchan close\fR of that channel. The result is normally the -empty string, but can be an error in some situations (i.e. where the -underlying system stream is closed and that results in an error). -.TP -\fBchan postevent \fIchannelId eventSpec\fR -. -This subcommand is used by command handlers specified with \fBchan -create\fR. It notifies the channel represented by the handle -\fIchannelId\fR that the event(s) listed in the \fIeventSpec\fR have -occurred. The argument has to be a list containing any of the strings -\fBread\fR and \fBwrite\fR. The list must contain at least one -element as it does not make sense to invoke the command if there are -no events to post. +\fBchan pop \fIchannelName\fR +Removes the topmost transformation handler from the channel if there is one, +and closes the channel otherwise. The result is normally the empty string, but +may be an error in some situations, e.g. when closing the underlying resource +results in an error. +.TP +\fBchan postevent \fIchannelName eventSpec\fR +. +For use by handlers established with \fBchan create\fR. Notifies Tcl that +that one or more event(s) listed in \fIeventSpec\fR, each of which is either +.QW\fBread\fR +or +.QW\fBwrite\fR. +, have occurred. .RS .PP -Note that this subcommand can only be used with channel handles that -were created/opened by \fBchan create\fR. All other channels will -cause this subcommand to report an error. -.PP -As only the Tcl level of a channel, i.e. its command handler, should -post events to it we also restrict the usage of this command to the -interpreter that created the channel. In other words, posting events -to a reflected channel from an interpreter that does not contain it's -implementation is not allowed. Attempting to post an event from any -other interpreter will cause this subcommand to report an error. -.PP -Another restriction is that it is not possible to post events that the -I/O core has not registered an interest in. Trying to do so will cause -the method to throw an error. See the command handler method -\fBwatch\fR described in \fBrefchan\fR, the document specifying -the API of command handlers for reflected channels. -.PP -This command is \fBsafe\fR and made accessible to safe interpreters. -It can trigger the execution of \fBchan event\fR handlers, whether in the -current interpreter or in other interpreters or other threads, even -where the event is posted from a safe interpreter and listened for by -a trusted interpreter. \fBChan event\fR handlers are \fIalways\fR -executed in the interpreter that set them up. +For use only by handlers for a channel created by \fBchan create\fR. It is an +error to post an event for any other channel. +.PP +Since only the handler for a reflected channel channel should post events it is +an error to post an event from any interpreter other than the interpreter that +created the channel. +.PP +It is an error to post an event that the channel has no interest in. See +\fBwatch\fR in the \fBrefchan\fR documentation for more information +.PP +\fBchan postevent\fR is available in safe interpreters, as any handler for a +reflected channel would have been created, and will be evaluated in that +interpreter as well. .RE .TP -\fBchan push \fIchannelId cmdPrefix\fR -Adds a new transformation on top of the channel \fIchannelId\fR. The -\fIcmdPrefix\fR argument describes a list of one or more words which represent -a handler that will be used to implement the transformation. The command -prefix must provide the API described in the \fBtranschan\fR manual page. -The result of this subcommand is a handle to the transformation. Note that it -is important to make sure that the transformation is capable of supporting the -channel mode that it is used with or this can make the channel neither -readable nor writable. -.TP -\fBchan puts\fR ?\fB\-nonewline\fR? ?\fIchannelId\fR? \fIstring\fR -. -Writes \fIstring\fR to the channel named \fIchannelId\fR followed by a -newline character. A trailing newline character is written unless the -optional flag \fB\-nonewline\fR is given. If \fIchannelId\fR is -omitted, the string is written to the standard output channel, +\fBchan push \fIchannelName cmdPrefix\fR +Adds a new transformation handler on top of the channel and returns a handle +for the transformation. \fIcmdPrefix\fR is the first words of a command that +provides the interface documented for \fBtranschan\fR, and transforms data on +the channel, It is an error if handler does not support the mode(s) the channel +is in. +.TP +\fBchan puts\fR ?\fB\-nonewline\fR? ?\fIchannelName\fR? \fIstring\fR +. +Writes \fIstring\fR and a line feed to the channel. If \fB\-nonewline\fR is +given, the trailing line feed is not written. The default channel is \fBstdout\fR. .RS .PP -Newline characters in the output are translated by \fBchan puts\fR to -platform-specific end-of-line sequences according to the currently -configured value of the \fB\-translation\fR option for the channel -(for example, on PCs newlines are normally replaced with -carriage-return-linefeed sequences; see \fBchan configure\fR above for -details). -.PP -Tcl buffers output internally, so characters written with \fBchan -puts\fR may not appear immediately on the output file or device; Tcl -will normally delay output until the buffer is full or the channel is -closed. You can force output to appear immediately with the \fBchan -flush\fR command. -.PP -When the output buffer fills up, the \fBchan puts\fR command will -normally block until all the buffered data has been accepted for -output by the operating system. If \fIchannelId\fR is in non-blocking -mode then the \fBchan puts\fR command will not block even if the -operating system cannot accept the data. Instead, Tcl continues to -buffer the data and writes it in the background as fast as the -underlying file or device can accept it. The application must use the -Tcl event loop for non-blocking output to work; otherwise Tcl never -finds out that the file or device is ready for more output data. It -is possible for an arbitrarily large amount of data to be buffered for -a channel in non-blocking mode, which could consume a large amount of -memory. To avoid wasting memory, non-blocking I/O should normally be -used in an event-driven fashion with the \fBchan event\fR command -(do not invoke \fBchan puts\fR unless you have recently been notified -via a file event that the channel is ready for more output data). +Each line feed in the output is translated according to the configuration of +\fB\-translation\fR. +.PP +Because Tcl internally buffers output, characters written to a channel may not +immediately be available at the destination. Tcl normally delays output until +the buffer is full or the channel is closed. \fBchan flush\fR forces output in +the direction of the destination. +.PP +When the output for a channel in blocking mode fills up, \fBchan puts\fR blocks +until space in the buffer is available again, but for a channel in non-blocking +mode, it returns immediately and the data is written in the background as fast +possible, constrained by the speed at which as the destination accepts it. +Output to a channel in non-blocking mode only works properly when the +application enters the event loop, giving Tcl a chance to find out that the +destination is ready to accept more data. When a channel is in non-blocking +mode, Tcl's internal buffers can hold an arbitrary amount of data, possibly +consuming a large amount of memory. To avoid wasting memory, channels in +non-blocking mode should normally be handled using \fBchan event\fR, where the +application only invokes \fBchan puts\fR after being recently notified through +a file event handler that the channel is ready for more output data. .RE .TP -\fBchan read \fIchannelId\fR ?\fInumChars\fR? +\fBchan read \fIchannelName\fR ?\fInumChars\fR? .TP -\fBchan read \fR?\fB\-nonewline\fR? \fIchannelId\fR +\fBchan read \fR?\fB\-nonewline\fR? \fIchannelName\fR . -In the first form, the result will be the next \fInumChars\fR -characters read from the channel named \fIchannelId\fR; if -\fInumChars\fR is omitted, all characters up to the point when the -channel would signal a failure (whether an end-of-file, blocked or -other error condition) are read. In the second form (i.e. when -\fInumChars\fR has been omitted) the flag \fB\-nonewline\fR may be -given to indicate that any trailing newline in the string that has -been read should be trimmed. +Reads and returns the next \fInumChars\fR characters from the channel. If +\fInumChars\fR is omitted, all available characters up to the end of the file +are read, or if the channel is in non-blocking mode, all currently-available +characters are read. If there is an error on the channel, reading ceases and +an error is returned. If \fInumChars\fR is not given, \fB\-nonewline\fR +may be given, causing any any trailing line feed to be trimmed. .RS .PP -If \fIchannelId\fR is in non-blocking mode, \fBchan read\fR may not -read as many characters as requested: once all available input has -been read, the command will return the data that is available rather -than blocking for more input. If the channel is configured to use a -multi-byte encoding, then there may actually be some bytes remaining -in the internal buffers that do not form a complete character. These -bytes will not be returned until a complete character is available or -end-of-file is reached. The \fB\-nonewline\fR switch is ignored if -the command returns before reaching the end of the file. -.PP -\fBChan read\fR translates end-of-line sequences in the input into -newline characters according to the \fB\-translation\fR option for the -channel (see \fBchan configure\fR above for a discussion on the ways -in which \fBchan configure\fR will alter input). -.PP -When reading from a serial port, most applications should configure -the serial port channel to be non-blocking, like this: -.PP -.CS -\fBchan configure \fIchannelId \fB\-blocking \fI0\fR. -.CE -.PP -Then \fBchan read\fR behaves much like described above. Note that -most serial ports are comparatively slow; it is entirely possible to -get a \fBreadable\fR event for each character read from them. Care -must be taken when using \fBchan read\fR on blocking serial ports: -.TP -\fBchan read \fIchannelId numChars\fR -. -In this form \fBchan read\fR blocks until \fInumChars\fR have been -received from the serial port. -.TP -\fBchan read \fIchannelId\fR -. -In this form \fBchan read\fR blocks until the reception of the -end-of-file character, see \fBchan configure -eofchar\fR. If there no -end-of-file character has been configured for the channel, then -\fBchan read\fR will block forever. +If the channel is in non-blocking mode, fewer characters than requested may be +returned. If the channel is configured to use a multi-byte encoding, bytes +that do not form a complete character are retained in the buffers until enough +bytes to complete the character accumulate, or the end of the data is reached. +\fB\-nonewline\fR is ignored if characters are returned before reaching the end +of the file. +.PP +Each end-of-line sequence according to the value of \fB\-translation\fR is +translated into a line feed. +.PP +When reading from a serial port, most applications should configure the serial +port channel to be in non-blocking mode, but not necessarily use an event +handler since most serial ports are comparatively slow. It is entirely +possible to get a \fBreadable\fR event for each individual character. In +blocking mode, \fBchan read\fR blocks forever when reading to the end of the +data if there is no \fBchan configure -eofchar\fR configured for the channel. .RE .TP -\fBchan seek \fIchannelId offset\fR ?\fIorigin\fR? +\fBchan seek \fIchannelName offset\fR ?\fIorigin\fR? . -Sets the current access position within the underlying data stream for -the channel named \fIchannelId\fR to be \fIoffset\fR bytes relative to -\fIorigin\fR. \fIOffset\fR must be an integer (which may be negative) -and \fIorigin\fR must be one of the following: +Sets the current position for the data in the channel to integer \fIoffset\fR +bytes relative to \fIorigin\fR. A negative offset moves the current position +backwards from the origin. \fIorigin\fR is one of the +following: .RS +.PP .TP 10 \fBstart\fR . -The new access position will be \fIoffset\fR bytes from the start -of the underlying file or device. +The origin is the start of the data. This is the default. .TP 10 \fBcurrent\fR . -The new access position will be \fIoffset\fR bytes from the current -access position; a negative \fIoffset\fR moves the access position -backwards in the underlying file or device. +The origin is the current position. .TP 10 \fBend\fR . -The new access position will be \fIoffset\fR bytes from the end of the -file or device. A negative \fIoffset\fR places the access position -before the end of file, and a positive \fIoffset\fR places the access -position after the end of file. -.PP -The \fIorigin\fR argument defaults to \fBstart\fR. +The origin is the end of the data. .PP -\fBChan seek\fR flushes all buffered output for the channel before the -command returns, even if the channel is in non-blocking mode. It also -discards any buffered and unread input. This command returns an empty -string. An error occurs if this command is applied to channels whose -underlying file or device does not support seeking. +\fBChan seek\fR flushes all buffered output even if the channel is in +non-blocking mode, discards any buffered and unread input, and returns the +empty string or an error if the channel does not support seeking. .PP -Note that \fIoffset\fR values are byte offsets, not character offsets. -Both \fBchan seek\fR and \fBchan tell\fR operate in terms of bytes, -not characters, unlike \fBchan read\fR. +\fIoffset\fR values are byte offsets, not character offsets. Unlike \fBchan +read\fR, both \fBchan seek\fR and \fBchan tell\fR operate in terms of bytes, +not characters, .RE .TP -\fBchan tell \fIchannelId\fR +\fBchan tell \fIchannelName\fR . -Returns a number giving the current access position within the -underlying data stream for the channel named \fIchannelId\fR. This -value returned is a byte offset that can be passed to \fBchan seek\fR -in order to set the channel to a particular position. Note that this -value is in terms of bytes, not characters like \fBchan read\fR. The -value returned is -1 for channels that do not support seeking. +Returns the offset in bytes of the current position in the underlying data, or +-1 if the channel does not suport seeking. The value can be passed to \fBchan +seek\fR to set current position to that offset. .TP -\fBchan truncate \fIchannelId\fR ?\fIlength\fR? +\fBchan truncate \fIchannelName\fR ?\fIlength\fR? . -Sets the byte length of the underlying data stream for the channel -named \fIchannelId\fR to be \fIlength\fR (or to the current byte -offset within the underlying data stream if \fIlength\fR is -omitted). The channel is flushed before truncation. +Flushes the channel and truncates the data in the channel to \fIlength\fR +bytes, or to the current position in bytes if \fIlength\fR is omitted. . .SH EXAMPLES .PP -This opens a file using a known encoding (CP1252, a very common encoding -on Windows), searches for a string, rewrites that part, and truncates the -file after a further two lines. +In the following example a file is opened using the encoding CP1252, which is +common on Windows, searches for a string, rewrites that part, and truncates the +file two lines later. .PP .CS set f [open somefile.txt r+] @@ -793,12 +619,12 @@ while {[\fBchan gets\fR $f line] >= 0} { \fBchan close\fR $f .CE .PP -A network server that does echoing of its input line-by-line without -preventing servicing of other connections at the same time. +A network server that echoes its input line-by-line without +preventing servicing of other connections at the same time: .PP .CS # This is a very simple logger... -proc log {message} { +proc log message { \fBchan puts\fR stdout $message } -- cgit v0.12 From 511e85013ac111a96845721348abc019321ab15e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 23 Jan 2022 16:21:42 +0000 Subject: eol-spacing from previous commit --- doc/chan.n | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/doc/chan.n b/doc/chan.n index aa8bbca..9589f98 100644 --- a/doc/chan.n +++ b/doc/chan.n @@ -113,7 +113,7 @@ connect to terminal-like devices, the default value is \fBline\fR. For \fB\-buffersize\fR \fInewSize\fR . \fInewSize\fR, an integer no greater than one million, is the size in bytes of -any input or output buffers subsequently allocated for this channel. +any input or output buffers subsequently allocated for this channel. .TP \fB\-encoding\fR ?\fIname\fR? . @@ -148,7 +148,7 @@ interface with the operating system, . \fIchar\fR signals the end of the data when it is encountered in the input. For output, the character is added when the channel is closed. If \fIchar\fR -is the empty string, there is no special character that marks the end of the +is the empty string, there is no special character that marks the end of the data. For read-write channels, one end-of-file character for input and another for output may be given. When only one end-of-file character is given it is applied to both input and output. For a read-write channel two values are @@ -279,14 +279,14 @@ first words of a command that provides the interface for a \fBrefchan\fR. \fBImode\fR is a list of one or more of the strings .QW \fBread\fR or -.QW \fBwrite\fR +.QW \fBwrite\fR , indicating whether the channel is a read channel, a write channel, or both. It is an error if the handler does not support the chosen mode. .PP The handler is called as needed from the global namespace at the top level, and command resolution happens there at the time of the call. If the handler is renamed or deleted any subsequent attempt to call it is an error, which may -not be able to describe the failure. +not be able to describe the failure. .PP The handler is always called in the interpreter and thread it was created in, even if the channel was shared with or moved into a different interpreter in a @@ -374,7 +374,7 @@ to the channel at the right time. . For a channel in blocking mode, flushes all buffered output to the destination, and then returns. For a channel in non-blocking mode, returns immediately -while all buffered output is flushed in the background as soon as possible. +while all buffered output is flushed in the background as soon as possible. .TP \fBchan gets \fIchannelName\fR ?\fIvarName\fR? . @@ -522,7 +522,7 @@ Reads and returns the next \fInumChars\fR characters from the channel. If are read, or if the channel is in non-blocking mode, all currently-available characters are read. If there is an error on the channel, reading ceases and an error is returned. If \fInumChars\fR is not given, \fB\-nonewline\fR -may be given, causing any any trailing line feed to be trimmed. +may be given, causing any any trailing line feed to be trimmed. .RS .PP If the channel is in non-blocking mode, fewer characters than requested may be @@ -562,7 +562,7 @@ The origin is the current position. .TP 10 \fBend\fR . -The origin is the end of the data. +The origin is the end of the data. .PP \fBChan seek\fR flushes all buffered output even if the channel is in non-blocking mode, discards any buffered and unread input, and returns the -- cgit v0.12 From bc8c2ad47a5fc72622020a829493e50e449bd040 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 24 Jan 2022 11:01:07 +0000 Subject: Fix another bug in Tcl_GetIntForIndex() (demonstrated by the new testcases from the previous commit) --- generic/tclTest.c | 7 ++++--- generic/tclUtil.c | 2 +- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/generic/tclTest.c b/generic/tclTest.c index 95ef5b7..5e6ca8c 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -7046,20 +7046,21 @@ TestGetIntForIndexCmd( int objc, Tcl_Obj *const objv[]) { - int result, endvalue; + int result; + Tcl_WideInt endvalue; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "index endvalue"); return TCL_ERROR; } - if (Tcl_GetIntFromObj(interp, objv[2], &endvalue) != TCL_OK) { + if (Tcl_GetWideIntFromObj(interp, objv[2], &endvalue) != TCL_OK) { return TCL_ERROR; } if (Tcl_GetIntForIndex(interp, objv[1], endvalue, &result) != TCL_OK) { return TCL_ERROR; } - Tcl_SetObjResult(interp, Tcl_NewIntObj(result)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(result)); return TCL_OK; } diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 10153fb..e29afcc 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -3699,7 +3699,7 @@ Tcl_GetIntForIndex( { Tcl_WideInt wide; - if (GetWideForIndex(interp, objPtr, (size_t)(endValue + 1) - 1, &wide) == TCL_ERROR) { + if (GetWideForIndex(interp, objPtr, endValue, &wide) == TCL_ERROR) { return TCL_ERROR; } if (indexPtr != NULL) { -- cgit v0.12 From d46657f1f739cdf35daf961140c922498eb151f7 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 24 Jan 2022 11:15:39 +0000 Subject: Don't document the size_t form of Tcl_GetStringFromObj() (yet), because it's only available if TCL_NO_DEPRECATED is defined --- doc/StringObj.3 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/StringObj.3 b/doc/StringObj.3 index 90b53f2..1b04dd4 100644 --- a/doc/StringObj.3 +++ b/doc/StringObj.3 @@ -121,7 +121,7 @@ the last one available. Points to a value to manipulate. .AP Tcl_Obj *appendObjPtr in The value to append to \fIobjPtr\fR in \fBTcl_AppendObjToObj\fR. -.AP size_t | int *lengthPtr out +.AP int *lengthPtr out The location where \fBTcl_GetStringFromObj\fR will store the length of a value's string representation. May be (int *)NULL when not used. .AP "const char" *string in -- cgit v0.12 From 5c2bc08ea4edc13e386422d6c6f86bb65014a0a3 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Wed, 26 Jan 2022 17:48:34 +0000 Subject: Add back a clarification to the documentation for [expr] that an operand is interpreted as a number wherever possible, and rework text to be more compact. --- doc/expr.n | 137 +++++++++++++++++++++++++++++++------------------------------ 1 file changed, 69 insertions(+), 68 deletions(-) diff --git a/doc/expr.n b/doc/expr.n index 43ad26f..490217c 100644 --- a/doc/expr.n +++ b/doc/expr.n @@ -17,7 +17,7 @@ expr \- Evaluate an expression .BE .SH DESCRIPTION .PP -The \fIexpr\fR command concatenates \fIarg\fRs, separated by a space, into an expression, and evaluates +Concatenates \fIarg\fRs, separated by a space, into an expression, and evaluates that expression, returning its value. The operators permitted in an expression include a subset of the operators permitted in C expressions. For those operators @@ -37,76 +37,36 @@ operands are specified. Expressions also support non-numeric operands, string comparisons, and some additional operators not found in C. .PP -When an expression evaluates to an integer, the value is the decimal form of -the integer, and when an expression evaluates to a floating-point number, the -value is the form produced by the \fB%g\fR format specifier of Tcl's -\fBformat\fR command. +When the result of expression is an integer, it is in decimal form, and when +the result is a floating-point number, it is in the form produced by the +\fB%g\fR format specifier of \fBformat\fR. .PP .VS "TIP 582" -You can use \fB#\fR at any point in the expression (except inside double -quotes or braces) to start a comment. Comments last to the end of the line or +At any point in the expression except within double quotes or braces, \fB#\fR +is the beginning of a comment, which lasts to the end of the line or the end of the expression, whichever comes first. .VE "TIP 582" .SS OPERANDS .PP An expression consists of a combination of operands, operators, parentheses and commas, possibly with whitespace between any of these elements, which is -ignored. +ignored. Each operand is intepreted as a numeric value if at all possible. .PP -An operand may be specified in any of the following ways: -.IP [1] -As a numeric value, either integer or floating-point. -.IP [2] -As a boolean value, using any form understood by \fBstring is\fR -\fBboolean\fR. -.IP [3] -As a variable, using standard \fB$\fR notation. -The value of the variable is then the value of the operand. -.IP [4] -As a string enclosed in double-quotes. -Backslash, variable, and command substitution are performed as described in -\fBTcl\fR. -.IP [5] -As a string enclosed in braces. -The operand is treated as a braced value as described in \fBTcl\fR. -.IP [6] -As a Tcl command enclosed in brackets. -Command substitution is performed as described in \fBTcl\fR. -.IP [7] -As a mathematical function such as \fBsin($x)\fR, whose arguments have any of the above -forms for operands. See \fBMATH FUNCTIONS\fR below for -a discussion of how mathematical functions are handled. -.PP -Because \fBexpr\fR parses and performs substitutions on values that have -already been parsed and substituted by \fBTcl\fR, it is usually best to enclose -expressions in braces to avoid the first round of substitutions by -\fBTcl\fR. -.PP -Below are some examples of simple expressions where the value of \fBa\fR is 3 -and the value of \fBb\fR is 6. The command on the left side of each line -produces the value on the right side. -.PP -.CS -.ta 9c -\fBexpr\fR {3.1 + $a} \fI6.1\fR -\fBexpr\fR {2 + "$a.$b"} \fI5.6\fR -\fBexpr\fR {4*[llength "6 2"]} \fI8\fR -\fBexpr\fR {{word one} < "word $a"} \fI0\fR -.CE -.PP -\fBInteger value\fR +Each operand has one of the following forms: +.RS .PP -An integer operand may be specified in decimal (the normal case, the optional -first two characters are \fB0d\fR), binary -(the first two characters are \fB0b\fR), octal -(the first two characters are \fB0o\fR), or hexadecimal -(the first two characters are \fB0x\fR) form. For -compatibility with older Tcl releases, an operand that begins with \fB0\fR is -interpreted as an octal integer even if the second character is not \fBo\fR. +.TP +A \fBnumeric value\fR .PP -\fBFloating-point value\fR +.RS +. +Either integer or floating-point. The first two characters of an integer may +also be \fB0d\fR for decimal, \fB0b\fR for binary, \fB0o\fR for octal or +\fB0x\fR for hexadicimal. For compatibility with older Tcl releases, an +operand that begins with \fB0\fR is interpreted as an octal integer even if the +second character is not \fBo\fR. .PP -A floating-point number may be specified in any of several +A floating-point number may be take any of several common decimal formats, and may use the decimal point \fB.\fR, \fBe\fR or \fBE\fR for scientific notation, and the sign characters \fB+\fR and \fB\-\fR. The @@ -116,16 +76,9 @@ and \fBNaN\fR, in any combination of case, are also recognized as floating point values. An operand that doesn't have a numeric interpretation must be quoted with either braces or with double quotes. .PP -\fBBoolean value\fR -.PP -A boolean value may be represented by any of the values \fB0\fR, \fBfalse\fR, \fBno\fR, -or \fBoff\fR and any of the values \fB1\fR, \fBtrue\fR, \fByes\fR, or \fBon\fR. -.PP -\fBDigit Separator\fR -.PP Digits in any numeric value may be separated with one or more underscore -characters, "\fB_\fR", to improve readability. These separators may only -appear between digits. The separator may not appear at the start of a +characters, "\fB_\fR". A separator may only +appear between digits, not appear at the start of a numeric value, between the leading 0 and radix specifier, or at the end of a numeric value. Here are some examples: .PP @@ -135,6 +88,54 @@ end of a numeric value. Here are some examples: \fBexpr\fR 0xffff_ffff \fI4294967295\fR \fBformat\fR 0x%x 0b1111_1110_1101_1011 \fI0xfedb\fR .CE +.RE + +.TP +A \fBboolean value\fR +. +Using any form understood by \fBstring is\fR +\fBboolean\fR. +.TP +A \fBvariable\fR +. +Using standard \fB$\fR notation. +The value of the variable is the value of the operand. +.TP +A string enclosed in \fBdouble-quotes\fR +. +Backslash, variable, and command substitution are performed according to the +rules for \fBTcl\fR. +.TP +A string enclosed in \fBbraces\fR. +The operand is treated as a braced value according to the rule for braces in +\fBTcl\fR. +.TP +A Tcl command enclosed in \fBbrackets\fR +. +Command substitution is performed as according to the command substitution rule +for \fBTcl\fR. +.TP +A mathematical function such as \fBsin($x)\fR, whose arguments have any of the above +forms for operands. See \fBMATH FUNCTIONS\fR below for +a discussion of how mathematical functions are handled. +.RE +.PP +Because \fBexpr\fR parses and performs substitutions on values that have +already been parsed and substituted by \fBTcl\fR, it is usually best to enclose +expressions in braces to avoid the first round of substitutions by +\fBTcl\fR. +.PP +Below are some examples of simple expressions where the value of \fBa\fR is 3 +and the value of \fBb\fR is 6. The command on the left side of each line +produces the value on the right side. +.PP +.CS +.ta 9c +\fBexpr\fR {3.1 + $a} \fI6.1\fR +\fBexpr\fR {2 + "$a.$b"} \fI5.6\fR +\fBexpr\fR {4*[llength {6 2}]} \fI8\fR +\fBexpr\fR {{word one} < "word $a"} \fI0\fR +.CE .PP .SS OPERATORS .PP -- cgit v0.12 From cc66f3601ff68b38489ca84cb582dbbe3ea804ef Mon Sep 17 00:00:00 2001 From: bch Date: Fri, 28 Jan 2022 23:28:24 +0000 Subject: rejig argv/argc handling in response to investigation prompted by [https://arstechnica.com/information-technology/2022/01/a-bug-lurking-for- 12-years-gives-attackers-root-on-every-major-linux-distro/|this "polkit issue"] and some experimenting w/ execve() (ab)use. Essentially port of [0e1d2702ab] and its parent; discussed at length on IRC --- generic/tclMain.c | 26 +++++++++++++++++--------- 1 file changed, 17 insertions(+), 9 deletions(-) diff --git a/generic/tclMain.c b/generic/tclMain.c index bb48dbb..f1b1ae2 100644 --- a/generic/tclMain.c +++ b/generic/tclMain.c @@ -288,6 +288,8 @@ Tcl_MainEx( * but before starting to execute commands. */ Tcl_Interp *interp) { + char *progname = NULL; /* may/may-not be able to use argv[0] */ + int i=0; /* argv[i] index */ Tcl_Obj *path, *resultPtr, *argvPtr, *appName; const char *encodingName = NULL; int code, exitCode = 0; @@ -296,7 +298,14 @@ Tcl_MainEx( InteractiveState is; TclpSetInitialEncodings(); - TclpFindExecutable((const char *)argv[0]); + if (0 < argc) { + progname = argv[0]; + --argc; /* consume argv[0] */ + ++i; + } + TclpFindExecutable ((const char *)progname); /* nb: this could be NULL + * w/ (eg) a malformed + * execve() */ Tcl_InitMemory(interp); @@ -318,36 +327,35 @@ Tcl_MainEx( * FILENAME */ - if ((argc > 3) && (0 == _tcscmp(TEXT("-encoding"), argv[1])) + /* mind argc is being adjusted as we proceed */ + if ((argc >= 3) && (0 == _tcscmp(TEXT("-encoding"), argv[1])) && ('-' != argv[3][0])) { Tcl_Obj *value = NewNativeObj(argv[2]); Tcl_SetStartupScript(NewNativeObj(argv[3]), Tcl_GetString(value)); Tcl_DecrRefCount(value); argc -= 3; - argv += 3; - } else if ((argc > 1) && ('-' != argv[1][0])) { + i += 3; + } else if ((argc >= 1) && ('-' != argv[1][0])) { Tcl_SetStartupScript(NewNativeObj(argv[1]), NULL); argc--; - argv++; + i++; } } path = Tcl_GetStartupScript(&encodingName); if (path == NULL) { - appName = NewNativeObj(argv[0]); + appName = NewNativeObj(progname); } else { appName = path; } Tcl_SetVar2Ex(interp, "argv0", NULL, appName, TCL_GLOBAL_ONLY); - argc--; - argv++; Tcl_SetVar2Ex(interp, "argc", NULL, Tcl_NewWideIntObj(argc), TCL_GLOBAL_ONLY); argvPtr = Tcl_NewListObj(0, NULL); while (argc--) { - Tcl_ListObjAppendElement(NULL, argvPtr, NewNativeObj(*argv++)); + Tcl_ListObjAppendElement(NULL, argvPtr, NewNativeObj(argv[i++])); } Tcl_SetVar2Ex(interp, "argv", NULL, argvPtr, TCL_GLOBAL_ONLY); -- cgit v0.12 From 95bcc538075fc86ab77313a173e2c4ce89a38f0d Mon Sep 17 00:00:00 2001 From: bch Date: Fri, 28 Jan 2022 23:52:10 +0000 Subject: take advantage of what we know re: argv guarantees [https://www.iso-9899.info/n1570.html#5.1.2.2.1|argv spec] (per @cousteau on #tcl) --- generic/tclMain.c | 12 +++++------- 1 file changed, 5 insertions(+), 7 deletions(-) diff --git a/generic/tclMain.c b/generic/tclMain.c index f1b1ae2..be9ec4c 100644 --- a/generic/tclMain.c +++ b/generic/tclMain.c @@ -288,7 +288,6 @@ Tcl_MainEx( * but before starting to execute commands. */ Tcl_Interp *interp) { - char *progname = NULL; /* may/may-not be able to use argv[0] */ int i=0; /* argv[i] index */ Tcl_Obj *path, *resultPtr, *argvPtr, *appName; const char *encodingName = NULL; @@ -299,13 +298,12 @@ Tcl_MainEx( TclpSetInitialEncodings(); if (0 < argc) { - progname = argv[0]; - --argc; /* consume argv[0] */ + --argc; /* "consume" argv[0] */ ++i; } - TclpFindExecutable ((const char *)progname); /* nb: this could be NULL - * w/ (eg) a malformed - * execve() */ + TclpFindExecutable ((const char *)argv [0]); /* nb: this could be NULL + * w/ (eg) an empty argv + * supplied to execve() */ Tcl_InitMemory(interp); @@ -345,7 +343,7 @@ Tcl_MainEx( path = Tcl_GetStartupScript(&encodingName); if (path == NULL) { - appName = NewNativeObj(progname); + appName = NewNativeObj(argv[0]); } else { appName = path; } -- cgit v0.12 From 99678d70f78441ead651c6b62e7af986648deaeb Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 3 Feb 2022 12:49:55 +0000 Subject: Fix Tcl_UtfToWChar() typedef --- generic/tclDecls.h | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 6ca7633..f1962b2 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -4269,8 +4269,8 @@ extern const TclStubs *tclStubsPtr; ? (wchar_t *(*)(const char *, int, Tcl_DString *))tclStubsPtr->tcl_UtfToUniCharDString \ : (wchar_t *(*)(const char *, int, Tcl_DString *))Tcl_UtfToChar16DString) # define Tcl_UtfToWChar (sizeof(wchar_t) != sizeof(short) \ - ? (int (*)(const char *, wchar_t *))tclStubsPtr->tcl_UtfToChar16 \ - : (int (*)(const char *, wchar_t *))Tcl_UtfToUniChar) + ? (int (*)(const char *, wchar_t *))tclStubsPtr->tcl_UtfToUniChar \ + : (int (*)(const char *, wchar_t *))Tcl_UtfToChar16) #else # define Tcl_WCharToUtfDString (sizeof(wchar_t) != sizeof(short) \ ? (char *(*)(const wchar_t *, int, Tcl_DString *))Tcl_UniCharToUtfDString \ @@ -4279,8 +4279,8 @@ extern const TclStubs *tclStubsPtr; ? (wchar_t *(*)(const char *, int, Tcl_DString *))Tcl_UtfToUniCharDString \ : (wchar_t *(*)(const char *, int, Tcl_DString *))Tcl_UtfToChar16DString) # define Tcl_UtfToWChar (sizeof(wchar_t) != sizeof(short) \ - ? (int (*)(const char *, wchar_t *))Tcl_UtfToChar16 \ - : (int (*)(const char *, wchar_t *))Tcl_UtfToUniChar) + ? (int (*)(const char *, wchar_t *))Tcl_UtfToUniChar \ + : (int (*)(const char *, wchar_t *))Tcl_UtfToChar16) #endif /* -- cgit v0.12 From 62f5155cc809b84cc59bc06780d309edaa2b59f0 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 3 Feb 2022 13:13:06 +0000 Subject: TIP #617: Tcl_WCharLen/Tcl_Char16Len --- doc/Utf.3 | 16 +++++++++++++++- generic/tcl.decls | 10 ++++++++-- generic/tclDecls.h | 43 ++++++++++++++++++++++++++++++++++++++----- generic/tclStubInit.c | 10 +++++++++- generic/tclUtf.c | 33 ++++++++++++++++++++++++++++++++- 5 files changed, 102 insertions(+), 10 deletions(-) diff --git a/doc/Utf.3 b/doc/Utf.3 index f1aca4c..b0c7f64 100644 --- a/doc/Utf.3 +++ b/doc/Utf.3 @@ -8,7 +8,7 @@ .so man.macros .BS .SH NAME -Tcl_UniChar, Tcl_UniCharToUtf, Tcl_UtfToUniChar, Tcl_UtfToChar16, Tcl_UtfToWChar, Tcl_UniCharToUtfDString, Tcl_UtfToUniCharDString, Tcl_Char16ToUtfDString, Tcl_UtfToWCharDString, Tcl_UtfToChar16DString, Tcl_UniCharLen, Tcl_UniCharNcmp, Tcl_UniCharNcasecmp, Tcl_UniCharCaseMatch, Tcl_UtfNcmp, Tcl_UtfNcasecmp, Tcl_UtfCharComplete, Tcl_NumUtfChars, Tcl_UtfFindFirst, Tcl_UtfFindLast, Tcl_UtfNext, Tcl_UtfPrev, Tcl_UniCharAtIndex, Tcl_UtfAtIndex, Tcl_UtfBackslash \- routines for manipulating UTF-8 strings +Tcl_UniChar, Tcl_UniCharToUtf, Tcl_UtfToUniChar, Tcl_UtfToChar16, Tcl_UtfToWChar, Tcl_UniCharToUtfDString, Tcl_UtfToUniCharDString, Tcl_Char16ToUtfDString, Tcl_UtfToWCharDString, Tcl_UtfToChar16DString, Tcl_WCharLen, Tcl_Char16Len, Tcl_UniCharLen, Tcl_UniCharNcmp, Tcl_UniCharNcasecmp, Tcl_UniCharCaseMatch, Tcl_UtfNcmp, Tcl_UtfNcasecmp, Tcl_UtfCharComplete, Tcl_NumUtfChars, Tcl_UtfFindFirst, Tcl_UtfFindLast, Tcl_UtfNext, Tcl_UtfPrev, Tcl_UniCharAtIndex, Tcl_UtfAtIndex, Tcl_UtfBackslash \- routines for manipulating UTF-8 strings .SH SYNOPSIS .nf \fB#include \fR @@ -46,6 +46,12 @@ wchar_t * \fBTcl_UtfToWCharDString\fR(\fIsrc, length, dsPtr\fR) .sp int +\fBTcl_Char16Len\fR(\fIuniStr\fR) +.sp +int +\fBTcl_WCharLen\fR(\fIuniStr\fR) +.sp +int \fBTcl_UniCharLen\fR(\fIuniStr\fR) .sp int @@ -198,6 +204,14 @@ representation of the UTF-8 string. Storage for the return value is appended to the end of the \fBTcl_DString\fR. The Unicode string is terminated with a Unicode null character. .PP +\fBTcl_Char16Len\fR corresponds to \fBstrlen\fR for UTF-16 +characters. It accepts a null-terminated Unicode string and returns +the number of Unicode characters (not bytes) in that string. +.PP +\fBTcl_WCharLen\fR corresponds to \fBstrlen\fR for wchar_t +characters. It accepts a null-terminated Unicode string and returns +the number of Unicode characters (not bytes) in that string. +.PP \fBTcl_UniCharLen\fR corresponds to \fBstrlen\fR for Unicode characters. It accepts a null-terminated Unicode string and returns the number of Unicode characters (not bytes) in that string. diff --git a/generic/tcl.decls b/generic/tcl.decls index bd9800a..38dbe5a 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -1244,8 +1244,8 @@ declare 350 { declare 351 { int Tcl_UniCharIsWordChar(int ch) } -declare 352 {deprecated {Use Tcl_GetCharLength}} { - int Tcl_UniCharLen(const Tcl_UniChar *uniStr) +declare 352 { + int Tcl_Char16Len(const unsigned short *uniStr) } declare 353 {deprecated {Use Tcl_UtfNcmp}} { int Tcl_UniCharNcmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, @@ -2442,6 +2442,12 @@ declare 660 { int Tcl_AsyncMarkFromSignal(Tcl_AsyncHandler async, int sigNumber) } +# TIP #617 +declare 668 { + int Tcl_UniCharLen(const int *uniStr) +} + + # ----- BASELINE -- FOR -- 8.7.0 ----- # ############################################################################## diff --git a/generic/tclDecls.h b/generic/tclDecls.h index f1962b2..6400029 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1063,8 +1063,7 @@ EXTERN int Tcl_UniCharIsUpper(int ch); /* 351 */ EXTERN int Tcl_UniCharIsWordChar(int ch); /* 352 */ -TCL_DEPRECATED("Use Tcl_GetCharLength") -int Tcl_UniCharLen(const Tcl_UniChar *uniStr); +EXTERN int Tcl_Char16Len(const unsigned short *uniStr); /* 353 */ TCL_DEPRECATED("Use Tcl_UtfNcmp") int Tcl_UniCharNcmp(const Tcl_UniChar *ucs, @@ -1948,6 +1947,15 @@ EXTERN int Tcl_UniCharIsUnicode(int ch); /* 660 */ EXTERN int Tcl_AsyncMarkFromSignal(Tcl_AsyncHandler async, int sigNumber); +/* Slot 661 is reserved */ +/* Slot 662 is reserved */ +/* Slot 663 is reserved */ +/* Slot 664 is reserved */ +/* Slot 665 is reserved */ +/* Slot 666 is reserved */ +/* Slot 667 is reserved */ +/* 668 */ +EXTERN int Tcl_UniCharLen(const int *uniStr); typedef struct { const struct TclPlatStubs *tclPlatStubs; @@ -2335,7 +2343,7 @@ typedef struct TclStubs { int (*tcl_UniCharIsSpace) (int ch); /* 349 */ int (*tcl_UniCharIsUpper) (int ch); /* 350 */ int (*tcl_UniCharIsWordChar) (int ch); /* 351 */ - TCL_DEPRECATED_API("Use Tcl_GetCharLength") int (*tcl_UniCharLen) (const Tcl_UniChar *uniStr); /* 352 */ + int (*tcl_Char16Len) (const unsigned short *uniStr); /* 352 */ TCL_DEPRECATED_API("Use Tcl_UtfNcmp") int (*tcl_UniCharNcmp) (const Tcl_UniChar *ucs, const Tcl_UniChar *uct, unsigned long numChars); /* 353 */ char * (*tcl_Char16ToUtfDString) (const unsigned short *uniStr, int uniLength, Tcl_DString *dsPtr); /* 354 */ unsigned short * (*tcl_UtfToChar16DString) (const char *src, int length, Tcl_DString *dsPtr); /* 355 */ @@ -2644,6 +2652,14 @@ typedef struct TclStubs { void (*reserved658)(void); void (*reserved659)(void); int (*tcl_AsyncMarkFromSignal) (Tcl_AsyncHandler async, int sigNumber); /* 660 */ + void (*reserved661)(void); + void (*reserved662)(void); + void (*reserved663)(void); + void (*reserved664)(void); + void (*reserved665)(void); + void (*reserved666)(void); + void (*reserved667)(void); + int (*tcl_UniCharLen) (const int *uniStr); /* 668 */ } TclStubs; extern const TclStubs *tclStubsPtr; @@ -3378,8 +3394,8 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_UniCharIsUpper) /* 350 */ #define Tcl_UniCharIsWordChar \ (tclStubsPtr->tcl_UniCharIsWordChar) /* 351 */ -#define Tcl_UniCharLen \ - (tclStubsPtr->tcl_UniCharLen) /* 352 */ +#define Tcl_Char16Len \ + (tclStubsPtr->tcl_Char16Len) /* 352 */ #define Tcl_UniCharNcmp \ (tclStubsPtr->tcl_UniCharNcmp) /* 353 */ #define Tcl_Char16ToUtfDString \ @@ -3994,6 +4010,15 @@ extern const TclStubs *tclStubsPtr; /* Slot 659 is reserved */ #define Tcl_AsyncMarkFromSignal \ (tclStubsPtr->tcl_AsyncMarkFromSignal) /* 660 */ +/* Slot 661 is reserved */ +/* Slot 662 is reserved */ +/* Slot 663 is reserved */ +/* Slot 664 is reserved */ +/* Slot 665 is reserved */ +/* Slot 666 is reserved */ +/* Slot 667 is reserved */ +#define Tcl_UniCharLen \ + (tclStubsPtr->tcl_UniCharLen) /* 668 */ #endif /* defined(USE_TCL_STUBS) */ @@ -4260,6 +4285,8 @@ extern const TclStubs *tclStubsPtr; # define Tcl_UtfToUniCharDString Tcl_UtfToChar16DString # undef Tcl_UtfToUniChar # define Tcl_UtfToUniChar Tcl_UtfToChar16 +# undef Tcl_UniCharLen +# define Tcl_UniCharLen Tcl_Char16Len #endif #if defined(USE_TCL_STUBS) # define Tcl_WCharToUtfDString (sizeof(wchar_t) != sizeof(short) \ @@ -4271,6 +4298,9 @@ extern const TclStubs *tclStubsPtr; # define Tcl_UtfToWChar (sizeof(wchar_t) != sizeof(short) \ ? (int (*)(const char *, wchar_t *))tclStubsPtr->tcl_UtfToUniChar \ : (int (*)(const char *, wchar_t *))Tcl_UtfToChar16) +# define Tcl_WCharLen (sizeof(wchar_t) != sizeof(short) \ + ? (int (*)(wchar_t *))tclStubsPtr->tcl_UniCharLen \ + : (int (*)(wchar_t *))Tcl_Char16Len) #else # define Tcl_WCharToUtfDString (sizeof(wchar_t) != sizeof(short) \ ? (char *(*)(const wchar_t *, int, Tcl_DString *))Tcl_UniCharToUtfDString \ @@ -4281,6 +4311,9 @@ extern const TclStubs *tclStubsPtr; # define Tcl_UtfToWChar (sizeof(wchar_t) != sizeof(short) \ ? (int (*)(const char *, wchar_t *))Tcl_UtfToUniChar \ : (int (*)(const char *, wchar_t *))Tcl_UtfToChar16) +# define Tcl_WCharLen (sizeof(wchar_t) != sizeof(short) \ + ? (int (*)(wchar_t *))Tcl_UniCharLen \ + : (int (*)(wchar_t *))Tcl_Char16Len) #endif /* diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index a1878c1..6374ab5 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -1635,7 +1635,7 @@ const TclStubs tclStubs = { Tcl_UniCharIsSpace, /* 349 */ Tcl_UniCharIsUpper, /* 350 */ Tcl_UniCharIsWordChar, /* 351 */ - Tcl_UniCharLen, /* 352 */ + Tcl_Char16Len, /* 352 */ Tcl_UniCharNcmp, /* 353 */ Tcl_Char16ToUtfDString, /* 354 */ Tcl_UtfToChar16DString, /* 355 */ @@ -1944,6 +1944,14 @@ const TclStubs tclStubs = { 0, /* 658 */ 0, /* 659 */ Tcl_AsyncMarkFromSignal, /* 660 */ + 0, /* 661 */ + 0, /* 662 */ + 0, /* 663 */ + 0, /* 664 */ + 0, /* 665 */ + 0, /* 666 */ + 0, /* 667 */ + Tcl_UniCharLen, /* 668 */ }; /* !END!: Do not edit above this line. */ diff --git a/generic/tclUtf.c b/generic/tclUtf.c index fcdf80a..fae6edd 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -1773,6 +1773,36 @@ Tcl_UniCharToTitle( /* *---------------------------------------------------------------------- * + * Tcl_Char16Len -- + * + * Find the length of a UniChar string. The str input must be null + * terminated. + * + * Results: + * Returns the length of str in UniChars (not bytes). + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_Char16Len( + const unsigned short *uniStr) /* Unicode string to find length of. */ +{ + int len = 0; + + while (*uniStr != '\0') { + len++; + uniStr++; + } + return len; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_UniCharLen -- * * Find the length of a UniChar string. The str input must be null @@ -1787,9 +1817,10 @@ Tcl_UniCharToTitle( *---------------------------------------------------------------------- */ +#undef Tcl_UniCharLen int Tcl_UniCharLen( - const Tcl_UniChar *uniStr) /* Unicode string to find length of. */ + const int *uniStr) /* Unicode string to find length of. */ { int len = 0; -- cgit v0.12 From 962d2a813067833151a5269899a50a865cd39e91 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 7 Feb 2022 15:35:09 +0000 Subject: Fix [1fe745559a]: 8.7, 9.0: Conditional jump or move depends on uninitialised value in Tcl_UniCharToUtf --- generic/tclUtil.c | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/generic/tclUtil.c b/generic/tclUtil.c index e29afcc..01548ae 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -802,9 +802,11 @@ TclCopyAndCollapse( char c = *src; if (c == '\\') { + char buf[4] = ""; int numRead; - int backslashCount = TclParseBackslash(src, count, &numRead, dst); + int backslashCount = TclParseBackslash(src, count, &numRead, &buf); + memcpy(dst, buf, backslashCount); dst += backslashCount; newCount += backslashCount; src += numRead; -- cgit v0.12 From d6d9d92060423c36c4badb814b2d88be198bf4ed Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 8 Feb 2022 14:23:39 +0000 Subject: Correct previous commit (Windows build error) --- generic/tclUtil.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 01548ae..2f31960 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -804,7 +804,7 @@ TclCopyAndCollapse( if (c == '\\') { char buf[4] = ""; int numRead; - int backslashCount = TclParseBackslash(src, count, &numRead, &buf); + int backslashCount = TclParseBackslash(src, count, &numRead, buf); memcpy(dst, buf, backslashCount); dst += backslashCount; -- cgit v0.12 From 1f35ddfe6233a4a056ba3c4e67a4a7563f6d681f Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 10 Feb 2022 14:16:00 +0000 Subject: Use Tcl_NewWideIntObj() for values that might be bigger than 32-bit --- generic/tclIORChan.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c index 2e25182..3e2bcbe 100644 --- a/generic/tclIORChan.c +++ b/generic/tclIORChan.c @@ -2111,7 +2111,7 @@ ReflectTruncate( Tcl_Preserve(rcPtr); - lenObj = Tcl_NewIntObj(length); + lenObj = Tcl_NewWideIntObj(length); Tcl_IncrRefCount(lenObj); if (InvokeTclMethod(rcPtr,METH_TRUNCATE,lenObj,NULL,&resObj)!=TCL_OK) { @@ -3361,7 +3361,7 @@ ForwardProc( break; case ForwardedTruncate: { - Tcl_Obj *lenObj = Tcl_NewIntObj(paramPtr->truncate.length); + Tcl_Obj *lenObj = Tcl_NewWideIntObj(paramPtr->truncate.length); Tcl_IncrRefCount(lenObj); Tcl_Preserve(rcPtr); -- cgit v0.12 From 42b02c426ce627a263ba827a896f81bad0ebdb4d Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 13 Feb 2022 23:07:51 +0000 Subject: Add libtommath.dll and libtommath.dll.a for windows-arm64 --- libtommath/win64-arm/libtommath.dll | Bin 0 -> 69120 bytes libtommath/win64-arm/libtommath.dll.a | Bin 0 -> 20816 bytes 2 files changed, 0 insertions(+), 0 deletions(-) create mode 100755 libtommath/win64-arm/libtommath.dll create mode 100644 libtommath/win64-arm/libtommath.dll.a diff --git a/libtommath/win64-arm/libtommath.dll b/libtommath/win64-arm/libtommath.dll new file mode 100755 index 0000000..99c57a2 Binary files /dev/null and b/libtommath/win64-arm/libtommath.dll differ diff --git a/libtommath/win64-arm/libtommath.dll.a b/libtommath/win64-arm/libtommath.dll.a new file mode 100644 index 0000000..611522e Binary files /dev/null and b/libtommath/win64-arm/libtommath.dll.a differ -- cgit v0.12 From 46007941c79dfbd5c661d1f46888db7d54730d2e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 14 Feb 2022 13:54:14 +0000 Subject: Fix tommath.lib, which is missing some (deprecated) symbols. --- libtommath/tommath.def | 11 +++++++++++ libtommath/win64-arm/tommath.lib | Bin 26734 -> 28856 bytes 2 files changed, 11 insertions(+) diff --git a/libtommath/tommath.def b/libtommath/tommath.def index 229fae4..879767f 100644 --- a/libtommath/tommath.def +++ b/libtommath/tommath.def @@ -143,3 +143,14 @@ EXPORTS mp_unpack mp_xor mp_zero + s_mp_mul_digs + s_mp_sub + s_mp_add + s_mp_toom_mul + s_mp_mul_digs_fast + s_mp_karatsuba_mul + s_mp_sqr_fast + s_mp_reverse + s_mp_karatsuba_sqr + s_mp_toom_sqr + s_mp_sqr diff --git a/libtommath/win64-arm/tommath.lib b/libtommath/win64-arm/tommath.lib index 2721c6c..f14fbe7 100644 Binary files a/libtommath/win64-arm/tommath.lib and b/libtommath/win64-arm/tommath.lib differ -- cgit v0.12 From 1335b4e324414f01c2f79058a90d4ad3c43aecf3 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 14 Feb 2022 15:28:25 +0000 Subject: Re-build zlib and libtommath for AMD64 and ARM64 to use the UCRT runtime (with llvm-clang toolset) --- compat/zlib/win64-arm/zlib1.dll | Bin 92672 -> 92672 bytes compat/zlib/win64/libz.dll.a | Bin 51638 -> 13002 bytes compat/zlib/win64/zlib1.dll | Bin 116736 -> 99840 bytes libtommath/win64-arm/libtommath.dll | Bin 69120 -> 69120 bytes libtommath/win64-arm/libtommath.dll.a | Bin 20816 -> 22478 bytes libtommath/win64/libtommath.dll | Bin 81408 -> 80896 bytes libtommath/win64/libtommath.dll.a | Bin 128166 -> 22478 bytes 7 files changed, 0 insertions(+), 0 deletions(-) diff --git a/compat/zlib/win64-arm/zlib1.dll b/compat/zlib/win64-arm/zlib1.dll index 7d08dd3..1f43308 100755 Binary files a/compat/zlib/win64-arm/zlib1.dll and b/compat/zlib/win64-arm/zlib1.dll differ diff --git a/compat/zlib/win64/libz.dll.a b/compat/zlib/win64/libz.dll.a index 93be06e..b0c8722 100644 Binary files a/compat/zlib/win64/libz.dll.a and b/compat/zlib/win64/libz.dll.a differ diff --git a/compat/zlib/win64/zlib1.dll b/compat/zlib/win64/zlib1.dll index 81195c3..e893cff 100755 Binary files a/compat/zlib/win64/zlib1.dll and b/compat/zlib/win64/zlib1.dll differ diff --git a/libtommath/win64-arm/libtommath.dll b/libtommath/win64-arm/libtommath.dll index 99c57a2..37bccf7 100755 Binary files a/libtommath/win64-arm/libtommath.dll and b/libtommath/win64-arm/libtommath.dll differ diff --git a/libtommath/win64-arm/libtommath.dll.a b/libtommath/win64-arm/libtommath.dll.a index 611522e..0108f90 100644 Binary files a/libtommath/win64-arm/libtommath.dll.a and b/libtommath/win64-arm/libtommath.dll.a differ diff --git a/libtommath/win64/libtommath.dll b/libtommath/win64/libtommath.dll index 2225faf..ace8fce 100755 Binary files a/libtommath/win64/libtommath.dll and b/libtommath/win64/libtommath.dll differ diff --git a/libtommath/win64/libtommath.dll.a b/libtommath/win64/libtommath.dll.a index 40adaf7..81be3c8 100644 Binary files a/libtommath/win64/libtommath.dll.a and b/libtommath/win64/libtommath.dll.a differ -- cgit v0.12 From 11416a8c3aba74bef614771e7e212ebcc4632e7a Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 14 Feb 2022 15:39:52 +0000 Subject: Use TCLSH_NATIVE for building the zip-file when cross-compiling --- win/makefile.vc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/win/makefile.vc b/win/makefile.vc index 68c2aa7..ee29360 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -603,7 +603,7 @@ $(TCLSCRIPTZIP): $(TCLDDELIB) $(TCLREGLIB) !endif @echo file delete -force {$@} > "$(OUT_DIR)\zipper.tcl" @echo zipfs mkzip {$@} {$(LIBTCLVFS)} {$(LIBTCLVFS)} >> "$(OUT_DIR)\zipper.tcl" - @cd "$(OUT_DIR)" && $(TCLSH) zipper.tcl + @cd "$(OUT_DIR)" && $(TCLSH_NATIVE) zipper.tcl pkgs: -- cgit v0.12 From 79389c01abf1f00ab5d29c677bd86acfe618bd7b Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 14 Feb 2022 17:17:05 +0000 Subject: Correct references to libtommath.dll.a/tommath.lib, depending on compiler (was OK for zlib) --- win/configure | 12 ++++++++---- win/configure.ac | 6 ++++-- 2 files changed, 12 insertions(+), 6 deletions(-) diff --git a/win/configure b/win/configure index 3ae3d41..56342c0 100755 --- a/win/configure +++ b/win/configure @@ -4958,15 +4958,17 @@ then : ZLIB_LIBS=\${ZLIB_DIR_NATIVE}/win64-arm/libz.dll.a + TOMMATH_LIBS=\${TOMMATH_DIR_NATIVE}/win64-arm/libtommath.dll.a + else $as_nop ZLIB_LIBS=\${ZLIB_DIR_NATIVE}/win64-arm/zdll.lib + TOMMATH_LIBS=\${TOMMATH_DIR_NATIVE}/win64-arm/tommath.lib -fi - TOMMATH_LIBS=\${TOMMATH_DIR_NATIVE}/win64/libtommath.dll.a +fi else $as_nop @@ -4975,15 +4977,17 @@ then : ZLIB_LIBS=\${ZLIB_DIR_NATIVE}/win64/libz.dll.a + TOMMATH_LIBS=\${TOMMATH_DIR_NATIVE}/win64/libtommath.dll.a + else $as_nop ZLIB_LIBS=\${ZLIB_DIR_NATIVE}/win64/zdll.lib + TOMMATH_LIBS=\${TOMMATH_DIR_NATIVE}/win64/tommath.lib -fi - TOMMATH_LIBS=\${TOMMATH_DIR_NATIVE}/win64/tommath.lib +fi fi diff --git a/win/configure.ac b/win/configure.ac index 87b6780..01f70b4 100644 --- a/win/configure.ac +++ b/win/configure.ac @@ -144,17 +144,19 @@ AS_IF([test "$tcl_ok" = "yes"], [ AS_IF([test "$do64bit" = "arm64"], [ AS_IF([test "$GCC" == "yes"],[ AC_SUBST(ZLIB_LIBS,[\${ZLIB_DIR_NATIVE}/win64-arm/libz.dll.a]) + AC_SUBST(TOMMATH_LIBS,[\${TOMMATH_DIR_NATIVE}/win64-arm/libtommath.dll.a]) ], [ AC_SUBST(ZLIB_LIBS,[\${ZLIB_DIR_NATIVE}/win64-arm/zdll.lib]) + AC_SUBST(TOMMATH_LIBS,[\${TOMMATH_DIR_NATIVE}/win64-arm/tommath.lib]) ]) - AC_SUBST(TOMMATH_LIBS,[\${TOMMATH_DIR_NATIVE}/win64/libtommath.dll.a]) ], [ AS_IF([test "$GCC" == "yes"],[ AC_SUBST(ZLIB_LIBS,[\${ZLIB_DIR_NATIVE}/win64/libz.dll.a]) + AC_SUBST(TOMMATH_LIBS,[\${TOMMATH_DIR_NATIVE}/win64/libtommath.dll.a]) ], [ AC_SUBST(ZLIB_LIBS,[\${ZLIB_DIR_NATIVE}/win64/zdll.lib]) + AC_SUBST(TOMMATH_LIBS,[\${TOMMATH_DIR_NATIVE}/win64/tommath.lib]) ]) - AC_SUBST(TOMMATH_LIBS,[\${TOMMATH_DIR_NATIVE}/win64/tommath.lib]) ]) ], [ AC_SUBST(ZLIB_LIBS,[\${ZLIB_DIR_NATIVE}/win32/zdll.lib]) -- cgit v0.12 From e67e9e8530f03686180b8523847e1a933db359e0 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 14 Feb 2022 17:53:01 +0000 Subject: Always produce windows binaries on windows-2019, even if windows-latest switches to windows-2022 --- .github/workflows/onefiledist.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/onefiledist.yml b/.github/workflows/onefiledist.yml index b6b3614..8bd8ed2 100644 --- a/.github/workflows/onefiledist.yml +++ b/.github/workflows/onefiledist.yml @@ -100,7 +100,7 @@ jobs: path: 1dist/*.dmg win: name: Windows - runs-on: windows-latest + runs-on: windows-2019 defaults: run: shell: msys2 {0} -- cgit v0.12 From 6cf6873784a9c4f2488341b1fbf6bc8864d24eb1 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 15 Feb 2022 15:04:48 +0000 Subject: Tcl 8.7 requires Visual Studio 2015 or newer --- win/README | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/win/README b/win/README index 3f27f66..3cfcc15 100644 --- a/win/README +++ b/win/README @@ -20,7 +20,7 @@ In order to compile Tcl for Windows, you need the following: and - Visual C++ 6 or newer + Visual Studio 2015 or newer or -- cgit v0.12 From e246b44499e406683adac8035e53d08b4dc0192a Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 17 Feb 2022 17:30:13 +0000 Subject: Deprecate internal macro's TclIsInfinite() and TclIsNan(), since C99 has isinf() and isnan() --- generic/tclBasic.c | 6 +++--- generic/tclExecute.c | 12 ++++++------ generic/tclInt.h | 15 ++++----------- generic/tclLink.c | 6 +++--- generic/tclObj.c | 4 ++-- generic/tclStrToD.c | 2 +- generic/tclTest.c | 2 +- generic/tclUtil.c | 4 ++-- unix/configure | 41 ----------------------------------------- unix/configure.ac | 12 ------------ unix/tclConfig.h.in | 3 --- 11 files changed, 22 insertions(+), 85 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 714bd80..ae7a3dc 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -7841,7 +7841,7 @@ ExprSqrtFunc( if (code != TCL_OK) { return TCL_ERROR; } - if ((d >= 0.0) && TclIsInfinite(d) + if ((d >= 0.0) && isinf(d) && (Tcl_GetBignumFromObj(NULL, objv[1], &big) == TCL_OK)) { mp_int root; mp_err err; @@ -7906,12 +7906,12 @@ CheckDoubleResult( double dResult) { #ifndef ACCEPT_NAN - if (TclIsNaN(dResult)) { + if (isnan(dResult)) { TclExprFloatError(interp, dResult); return TCL_ERROR; } #endif - if ((errno == ERANGE) && ((dResult == 0.0) || TclIsInfinite(dResult))) { + if ((errno == ERANGE) && ((dResult == 0.0) || isinf(dResult))) { /* * When ERANGE signals under/overflow, just accept 0.0 or +/-Inf */ diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 403f3c9..dfb195a 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -514,7 +514,7 @@ VarHashCreateVar( *(ptrPtr) = (ClientData) \ (&((objPtr)->internalRep.wideValue)), TCL_OK) : \ TclHasInternalRep((objPtr), &tclDoubleType) \ - ? (((TclIsNaN((objPtr)->internalRep.doubleValue)) \ + ? (((isnan((objPtr)->internalRep.doubleValue)) \ ? (*(tPtr) = TCL_NUMBER_NAN) \ : (*(tPtr) = TCL_NUMBER_DOUBLE)), \ *(ptrPtr) = (ClientData) \ @@ -8653,7 +8653,7 @@ ExecuteExtendedBinaryMathOp( * Check now for IEEE floating-point error. */ - if (TclIsNaN(dResult)) { + if (isnan(dResult)) { TclExprFloatError(interp, dResult); return GENERAL_ARITHMETIC_ERROR; } @@ -8966,7 +8966,7 @@ TclCompareTwoNumbers( w1 = (Tcl_WideInt)d1; goto wideCompare; case TCL_NUMBER_BIG: - if (TclIsInfinite(d1)) { + if (isinf(d1)) { return (d1 > 0.0) ? MP_GT : MP_LT; } Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); @@ -8999,7 +8999,7 @@ TclCompareTwoNumbers( return compare; case TCL_NUMBER_DOUBLE: d2 = *((const double *)ptr2); - if (TclIsInfinite(d2)) { + if (isinf(d2)) { compare = (d2 > 0.0) ? MP_LT : MP_GT; mp_clear(&big1); return compare; @@ -9602,11 +9602,11 @@ TclExprFloatError( { const char *s; - if ((errno == EDOM) || TclIsNaN(value)) { + if ((errno == EDOM) || isnan(value)) { s = "domain error: argument not in valid range"; Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1)); Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", s, NULL); - } else if ((errno == ERANGE) || TclIsInfinite(value)) { + } else if ((errno == ERANGE) || isinf(value)) { if (value == 0.0) { s = "floating-point value too small to represent"; Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1)); diff --git a/generic/tclInt.h b/generic/tclInt.h index b82a473..75cd6e5 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4965,22 +4965,15 @@ MODULE_SCOPE Tcl_LibraryInitProc Procbodytest_SafeInit; /* *---------------------------------------------------------------- * Macros used by the Tcl core to test for some special double values. - * The ANSI C "prototypes" for these macros are: + * (deprecated) The ANSI C "prototypes" for these macros are: * * MODULE_SCOPE int TclIsInfinite(double d); * MODULE_SCOPE int TclIsNaN(double d); */ -#ifdef _MSC_VER -# define TclIsInfinite(d) (!(_finite((d)))) -# define TclIsNaN(d) (_isnan((d))) -#else -# define TclIsInfinite(d) ((d) > DBL_MAX || (d) < -DBL_MAX) -# ifdef NO_ISNAN -# define TclIsNaN(d) ((d) != (d)) -# else -# define TclIsNaN(d) (isnan(d)) -# endif +#if !defined(TCL_NO_DEPRECATED) && !defined(BUILD_tcl) +# define TclIsInfinite(d) isinf(d) +# define TclIsNaN(d) isnan(d) #endif /* diff --git a/generic/tclLink.c b/generic/tclLink.c index 5baa092..39f5345 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -606,7 +606,7 @@ EqualDouble( { return (a == b) #ifdef ACCEPT_NAN - || (TclIsNaN(a) && TclIsNaN(b)) + || (isnan(a) && isnan(b)) #endif /* ACCEPT_NAN */ ; } @@ -615,9 +615,9 @@ static inline int IsSpecial( double a) { - return TclIsInfinite(a) + return isinf(a) #ifdef ACCEPT_NAN - || TclIsNaN(a) + || isnan(a) #endif /* ACCEPT_NAN */ ; } diff --git a/generic/tclObj.c b/generic/tclObj.c index 4ac9936..a06b8fd 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -2547,7 +2547,7 @@ Tcl_GetDoubleFromObj( { do { if (objPtr->typePtr == &tclDoubleType) { - if (TclIsNaN(objPtr->internalRep.doubleValue)) { + if (isnan(objPtr->internalRep.doubleValue)) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "floating point value is Not a Number", -1)); @@ -3880,7 +3880,7 @@ TclGetNumberFromObj( { do { if (objPtr->typePtr == &tclDoubleType) { - if (TclIsNaN(objPtr->internalRep.doubleValue)) { + if (isnan(objPtr->internalRep.doubleValue)) { *typePtr = TCL_NUMBER_NAN; } else { *typePtr = TCL_NUMBER_DOUBLE; diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c index 5ee5945..a7986b0 100644 --- a/generic/tclStrToD.c +++ b/generic/tclStrToD.c @@ -4832,7 +4832,7 @@ Tcl_InitBignumFromDouble( * Infinite values can't convert to bignum. */ - if (TclIsInfinite(d)) { + if (isinf(d)) { if (interp != NULL) { const char *s = "integer value too large to represent"; diff --git a/generic/tclTest.c b/generic/tclTest.c index 0db8587..009c95f 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -1652,7 +1652,7 @@ TestdoubledigitsObjCmd( if (status != TCL_OK) { doubleType = Tcl_GetObjType("double"); if (Tcl_FetchInternalRep(objv[1], doubleType) - && TclIsNaN(objv[1]->internalRep.doubleValue)) { + && isnan(objv[1]->internalRep.doubleValue)) { status = TCL_OK; memcpy(&d, &(objv[1]->internalRep.doubleValue), sizeof(double)); } diff --git a/generic/tclUtil.c b/generic/tclUtil.c index a96c752..66d1009 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -3231,7 +3231,7 @@ Tcl_PrintDouble( * Handle NaN. */ - if (TclIsNaN(value)) { + if (isnan(value)) { TclFormatNaN(value, dst); return; } @@ -3240,7 +3240,7 @@ Tcl_PrintDouble( * Handle infinities. */ - if (TclIsInfinite(value)) { + if (isinf(value)) { /* * Remember to copy the terminating NUL too. */ diff --git a/unix/configure b/unix/configure index 452d5da..5d18196 100755 --- a/unix/configure +++ b/unix/configure @@ -10341,47 +10341,6 @@ fi #-------------------------------------------------------------------- -# Check for support of isnan() function or macro -#-------------------------------------------------------------------- - -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking isnan" >&5 -printf %s "checking isnan... " >&6; } -if test ${tcl_cv_isnan+y} -then : - printf %s "(cached) " >&6 -else $as_nop - - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ -#include -int -main (void) -{ - -isnan(0.0); /* Generates an error if isnan is missing */ - - ; - return 0; -} -_ACEOF -if ac_fn_c_try_link "$LINENO" -then : - tcl_cv_isnan=yes -else $as_nop - tcl_cv_isnan=no -fi -rm -f core conftest.err conftest.$ac_objext conftest.beam \ - conftest$ac_exeext conftest.$ac_ext -fi -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_isnan" >&5 -printf "%s\n" "$tcl_cv_isnan" >&6; } -if test $tcl_cv_isnan = no; then - -printf "%s\n" "#define NO_ISNAN 1" >>confdefs.h - -fi - -#-------------------------------------------------------------------- # Darwin specific API checks and defines #-------------------------------------------------------------------- diff --git a/unix/configure.ac b/unix/configure.ac index 335c5a2..7acb5ce 100644 --- a/unix/configure.ac +++ b/unix/configure.ac @@ -562,18 +562,6 @@ SC_ENABLE_LANGINFO AC_CHECK_FUNCS(cfmakeraw chflags mkstemps) #-------------------------------------------------------------------- -# Check for support of isnan() function or macro -#-------------------------------------------------------------------- - -AC_CACHE_CHECK([isnan], tcl_cv_isnan, [ - AC_LINK_IFELSE([AC_LANG_PROGRAM([[#include ]], [[ -isnan(0.0); /* Generates an error if isnan is missing */ -]])],[tcl_cv_isnan=yes],[tcl_cv_isnan=no])]) -if test $tcl_cv_isnan = no; then - AC_DEFINE(NO_ISNAN, 1, [Do we have a usable 'isnan'?]) -fi - -#-------------------------------------------------------------------- # Darwin specific API checks and defines #-------------------------------------------------------------------- diff --git a/unix/tclConfig.h.in b/unix/tclConfig.h.in index 5c24d40..1acc55d 100644 --- a/unix/tclConfig.h.in +++ b/unix/tclConfig.h.in @@ -349,9 +349,6 @@ /* Do we have getwd() */ #undef NO_GETWD -/* Do we have a usable 'isnan'? */ -#undef NO_ISNAN - /* Do we have memmove()? */ #undef NO_MEMMOVE -- cgit v0.12 From 058d08c66ff3c104f9fbc29919b0220f888374f3 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 18 Feb 2022 16:57:01 +0000 Subject: Fix [22547f9053]: TIP 519 compiler warning --- generic/tclOODefineCmds.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index cadfee5..4af23c2 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -2002,7 +2002,7 @@ TclOODefineMethodObjCmd( } if (objc == 5) { if (Tcl_GetIndexFromObj(interp, objv[2], exportModes, "export flag", - 0, (int *) &exportMode) != TCL_OK) { + 0, &exportMode) != TCL_OK) { return TCL_ERROR; } switch (exportMode) { -- cgit v0.12 From 671915641bb91ac0aed5250cf92efbfc30f9e0a4 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 24 Feb 2022 22:13:52 +0000 Subject: Consistancy in TCL_UTF_MAX check --- generic/tclEncoding.c | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index fd83855..4630a02 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -2798,7 +2798,7 @@ UtfToUcs2Proc( { const char *srcStart, *srcEnd, *srcClose, *dstStart, *dstEnd; int result, numChars; -#if TCL_UTF_MAX <= 3 +#if TCL_UTF_MAX < 4 int len; #endif Tcl_UniChar ch = 0; @@ -2829,7 +2829,7 @@ UtfToUcs2Proc( result = TCL_CONVERT_NOSPACE; break; } -#if TCL_UTF_MAX <= 3 +#if TCL_UTF_MAX < 4 src += (len = TclUtfToUniChar(src, &ch)); if ((ch >= 0xD800) && (len < 3)) { src += TclUtfToUniChar(src, &ch); @@ -3242,7 +3242,7 @@ Iso88591FromUtfProc( */ if (ch > 0xFF -#if TCL_UTF_MAX <= 3 +#if TCL_UTF_MAX < 4 || ((ch >= 0xD800) && (len < 3)) #endif ) { @@ -3250,7 +3250,7 @@ Iso88591FromUtfProc( result = TCL_CONVERT_UNKNOWN; break; } -#if TCL_UTF_MAX <= 3 +#if TCL_UTF_MAX < 4 if ((ch >= 0xD800) && (len < 3)) { len = 4; } -- cgit v0.12 From b788457ad48d5cc34b431418f7d076d83f78b5ff Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 24 Feb 2022 22:20:17 +0000 Subject: 3 more files with TCL_UTF_MAX checks --- generic/tclDecls.h | 2 +- generic/tclStringObj.c | 4 ++-- generic/tclUtf.c | 16 ++++++++-------- 3 files changed, 11 insertions(+), 11 deletions(-) diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 939bae9..fd5f81b 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -4283,7 +4283,7 @@ extern const TclStubs *tclStubsPtr; #undef Tcl_StringMatch #define Tcl_StringMatch(str, pattern) Tcl_StringCaseMatch((str), (pattern), 0) -#if TCL_UTF_MAX <= 3 +#if TCL_UTF_MAX < 4 # undef Tcl_UniCharToUtfDString # define Tcl_UniCharToUtfDString Tcl_Char16ToUtfDString # undef Tcl_UtfToUniCharDString diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index bee1e3e..f240bc0 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -571,7 +571,7 @@ Tcl_GetUniChar( return -1; } ch = stringPtr->unicode[index]; -#if TCL_UTF_MAX <= 3 +#if TCL_UTF_MAX < 4 /* See: bug [11ae2be95dac9417] */ if ((ch & 0xF800) == 0xD800) { if (ch & 0x400) { @@ -785,7 +785,7 @@ Tcl_GetRange( TclNewObj(newObjPtr); return newObjPtr; } -#if TCL_UTF_MAX <= 3 +#if TCL_UTF_MAX < 4 /* See: bug [11ae2be95dac9417] */ if ((first > 0) && ((stringPtr->unicode[first] & 0xFC00) == 0xDC00) && ((stringPtr->unicode[first-1] & 0xFC00) == 0xD800)) { diff --git a/generic/tclUtf.c b/generic/tclUtf.c index fae6edd..169f240 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -1137,7 +1137,7 @@ Tcl_UniCharAtIndex( i = TclUtfToUniChar(src, &ch); src += i; } -#if TCL_UTF_MAX <= 3 +#if TCL_UTF_MAX < 4 if ((ch >= 0xD800) && (i < 3)) { /* Index points at character following high Surrogate */ return -1; @@ -1153,7 +1153,7 @@ Tcl_UniCharAtIndex( * Tcl_UtfAtIndex -- * * Returns a pointer to the specified character (not byte) position in - * the UTF-8 string. If TCL_UTF_MAX <= 3, characters > U+FFFF count as + * the UTF-8 string. If TCL_UTF_MAX < 4, characters > U+FFFF count as * 2 positions, but then the pointer should never be placed between * the two positions. * @@ -1178,7 +1178,7 @@ Tcl_UtfAtIndex( len = TclUtfToUniChar(src, &ch); src += len; } -#if TCL_UTF_MAX <= 3 +#if TCL_UTF_MAX < 4 if ((ch >= 0xD800) && (len < 3)) { /* Index points at character following high Surrogate */ src += TclUtfToUniChar(src, &ch); @@ -1500,7 +1500,7 @@ Tcl_UtfNcmp( cs += TclUtfToUniChar(cs, &ch1); ct += TclUtfToUniChar(ct, &ch2); if (ch1 != ch2) { -#if TCL_UTF_MAX <= 3 +#if TCL_UTF_MAX < 4 /* Surrogates always report higher than non-surrogates */ if (((ch1 & 0xFC00) == 0xD800)) { if ((ch2 & 0xFC00) != 0xD800) { @@ -1551,7 +1551,7 @@ Tcl_UtfNcasecmp( cs += TclUtfToUniChar(cs, &ch1); ct += TclUtfToUniChar(ct, &ch2); if (ch1 != ch2) { -#if TCL_UTF_MAX <= 3 +#if TCL_UTF_MAX < 4 /* Surrogates always report higher than non-surrogates */ if (((ch1 & 0xFC00) == 0xD800)) { if ((ch2 & 0xFC00) != 0xD800) { @@ -1600,7 +1600,7 @@ TclUtfCmp( cs += TclUtfToUniChar(cs, &ch1); ct += TclUtfToUniChar(ct, &ch2); if (ch1 != ch2) { -#if TCL_UTF_MAX <= 3 +#if TCL_UTF_MAX < 4 /* Surrogates always report higher than non-surrogates */ if (((ch1 & 0xFC00) == 0xD800)) { if ((ch2 & 0xFC00) != 0xD800) { @@ -1646,7 +1646,7 @@ TclUtfCasecmp( cs += TclUtfToUniChar(cs, &ch1); ct += TclUtfToUniChar(ct, &ch2); if (ch1 != ch2) { -#if TCL_UTF_MAX <= 3 +#if TCL_UTF_MAX < 4 /* Surrogates always report higher than non-surrogates */ if (((ch1 & 0xFC00) == 0xD800)) { if ((ch2 & 0xFC00) != 0xD800) { @@ -2673,7 +2673,7 @@ TclUniCharMatch( *--------------------------------------------------------------------------- */ -#if TCL_UTF_MAX <= 3 +#if TCL_UTF_MAX < 4 int TclUtfToUCS4( const char *src, /* The UTF-8 string. */ -- cgit v0.12 From 75e8b346e2193f1c524cbbb741583e6ab4dfc417 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sat, 5 Mar 2022 10:32:38 +0000 Subject: Add "const" to Tcl_SetNotifier() argument. Should have been part of TIP #27, looooooong ago. This simplifier tclXtNotify.c a lot. --- doc/Notifier.3 | 2 +- generic/tcl.decls | 2 +- generic/tclDecls.h | 5 +++-- generic/tclNotify.c | 2 +- unix/tclXtNotify.c | 13 +++++++------ 5 files changed, 13 insertions(+), 11 deletions(-) diff --git a/doc/Notifier.3 b/doc/Notifier.3 index ec9f910..efbe216 100644 --- a/doc/Notifier.3 +++ b/doc/Notifier.3 @@ -103,7 +103,7 @@ passed to \fBTcl_DoOneEvent\fR. .AP int mode in Indicates whether events should be serviced by \fBTcl_ServiceAll\fR. Must be one of \fBTCL_SERVICE_NONE\fR or \fBTCL_SERVICE_ALL\fR. -.AP Tcl_NotifierProcs* notifierProcPtr in +.AP const Tcl_NotifierProcs* notifierProcPtr in Structure of function pointers describing notifier procedures that are to replace the ones installed in the executable. See \fBREPLACING THE NOTIFIER\fR for details. diff --git a/generic/tcl.decls b/generic/tcl.decls index a6a9d5c..8e21b1d 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -1365,7 +1365,7 @@ declare 385 { Tcl_Obj *patternObj) } declare 386 { - void Tcl_SetNotifier(Tcl_NotifierProcs *notifierProcPtr) + void Tcl_SetNotifier(const Tcl_NotifierProcs *notifierProcPtr) } declare 387 { Tcl_Mutex *Tcl_GetAllocMutex(void) diff --git a/generic/tclDecls.h b/generic/tclDecls.h index fd5f81b..87a90af 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1164,7 +1164,8 @@ void Tcl_AppendUnicodeToObj(Tcl_Obj *objPtr, EXTERN int Tcl_RegExpMatchObj(Tcl_Interp *interp, Tcl_Obj *textObj, Tcl_Obj *patternObj); /* 386 */ -EXTERN void Tcl_SetNotifier(Tcl_NotifierProcs *notifierProcPtr); +EXTERN void Tcl_SetNotifier( + const Tcl_NotifierProcs *notifierProcPtr); /* 387 */ EXTERN Tcl_Mutex * Tcl_GetAllocMutex(void); /* 388 */ @@ -2377,7 +2378,7 @@ typedef struct TclStubs { Tcl_Obj * (*tcl_GetRange) (Tcl_Obj *objPtr, int first, int last); /* 383 */ TCL_DEPRECATED_API("Use Tcl_AppendStringsToObj") void (*tcl_AppendUnicodeToObj) (Tcl_Obj *objPtr, const Tcl_UniChar *unicode, int length); /* 384 */ int (*tcl_RegExpMatchObj) (Tcl_Interp *interp, Tcl_Obj *textObj, Tcl_Obj *patternObj); /* 385 */ - void (*tcl_SetNotifier) (Tcl_NotifierProcs *notifierProcPtr); /* 386 */ + void (*tcl_SetNotifier) (const Tcl_NotifierProcs *notifierProcPtr); /* 386 */ Tcl_Mutex * (*tcl_GetAllocMutex) (void); /* 387 */ int (*tcl_GetChannelNames) (Tcl_Interp *interp); /* 388 */ int (*tcl_GetChannelNamesEx) (Tcl_Interp *interp, const char *pattern); /* 389 */ diff --git a/generic/tclNotify.c b/generic/tclNotify.c index 12b40b1..1140168 100644 --- a/generic/tclNotify.c +++ b/generic/tclNotify.c @@ -226,7 +226,7 @@ TclFinalizeNotifier(void) void Tcl_SetNotifier( - Tcl_NotifierProcs *notifierProcPtr) + const Tcl_NotifierProcs *notifierProcPtr) { tclNotifierHooks = *notifierProcPtr; diff --git a/unix/tclXtNotify.c b/unix/tclXtNotify.c index 0210cd3..45bda3e 100644 --- a/unix/tclXtNotify.c +++ b/unix/tclXtNotify.c @@ -181,7 +181,13 @@ TclSetAppContext( void InitNotifier(void) { - Tcl_NotifierProcs np; + static const Tcl_NotifierProcs np = + SetTimer, + WaitForEvent, + CreateFileHandler, + DeleteFileHandler, + NULL, NULL, NULL, NULL + }; /* * Only reinitialize if we are not in exit handling. The notifier can get @@ -193,11 +199,6 @@ InitNotifier(void) return; } - memset(&np, 0, sizeof(np)); - np.createFileHandlerProc = CreateFileHandler; - np.deleteFileHandlerProc = DeleteFileHandler; - np.setTimerProc = SetTimer; - np.waitForEventProc = WaitForEvent; Tcl_SetNotifier(&np); /* -- cgit v0.12 From 6ec7e10a1634a0a9c10ed2cf90072ba723d701ce Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sat, 5 Mar 2022 21:56:47 +0000 Subject: -nothrow -> -nocomplain --- doc/Encoding.3 | 2 +- generic/tcl.h | 4 ++-- generic/tclCmdAH.c | 22 ++++++++-------------- generic/tclEncoding.c | 6 +++--- tests/cmdAH.test | 4 ++-- tests/encoding.test | 52 +++++++++++++++++++++++++-------------------------- tests/safe.test | 8 ++++---- 7 files changed, 46 insertions(+), 52 deletions(-) diff --git a/doc/Encoding.3 b/doc/Encoding.3 index bffa0c3..dc37519 100644 --- a/doc/Encoding.3 +++ b/doc/Encoding.3 @@ -114,7 +114,7 @@ byte is converted and then to reset to an initial state. \fBTCL_ENCODING_STOPONERROR\fR signifies that the conversion routine should return immediately upon reading a source character that does not exist in the target encoding; otherwise a default fallback character will -automatically be substituted. The flag \fBTCL_ENCODING_NO_THROW\fR has +automatically be substituted. The flag \fBTCL_ENCODING_NOCOMPLAIN\fR has no effect, it is reserved for Tcl 9.0. The flag \fBTCL_ENCODING_MODIFIED\fR makes \fBTcl_UtfToExternalDStringEx\fR and \fBTcl_UtfToExternal\fR produce the byte sequence \exC0\ex80 in stead of \ex00, for the utf-8/cesu-8 encoders. diff --git a/generic/tcl.h b/generic/tcl.h index 783d576..ef0fa75 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -2081,7 +2081,7 @@ typedef struct Tcl_EncodingType { * 0x00. Only valid for "utf-8" and "cesu-8". * This flag is implicit for external -> internal conversions, * optional for internal -> external conversions. - * TCL_ENCODING_NO_THROW - If set, the converter + * TCL_ENCODING_NOCOMPLAIN - If set, the converter * substitutes the problematic character(s) with * one or more "close" characters in the * destination buffer and then continues to @@ -2097,7 +2097,7 @@ typedef struct Tcl_EncodingType { #define TCL_ENCODING_NO_TERMINATE 0x08 #define TCL_ENCODING_CHAR_LIMIT 0x10 #define TCL_ENCODING_MODIFIED 0x20 -#define TCL_ENCODING_NO_THROW 0x40 +#define TCL_ENCODING_NOCOMPLAIN 0x40 /* * The following definitions are the error codes returned by the conversion diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 5b655ef..60a2c42 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -553,7 +553,7 @@ EncodingConvertfromObjCmd( #if TCL_MAJOR_VERSION > 8 || defined(TCL_NO_DEPRECATED) int flags = TCL_ENCODING_STOPONERROR; #else - int flags = TCL_ENCODING_NO_THROW; + int flags = TCL_ENCODING_NOCOMPLAIN; #endif size_t result; @@ -564,11 +564,8 @@ EncodingConvertfromObjCmd( data = objv[objc - 1]; bytesPtr = Tcl_GetString(objv[1]); if (bytesPtr[0] == '-' && bytesPtr[1] == 'n' - && !strncmp(bytesPtr, "-nothrow", strlen(bytesPtr))) { - flags = TCL_ENCODING_NO_THROW; - } else if (bytesPtr[0] == '-' && bytesPtr[1] == 's' - && !strncmp(bytesPtr, "-stoponerror", strlen(bytesPtr))) { - flags = TCL_ENCODING_STOPONERROR; + && !strncmp(bytesPtr, "-nocomplain", strlen(bytesPtr))) { + flags = TCL_ENCODING_NOCOMPLAIN; } else if (objc < 4) { if (Tcl_GetEncodingFromObj(interp, objv[objc - 2], &encoding) != TCL_OK) { return TCL_ERROR; @@ -584,7 +581,7 @@ EncodingConvertfromObjCmd( } } else { encConvFromError: - Tcl_WrongNumArgs(interp, 1, objv, "?-nothrow? ?encoding? data"); + Tcl_WrongNumArgs(interp, 1, objv, "?-nocomplain? ?encoding? data"); return TCL_ERROR; } @@ -660,7 +657,7 @@ EncodingConverttoObjCmd( #if TCL_MAJOR_VERSION > 8 || defined(TCL_NO_DEPRECATED) int flags = TCL_ENCODING_STOPONERROR; #else - int flags = TCL_ENCODING_NO_THROW; + int flags = TCL_ENCODING_NOCOMPLAIN; #endif if (objc == 2) { @@ -670,11 +667,8 @@ EncodingConverttoObjCmd( data = objv[objc - 1]; stringPtr = Tcl_GetString(objv[1]); if (stringPtr[0] == '-' && stringPtr[1] == 'n' - && !strncmp(stringPtr, "-nothrow", strlen(stringPtr))) { - flags = TCL_ENCODING_NO_THROW; - } else if (stringPtr[0] == '-' && stringPtr[1] == 's' - && !strncmp(stringPtr, "-stoponerror", strlen(stringPtr))) { - flags = TCL_ENCODING_STOPONERROR; + && !strncmp(stringPtr, "-nocomplain", strlen(stringPtr))) { + flags = TCL_ENCODING_NOCOMPLAIN; } else if (objc < 4) { if (Tcl_GetEncodingFromObj(interp, objv[objc - 2], &encoding) != TCL_OK) { return TCL_ERROR; @@ -690,7 +684,7 @@ EncodingConverttoObjCmd( } } else { encConvToError: - Tcl_WrongNumArgs(interp, 1, objv, "?-nothrow? ?encoding? data"); + Tcl_WrongNumArgs(interp, 1, objv, "?-nocomplain? ?encoding? data"); return TCL_ERROR; } diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index d1dbb09..b6d5dcf 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -1158,7 +1158,7 @@ Tcl_ExternalToUtfDString( * Possible flags values: * TCL_ENCODING_STOPONERROR: don't replace invalid characters/bytes but * return the first error position (Default in Tcl 9.0). - * TCL_ENCODING_NO_THROW: replace invalid characters/bytes by a default + * TCL_ENCODING_NOCOMPLAIN: replace invalid characters/bytes by a default * fallback character. Always return -1 (Default in Tcl 8.7). * TCL_ENCODING_MODIFIED: convert NULL bytes to \xC0\x80 in stead of 0x00. * Only valid for "utf-8" and "cesu-8". This flag may be used together @@ -1397,7 +1397,7 @@ Tcl_UtfToExternalDString( * Possible flags values: * TCL_ENCODING_STOPONERROR: don't replace invalid characters/bytes but * return the first error position (Default in Tcl 9.0). - * TCL_ENCODING_NO_THROW: replace invalid characters/bytes by a default + * TCL_ENCODING_NOCOMPLAIN: replace invalid characters/bytes by a default * fallback character. Always return -1 (Default in Tcl 8.7). * TCL_ENCODING_MODIFIED: convert NULL bytes to \xC0\x80 in stead of 0x00. * Only valid for "utf-8" and "cesu-8". This flag may be used together @@ -2288,7 +2288,7 @@ BinaryProc( */ #if TCL_MAJOR_VERSION > 8 || defined(TCL_NO_DEPRECATED) -# define STOPONERROR !(flags & TCL_ENCODING_NO_THROW) +# define STOPONERROR !(flags & TCL_ENCODING_NOCOMPLAIN) #else # define STOPONERROR (flags & TCL_ENCODING_STOPONERROR) #endif diff --git a/tests/cmdAH.test b/tests/cmdAH.test index 7f86275..d787c7f 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -178,7 +178,7 @@ test cmdAH-4.2 {Tcl_EncodingObjCmd} -returnCodes error -body { } -result {unknown or ambiguous subcommand "foo": must be convertfrom, convertto, dirs, names, or system} test cmdAH-4.3 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding convertto -} -result {wrong # args: should be "encoding convertto ?-nothrow? ?encoding? data"} +} -result {wrong # args: should be "encoding convertto ?-nocomplain? ?encoding? data"} test cmdAH-4.4 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding convertto foo bar } -result {unknown encoding "foo"} @@ -200,7 +200,7 @@ test cmdAH-4.6 {Tcl_EncodingObjCmd} -setup { } -result 8C test cmdAH-4.7 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding convertfrom -} -result {wrong # args: should be "encoding convertfrom ?-nothrow? ?encoding? data"} +} -result {wrong # args: should be "encoding convertfrom ?-nocomplain? ?encoding? data"} test cmdAH-4.8 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding convertfrom foo bar } -result {unknown encoding "foo"} diff --git a/tests/encoding.test b/tests/encoding.test index c6865d9..bf82493 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -299,7 +299,7 @@ test encoding-11.11 {encoding: extended Unicode UTF-32} { test encoding-12.1 {LoadTableEncoding: normal encoding} { set x [encoding convertto iso8859-3 Ġ] - append x [encoding convertto -nothrow iso8859-3 Õ] + append x [encoding convertto -nocomplain iso8859-3 Õ] append x [encoding convertfrom iso8859-3 Õ] } "Õ?Ġ" test encoding-12.2 {LoadTableEncoding: single-byte encoding} { @@ -348,67 +348,67 @@ test encoding-15.5 {UtfToUtfProc emoji character input} { } "4 😂" test encoding-15.6 {UtfToUtfProc emoji character output} { set x \uDE02\uD83D\uDE02\uD83D - set y [encoding convertto -nothrow utf-8 \uDE02\uD83D\uDE02\uD83D] + set y [encoding convertto -nocomplain utf-8 \uDE02\uD83D\uDE02\uD83D] binary scan $y H* z list [string length $y] $z } {10 edb882f09f9882eda0bd} test encoding-15.7 {UtfToUtfProc emoji character output} { set x \uDE02\uD83D\uD83D - set y [encoding convertto -nothrow utf-8 \uDE02\uD83D\uD83D] + set y [encoding convertto -nocomplain utf-8 \uDE02\uD83D\uD83D] binary scan $y H* z list [string length $x] [string length $y] $z } {3 9 edb882eda0bdeda0bd} test encoding-15.8 {UtfToUtfProc emoji character output} { set x \uDE02\uD83Dé - set y [encoding convertto -nothrow utf-8 \uDE02\uD83Dé] + set y [encoding convertto -nocomplain utf-8 \uDE02\uD83Dé] binary scan $y H* z list [string length $x] [string length $y] $z } {3 8 edb882eda0bdc3a9} test encoding-15.9 {UtfToUtfProc emoji character output} { set x \uDE02\uD83DX - set y [encoding convertto -nothrow utf-8 \uDE02\uD83DX] + set y [encoding convertto -nocomplain utf-8 \uDE02\uD83DX] binary scan $y H* z list [string length $x] [string length $y] $z } {3 7 edb882eda0bd58} test encoding-15.10 {UtfToUtfProc high surrogate character output} { set x \uDE02é - set y [encoding convertto -nothrow utf-8 \uDE02é] + set y [encoding convertto -nocomplain utf-8 \uDE02é] binary scan $y H* z list [string length $x] [string length $y] $z } {2 5 edb882c3a9} test encoding-15.11 {UtfToUtfProc low surrogate character output} { set x \uDA02é - set y [encoding convertto -nothrow utf-8 \uDA02é] + set y [encoding convertto -nocomplain utf-8 \uDA02é] binary scan $y H* z list [string length $x] [string length $y] $z } {2 5 eda882c3a9} test encoding-15.12 {UtfToUtfProc high surrogate character output} { set x \uDE02Y - set y [encoding convertto -nothrow utf-8 \uDE02Y] + set y [encoding convertto -nocomplain utf-8 \uDE02Y] binary scan $y H* z list [string length $x] [string length $y] $z } {2 4 edb88259} test encoding-15.13 {UtfToUtfProc low surrogate character output} { set x \uDA02Y - set y [encoding convertto -nothrow utf-8 \uDA02Y] + set y [encoding convertto -nocomplain utf-8 \uDA02Y] binary scan $y H* z list [string length $x] [string length $y] $z } {2 4 eda88259} test encoding-15.14 {UtfToUtfProc high surrogate character output} { set x \uDE02 - set y [encoding convertto -nothrow utf-8 \uDE02] + set y [encoding convertto -nocomplain utf-8 \uDE02] binary scan $y H* z list [string length $x] [string length $y] $z } {1 3 edb882} test encoding-15.15 {UtfToUtfProc low surrogate character output} { set x \uDA02 - set y [encoding convertto -nothrow utf-8 \uDA02] + set y [encoding convertto -nocomplain utf-8 \uDA02] binary scan $y H* z list [string length $x] [string length $y] $z } {1 3 eda882} test encoding-15.16 {UtfToUtfProc: Invalid 4-byte UTF-8, see [ed29806ba]} { set x \xF0\xA0\xA1\xC2 - set y [encoding convertfrom -nothrow utf-8 \xF0\xA0\xA1\xC2] + set y [encoding convertfrom -nocomplain utf-8 \xF0\xA0\xA1\xC2] list [string length $x] $y } "4 \xF0\xA0\xA1\xC2" test encoding-15.17 {UtfToUtfProc emoji character output} { @@ -489,10 +489,10 @@ test encoding-17.2 {UtfToUcs2Proc} -body { encoding convertfrom utf-16 [encoding convertto ucs-2 "\U460DC"] } -result "\uFFFD" test encoding-17.3 {UtfToUtf16Proc} -body { - encoding convertto -nothrow utf-16be "\uDCDC" + encoding convertto -nocomplain utf-16be "\uDCDC" } -result "\xFF\xFD" test encoding-17.4 {UtfToUtf16Proc} -body { - encoding convertto -nothrow utf-16le "\uD8D8" + encoding convertto -nocomplain utf-16le "\uD8D8" } -result "\xFD\xFF" test encoding-17.5 {UtfToUtf16Proc} -body { encoding convertto utf-32le "\U460DC" @@ -617,25 +617,25 @@ test encoding-24.4 {Parse valid or invalid utf-8} { string length [encoding convertfrom utf-8 "\xC0\x80"] } 1 test encoding-24.5 {Parse valid or invalid utf-8} { - string length [encoding convertfrom -nothrow utf-8 "\xC0\x81"] + string length [encoding convertfrom -nocomplain utf-8 "\xC0\x81"] } 2 test encoding-24.6 {Parse valid or invalid utf-8} { - string length [encoding convertfrom -nothrow utf-8 "\xC1\xBF"] + string length [encoding convertfrom -nocomplain utf-8 "\xC1\xBF"] } 2 test encoding-24.7 {Parse valid or invalid utf-8} { string length [encoding convertfrom utf-8 "\xC2\x80"] } 1 test encoding-24.8 {Parse valid or invalid utf-8} { - string length [encoding convertfrom -nothrow utf-8 "\xE0\x80\x80"] + string length [encoding convertfrom -nocomplain utf-8 "\xE0\x80\x80"] } 3 test encoding-24.9 {Parse valid or invalid utf-8} { - string length [encoding convertfrom -nothrow utf-8 "\xE0\x9F\xBF"] + string length [encoding convertfrom -nocomplain utf-8 "\xE0\x9F\xBF"] } 3 test encoding-24.10 {Parse valid or invalid utf-8} { string length [encoding convertfrom utf-8 "\xE0\xA0\x80"] } 1 test encoding-24.11 {Parse valid or invalid utf-8} { - string length [encoding convertfrom -nothrow utf-8 "\xEF\xBF\xBF"] + string length [encoding convertfrom -nocomplain utf-8 "\xEF\xBF\xBF"] } 1 test encoding-24.12 {Parse valid or invalid utf-8} -constraints deprecated -body { encoding convertfrom utf-8 "\xC0\x81" @@ -661,18 +661,18 @@ test encoding-24.18 {Parse valid or invalid utf-8} -constraints {testbytestring test encoding-24.19 {Parse valid or invalid utf-8} -constraints deprecated -body { encoding convertto utf-8 "ZX\uD800" } -returnCodes 1 -match glob -result "unexpected character at index 2: 'U+00D800'" -test encoding-24.20 {Parse with -nothrow but without providing encoding} { - string length [encoding convertfrom -nothrow "\x20"] +test encoding-24.20 {Parse with -nocomplain but without providing encoding} { + string length [encoding convertfrom -nocomplain "\x20"] } 1 -test encoding-24.21 {Parse with -nothrow but without providing encoding} { - string length [encoding convertto -nothrow "\x20"] +test encoding-24.21 {Parse with -nocomplain but without providing encoding} { + string length [encoding convertto -nocomplain "\x20"] } 1 test encoding-24.22 {Syntax error, two encodings} -body { encoding convertfrom iso8859-1 utf-8 "ZX\uD800" -} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertfrom ?-nothrow? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertfrom ?-nocomplain? ?encoding? data"} test encoding-24.23 {Syntax error, two encodings} -body { encoding convertto iso8859-1 utf-8 "ZX\uD800" -} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertto ?-nothrow? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertto ?-nocomplain? ?encoding? data"} file delete [file join [temporaryDirectory] iso2022.txt] @@ -828,7 +828,7 @@ test encoding-28.0 {all encodings load} -body { set string hello foreach name [encoding names] { incr count - encoding convertto -nothrow $name $string + encoding convertto -nocomplain $name $string # discard the cached internal representation of Tcl_Encoding # Unfortunately, without this, encoding 2-1 fails. diff --git a/tests/safe.test b/tests/safe.test index d5e2f00..5f3eae8 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -1269,7 +1269,7 @@ test safe-11.7 {testing safe encoding} -setup { interp eval $i encoding convertfrom } -returnCodes error -cleanup { safe::interpDelete $i -} -result {wrong # args: should be "encoding convertfrom ?-nothrow? ?encoding? data"} +} -result {wrong # args: should be "encoding convertfrom ?-nocomplain? ?encoding? data"} test safe-11.7.1 {testing safe encoding} -setup { set i [safe::interpCreate] } -body { @@ -1278,7 +1278,7 @@ test safe-11.7.1 {testing safe encoding} -setup { } -returnCodes ok -match glob -cleanup { unset -nocomplain m o safe::interpDelete $i -} -result {wrong # args: should be "encoding convertfrom ?-nothrow? ?encoding? data" +} -result {wrong # args: should be "encoding convertfrom ?-nocomplain? ?encoding? data" while executing "encoding convertfrom" invoked from within @@ -1291,7 +1291,7 @@ test safe-11.8 {testing safe encoding} -setup { interp eval $i encoding convertto } -returnCodes error -cleanup { safe::interpDelete $i -} -result {wrong # args: should be "encoding convertto ?-nothrow? ?encoding? data"} +} -result {wrong # args: should be "encoding convertto ?-nocomplain? ?encoding? data"} test safe-11.8.1 {testing safe encoding} -setup { set i [safe::interpCreate] } -body { @@ -1300,7 +1300,7 @@ test safe-11.8.1 {testing safe encoding} -setup { } -returnCodes ok -match glob -cleanup { unset -nocomplain m o safe::interpDelete $i -} -result {wrong # args: should be "encoding convertto ?-nothrow? ?encoding? data" +} -result {wrong # args: should be "encoding convertto ?-nocomplain? ?encoding? data" while executing "encoding convertto" invoked from within -- cgit v0.12 From 2071722ddec667bebfb47e91d684cc37be2d81e5 Mon Sep 17 00:00:00 2001 From: fvogel Date: Mon, 7 Mar 2022 21:45:10 +0000 Subject: Improve a bit the ttk::treeview man page by instructing the html generator not link some words in that page when it should not. --- tools/tcltk-man2html.tcl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tools/tcltk-man2html.tcl b/tools/tcltk-man2html.tcl index 020aad9..75ed97e 100755 --- a/tools/tcltk-man2html.tcl +++ b/tools/tcltk-man2html.tcl @@ -682,7 +682,7 @@ array set exclude_refs_map { ttk_scale.n {variable} ttk_scrollbar.n {set} ttk_spinbox.n {format} - ttk_treeview.n {text open} + ttk_treeview.n {text open focus selection} ttk_widget.n {image text variable} TclZlib.3 {binary flush filename text} } -- cgit v0.12 From faf33c3ece8ecb7a33845cb5c3b4edfd725b9ef3 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 7 Mar 2022 23:59:52 +0000 Subject: Starting in Tcl 8.7, Tcl_GetUniChar() returns int, not Tcl_UniChar (TIP 389). Make typecasts of returned values match the new signature. --- generic/tclStringObj.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 0a6503c..c2249ae 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -561,7 +561,7 @@ Tcl_GetUniChar( TclNumUtfChars(stringPtr->numChars, objPtr->bytes, objPtr->length); } if (stringPtr->numChars == objPtr->length) { - return (Tcl_UniChar) objPtr->bytes[index]; + return (int) objPtr->bytes[index]; } FillUnicodeRep(objPtr); stringPtr = GET_STRING(objPtr); -- cgit v0.12 From 0c1dd51a1481431e5ea33b1a451b99c939775ea8 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 8 Mar 2022 08:23:07 +0000 Subject: This typecast is wrong (and was already wrong). Correct it, and add testcase to prove it --- generic/tclStringObj.c | 2 +- tests/string.test | 3 +++ 2 files changed, 4 insertions(+), 1 deletion(-) diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index c2249ae..7d4aef3 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -561,7 +561,7 @@ Tcl_GetUniChar( TclNumUtfChars(stringPtr->numChars, objPtr->bytes, objPtr->length); } if (stringPtr->numChars == objPtr->length) { - return (int) objPtr->bytes[index]; + return (unsigned char) objPtr->bytes[index]; } FillUnicodeRep(objPtr); stringPtr = GET_STRING(objPtr); diff --git a/tests/string.test b/tests/string.test index 7da50e9..203d0c6 100644 --- a/tests/string.test +++ b/tests/string.test @@ -510,6 +510,9 @@ test string-5.20.$noComp {string index, bytearray object out of bounds} -body { test string-5.21.$noComp {string index, surrogates, bug [11ae2be95dac9417]} -constraints utf16 -body { run {list [string index a\U100000b 1] [string index a\U100000b 2] [string index a\U100000b 3]} } -result [list \U100000 {} b] +test string-5.22.$noComp {string index} -constraints testbytestring -body { + run {list [scan [string index [testbytestring \xFF] 0] %c var] $var} +} -result {1 255} test string-6.1.$noComp {string is, not enough args} { -- cgit v0.12 From 0018893f3518509598c9945436bbd7b51ecacc70 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 9 Mar 2022 15:16:01 +0000 Subject: Tweak test code such that it can be used to test indexes > 2^31 too, so no longer limit values to INT_MIN .. INT_MAX --- generic/tclTest.c | 68 ++++++++-------- generic/tclTestObj.c | 216 +++++++++++++++++++++++---------------------------- 2 files changed, 130 insertions(+), 154 deletions(-) diff --git a/generic/tclTest.c b/generic/tclTest.c index 009c95f..1564bd5 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -760,7 +760,7 @@ TestasyncCmd( asyncPtr->nextPtr = firstHandler; firstHandler = asyncPtr; Tcl_MutexUnlock(&asyncTestMutex); - Tcl_SetObjResult(interp, Tcl_NewIntObj(asyncPtr->id)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(asyncPtr->id)); } else if (strcmp(argv[1], "delete") == 0) { if (argc == 2) { Tcl_MutexLock(&asyncTestMutex); @@ -1023,9 +1023,9 @@ TestcmdinfoCmd( info.deleteProc = CmdDelProc2; info.deleteData = (void *) "new_delete_data"; if (Tcl_SetCommandInfo(interp, argv[2], &info) == 0) { - Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(0)); } else { - Tcl_SetObjResult(interp, Tcl_NewIntObj(1)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(1)); } } else { Tcl_AppendResult(interp, "bad option \"", argv[1], @@ -1676,7 +1676,7 @@ TestdoubledigitsObjCmd( strObj = Tcl_NewStringObj(str, endPtr-str); ckfree(str); retval = Tcl_NewListObj(1, &strObj); - Tcl_ListObjAppendElement(NULL, retval, Tcl_NewIntObj(decpt)); + Tcl_ListObjAppendElement(NULL, retval, Tcl_NewWideIntObj(decpt)); strObj = Tcl_NewStringObj(signum ? "-" : "+", 1); Tcl_ListObjAppendElement(NULL, retval, strObj); Tcl_SetObjResult(interp, retval); @@ -1770,7 +1770,7 @@ TestdstringCmd( if (argc != 2) { goto wrongNumArgs; } - Tcl_SetObjResult(interp, Tcl_NewIntObj(Tcl_DStringLength(&dstring))); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(Tcl_DStringLength(&dstring))); } else if (strcmp(argv[1], "result") == 0) { if (argc != 2) { goto wrongNumArgs; @@ -3534,7 +3534,7 @@ PrintParse( Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewStringObj(parsePtr->commandStart, parsePtr->commandSize)); Tcl_ListObjAppendElement(NULL, objPtr, - Tcl_NewIntObj(parsePtr->numWords)); + Tcl_NewWideIntObj(parsePtr->numWords)); for (i = 0; i < parsePtr->numTokens; i++) { tokenPtr = &parsePtr->tokenPtr[i]; switch (tokenPtr->type) { @@ -3574,7 +3574,7 @@ PrintParse( Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewStringObj(tokenPtr->start, tokenPtr->size)); Tcl_ListObjAppendElement(NULL, objPtr, - Tcl_NewIntObj(tokenPtr->numComponents)); + Tcl_NewWideIntObj(tokenPtr->numComponents)); } Tcl_ListObjAppendElement(NULL, objPtr, parsePtr->commandStart ? @@ -3890,7 +3890,7 @@ TestregexpObjCmd( * value 0. */ - Tcl_SetIntObj(Tcl_GetObjResult(interp), 0); + Tcl_SetWideIntObj(Tcl_GetObjResult(interp), 0); if (objc > 2 && (cflags®_EXPECT) && indices) { const char *varName; const char *value; @@ -3986,7 +3986,7 @@ TestregexpObjCmd( * Set the interpreter's object result to an integer object w/ value 1. */ - Tcl_SetIntObj(Tcl_GetObjResult(interp), 1); + Tcl_SetWideIntObj(Tcl_GetObjResult(interp), 1); return TCL_OK; } @@ -6203,7 +6203,7 @@ TestServiceModeCmd( Tcl_SetServiceMode(TCL_SERVICE_ALL); } } - Tcl_SetObjResult(interp, Tcl_NewIntObj(oldmode)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(oldmode)); return TCL_OK; } @@ -6881,7 +6881,7 @@ TestUtfNextCmd( int objc, Tcl_Obj *const objv[]) { - int numBytes; + size_t numBytes; char *bytes; const char *result, *first; char buffer[32]; @@ -6894,10 +6894,10 @@ TestUtfNextCmd( } bytes = Tcl_GetStringFromObj(objv[1], &numBytes); - if (numBytes > (int)sizeof(buffer) - 4) { + if (numBytes + 4 > sizeof(buffer)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "\"testutfnext\" can only handle %d bytes", - (int)sizeof(buffer) - 4)); + "\"testutfnext\" can only handle %" TCL_Z_MODIFIER "u bytes", + sizeof(buffer) - 4)); return TCL_ERROR; } @@ -6925,7 +6925,7 @@ TestUtfNextCmd( } } - Tcl_SetObjResult(interp, Tcl_NewIntObj(first - buffer - 1)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(first - buffer - 1)); return TCL_OK; } @@ -6967,7 +6967,7 @@ TestUtfPrevCmd( offset = numBytes; } result = Tcl_UtfPrev(bytes + offset, bytes); - Tcl_SetObjResult(interp, Tcl_NewIntObj(result - bytes)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(result - bytes)); return TCL_OK; } @@ -6995,7 +6995,7 @@ TestNumUtfCharsCmd( } } len = Tcl_NumUtfChars(bytes, limit); - Tcl_SetObjResult(interp, Tcl_NewIntObj(len)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(len)); } return TCL_OK; } @@ -7120,7 +7120,7 @@ TestcpuidCmd( return status; } for (i=0 ; i<4 ; ++i) { - regsObjs[i] = Tcl_NewIntObj(regs[i]); + regsObjs[i] = Tcl_NewWideIntObj(regs[i]); } Tcl_SetObjResult(interp, Tcl_NewListObj(4, regsObjs)); return TCL_OK; @@ -7161,7 +7161,7 @@ TestHashSystemHashCmd( for (i=0 ; inumLevels); - levels[2] = Tcl_NewIntObj(iPtr->cmdFramePtr->level); - levels[3] = Tcl_NewIntObj(iPtr->varFramePtr->level); - levels[4] = Tcl_NewIntObj(iPtr->execEnvPtr->execStackPtr->tosPtr + levels[0] = Tcl_NewWideIntObj(depth); + levels[1] = Tcl_NewWideIntObj(iPtr->numLevels); + levels[2] = Tcl_NewWideIntObj(iPtr->cmdFramePtr->level); + levels[3] = Tcl_NewWideIntObj(iPtr->varFramePtr->level); + levels[4] = Tcl_NewWideIntObj(iPtr->execEnvPtr->execStackPtr->tosPtr - iPtr->execEnvPtr->execStackPtr->stackWords); while (cbPtr) { i++; cbPtr = cbPtr->nextPtr; } - levels[5] = Tcl_NewIntObj(i); + levels[5] = Tcl_NewWideIntObj(i); Tcl_SetObjResult(interp, Tcl_NewListObj(6, levels)); return TCL_OK; @@ -7726,8 +7726,8 @@ TestparseargsCmd( if (Tcl_ParseArgsObjv(interp, argTable, &count, objv, &remObjv)!=TCL_OK) { return TCL_ERROR; } - result[0] = Tcl_NewIntObj(foo); - result[1] = Tcl_NewIntObj(count); + result[0] = Tcl_NewWideIntObj(foo); + result[1] = Tcl_NewWideIntObj(count); result[2] = Tcl_NewListObj(count, remObjv); Tcl_SetObjResult(interp, Tcl_NewListObj(3, result)); ckfree(remObjv); diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c index f766030..9081bcf 100644 --- a/generic/tclTestObj.c +++ b/generic/tclTestObj.c @@ -38,10 +38,10 @@ * Forward declarations for functions defined later in this file: */ -static int CheckIfVarUnset(Tcl_Interp *interp, Tcl_Obj **varPtr, int varIndex); +static int CheckIfVarUnset(Tcl_Interp *interp, Tcl_Obj **varPtr, size_t varIndex); static int GetVariableIndex(Tcl_Interp *interp, - const char *string, int *indexPtr); -static void SetVarToObj(Tcl_Obj **varPtr, int varIndex, Tcl_Obj *objPtr); + Tcl_Obj *obj, size_t *indexPtr); +static void SetVarToObj(Tcl_Obj **varPtr, size_t varIndex, Tcl_Obj *objPtr); static Tcl_ObjCmdProc TestbignumobjCmd; static Tcl_ObjCmdProc TestbooleanobjCmd; static Tcl_ObjCmdProc TestdoubleobjCmd; @@ -160,7 +160,8 @@ TestbignumobjCmd( BIGNUM_SET, BIGNUM_GET, BIGNUM_MULT10, BIGNUM_DIV10, BIGNUM_ISEVEN, BIGNUM_RADIXSIZE }; - int index, varIndex; + int index; + size_t varIndex; const char *string; mp_int bignumValue; Tcl_Obj **varPtr; @@ -173,13 +174,12 @@ TestbignumobjCmd( &index) != TCL_OK) { return TCL_ERROR; } - string = Tcl_GetString(objv[2]); - if (GetVariableIndex(interp, string, &varIndex) != TCL_OK) { + if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) { return TCL_ERROR; } varPtr = GetVarPtr(interp); - switch (index) { + switch ((enum options)index) { case BIGNUM_SET: if (objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "var value"); @@ -292,9 +292,9 @@ TestbignumobjCmd( return TCL_ERROR; } if (!Tcl_IsShared(varPtr[varIndex])) { - Tcl_SetIntObj(varPtr[varIndex], mp_iszero(&bignumValue)); + Tcl_SetWideIntObj(varPtr[varIndex], mp_iszero(&bignumValue)); } else { - SetVarToObj(varPtr, varIndex, Tcl_NewIntObj(mp_iszero(&bignumValue))); + SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(mp_iszero(&bignumValue))); } mp_clear(&bignumValue); break; @@ -315,9 +315,9 @@ TestbignumobjCmd( return TCL_ERROR; } if (!Tcl_IsShared(varPtr[varIndex])) { - Tcl_SetIntObj(varPtr[varIndex], index); + Tcl_SetWideIntObj(varPtr[varIndex], index); } else { - SetVarToObj(varPtr, varIndex, Tcl_NewIntObj(index)); + SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(index)); } mp_clear(&bignumValue); break; @@ -352,8 +352,9 @@ TestbooleanobjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int varIndex, boolValue; - const char *index, *subCmd; + size_t varIndex; + int boolValue; + const char *subCmd; Tcl_Obj **varPtr; if (objc < 3) { @@ -362,8 +363,7 @@ TestbooleanobjCmd( return TCL_ERROR; } - index = Tcl_GetString(objv[2]); - if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { + if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) { return TCL_ERROR; } @@ -452,9 +452,9 @@ TestdoubleobjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int varIndex; + size_t varIndex; double doubleValue; - const char *index, *subCmd, *string; + const char *subCmd; Tcl_Obj **varPtr; if (objc < 3) { @@ -465,8 +465,7 @@ TestdoubleobjCmd( varPtr = GetVarPtr(interp); - index = Tcl_GetString(objv[2]); - if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { + if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) { return TCL_ERROR; } @@ -475,8 +474,7 @@ TestdoubleobjCmd( if (objc != 4) { goto wrongNumArgs; } - string = Tcl_GetString(objv[3]); - if (Tcl_GetDouble(interp, string, &doubleValue) != TCL_OK) { + if (Tcl_GetDouble(interp, Tcl_GetString(objv[3]), &doubleValue) != TCL_OK) { return TCL_ERROR; } @@ -570,7 +568,8 @@ TestindexobjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int allowAbbrev, index, index2, setError, i, result; + int allowAbbrev, index, setError, i, result; + Tcl_WideInt index2; const char **argv; static const char *const tablePtr[] = {"a", "b", "check", NULL}; @@ -579,10 +578,9 @@ TestindexobjCmd( */ struct IndexRep { void *tablePtr; /* Pointer to the table of strings. */ - int offset; /* Offset between table entries. */ - int index; /* Selected index into table. */ - }; - struct IndexRep *indexRep; + TCL_HASH_TYPE offset; /* Offset between table entries. */ + TCL_HASH_TYPE index; /* Selected index into table. */ + } *indexRep; if ((objc == 3) && (strcmp(Tcl_GetString(objv[1]), "check") == 0)) { @@ -592,7 +590,7 @@ TestindexobjCmd( * lookups. */ - if (Tcl_GetIntFromObj(interp, objv[2], &index2) != TCL_OK) { + if (Tcl_GetWideIntFromObj(interp, objv[2], &index2) != TCL_OK) { return TCL_ERROR; } @@ -602,7 +600,7 @@ TestindexobjCmd( result = Tcl_GetIndexFromObj(NULL, objv[1], tablePtr, "token", 0, &index); if (result == TCL_OK) { - Tcl_SetIntObj(Tcl_GetObjResult(interp), index); + Tcl_SetWideIntObj(Tcl_GetObjResult(interp), index); } return result; } @@ -630,7 +628,7 @@ TestindexobjCmd( &index); ckfree(argv); if (result == TCL_OK) { - Tcl_SetIntObj(Tcl_GetObjResult(interp), index); + Tcl_SetWideIntObj(Tcl_GetObjResult(interp), index); } return result; } @@ -660,9 +658,10 @@ TestintobjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int intValue, varIndex, i; + size_t varIndex; + int i; Tcl_WideInt wideValue; - const char *index, *subCmd, *string; + const char *subCmd; Tcl_Obj **varPtr; if (objc < 3) { @@ -672,8 +671,7 @@ TestintobjCmd( } varPtr = GetVarPtr(interp); - index = Tcl_GetString(objv[2]); - if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { + if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) { return TCL_ERROR; } @@ -682,11 +680,9 @@ TestintobjCmd( if (objc != 4) { goto wrongNumArgs; } - string = Tcl_GetString(objv[3]); - if (Tcl_GetInt(interp, string, &i) != TCL_OK) { + if (Tcl_GetWideIntFromObj(interp, objv[3], &wideValue) != TCL_OK) { return TCL_ERROR; } - intValue = i; /* * If the object currently bound to the variable with index varIndex @@ -697,38 +693,34 @@ TestintobjCmd( */ if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) { - Tcl_SetIntObj(varPtr[varIndex], intValue); + Tcl_SetWideIntObj(varPtr[varIndex], wideValue); } else { - SetVarToObj(varPtr, varIndex, Tcl_NewIntObj(intValue)); + SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(wideValue)); } Tcl_SetObjResult(interp, varPtr[varIndex]); } else if (strcmp(subCmd, "set2") == 0) { /* doesn't set result */ if (objc != 4) { goto wrongNumArgs; } - string = Tcl_GetString(objv[3]); - if (Tcl_GetInt(interp, string, &i) != TCL_OK) { + if (Tcl_GetWideIntFromObj(interp, objv[3], &wideValue) != TCL_OK) { return TCL_ERROR; } - intValue = i; if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) { - Tcl_SetIntObj(varPtr[varIndex], intValue); + Tcl_SetWideIntObj(varPtr[varIndex], wideValue); } else { - SetVarToObj(varPtr, varIndex, Tcl_NewIntObj(intValue)); + SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(wideValue)); } } else if (strcmp(subCmd, "setint") == 0) { if (objc != 4) { goto wrongNumArgs; } - string = Tcl_GetString(objv[3]); - if (Tcl_GetInt(interp, string, &i) != TCL_OK) { + if (Tcl_GetWideIntFromObj(interp, objv[3], &wideValue) != TCL_OK) { return TCL_ERROR; } - intValue = i; if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) { - Tcl_SetWideIntObj(varPtr[varIndex], intValue); + Tcl_SetWideIntObj(varPtr[varIndex], wideValue); } else { - SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(intValue)); + SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(wideValue)); } Tcl_SetObjResult(interp, varPtr[varIndex]); } else if (strcmp(subCmd, "setmax") == 0) { @@ -768,8 +760,7 @@ TestintobjCmd( if (CheckIfVarUnset(interp, varPtr,varIndex)) { return TCL_ERROR; } - string = Tcl_GetString(varPtr[varIndex]); - Tcl_AppendToObj(Tcl_GetObjResult(interp), string, -1); + Tcl_AppendToObj(Tcl_GetObjResult(interp), Tcl_GetString(varPtr[varIndex]), -1); } else if (strcmp(subCmd, "inttoobigtest") == 0) { /* * If long ints have more bits than ints on this platform, verify that @@ -803,14 +794,14 @@ TestintobjCmd( if (CheckIfVarUnset(interp, varPtr,varIndex)) { return TCL_ERROR; } - if (Tcl_GetIntFromObj(interp, varPtr[varIndex], - &intValue) != TCL_OK) { + if (Tcl_GetWideIntFromObj(interp, varPtr[varIndex], + &wideValue) != TCL_OK) { return TCL_ERROR; } if (!Tcl_IsShared(varPtr[varIndex])) { - Tcl_SetIntObj(varPtr[varIndex], intValue * 10); + Tcl_SetWideIntObj(varPtr[varIndex], wideValue * 10); } else { - SetVarToObj(varPtr, varIndex, Tcl_NewIntObj(intValue * 10)); + SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(wideValue * 10)); } Tcl_SetObjResult(interp, varPtr[varIndex]); } else if (strcmp(subCmd, "div10") == 0) { @@ -820,14 +811,14 @@ TestintobjCmd( if (CheckIfVarUnset(interp, varPtr,varIndex)) { return TCL_ERROR; } - if (Tcl_GetIntFromObj(interp, varPtr[varIndex], - &intValue) != TCL_OK) { + if (Tcl_GetWideIntFromObj(interp, varPtr[varIndex], + &wideValue) != TCL_OK) { return TCL_ERROR; } if (!Tcl_IsShared(varPtr[varIndex])) { - Tcl_SetIntObj(varPtr[varIndex], intValue / 10); + Tcl_SetWideIntObj(varPtr[varIndex], wideValue / 10); } else { - SetVarToObj(varPtr, varIndex, Tcl_NewIntObj(intValue / 10)); + SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(wideValue / 10)); } Tcl_SetObjResult(interp, varPtr[varIndex]); } else { @@ -874,13 +865,11 @@ TestlistobjCmd( LISTOBJ_SET, LISTOBJ_GET, LISTOBJ_REPLACE - }; + } cmdIndex; - const char* index; /* Argument giving the variable number */ - int varIndex; /* Variable number converted to binary */ - int cmdIndex; /* Ordinal number of the subcommand */ - int first; /* First index in the list */ - int count; /* Count of elements in a list */ + size_t varIndex; /* Variable number converted to binary */ + Tcl_WideInt first; /* First index in the list */ + Tcl_WideInt count; /* Count of elements in a list */ Tcl_Obj **varPtr; if (objc < 3) { @@ -888,8 +877,7 @@ TestlistobjCmd( return TCL_ERROR; } varPtr = GetVarPtr(interp); - index = Tcl_GetString(objv[2]); - if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { + if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) { return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[1], subcommands, "command", @@ -923,8 +911,8 @@ TestlistobjCmd( "varIndex start count ?element...?"); return TCL_ERROR; } - if (Tcl_GetIntFromObj(interp, objv[3], &first) != TCL_OK - || Tcl_GetIntFromObj(interp, objv[4], &count) != TCL_OK) { + if (Tcl_GetWideIntFromObj(interp, objv[3], &first) != TCL_OK + || Tcl_GetWideIntFromObj(interp, objv[4], &count) != TCL_OK) { return TCL_ERROR; } if (Tcl_IsShared(varPtr[varIndex])) { @@ -961,8 +949,9 @@ TestobjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int varIndex, destIndex, i; - const char *index, *subCmd, *string; + size_t varIndex, destIndex; + int i; + const char *subCmd; const Tcl_ObjType *targetType; Tcl_Obj **varPtr; @@ -978,15 +967,13 @@ TestobjCmd( if (objc != 4) { goto wrongNumArgs; } - index = Tcl_GetString(objv[2]); - if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { + if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) { return TCL_ERROR; } if (CheckIfVarUnset(interp, varPtr,varIndex)) { return TCL_ERROR; } - string = Tcl_GetString(objv[3]); - if (GetVariableIndex(interp, string, &destIndex) != TCL_OK) { + if (GetVariableIndex(interp, objv[3], &destIndex) != TCL_OK) { return TCL_ERROR; } SetVarToObj(varPtr, destIndex, varPtr[varIndex]); @@ -996,29 +983,26 @@ TestobjCmd( if (objc != 2) { goto wrongNumArgs; } - elemObjPtr = Tcl_NewIntObj(123); + elemObjPtr = Tcl_NewWideIntObj(123); listObjPtr = Tcl_NewListObj(1, &elemObjPtr); /* Replace the single list element through itself, nonsense but legal. */ Tcl_ListObjReplace(interp, listObjPtr, 0, 1, 1, &elemObjPtr); Tcl_SetObjResult(interp, listObjPtr); return TCL_OK; } else if (strcmp(subCmd, "convert") == 0) { - const char *typeName; if (objc != 4) { goto wrongNumArgs; } - index = Tcl_GetString(objv[2]); - if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { + if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) { return TCL_ERROR; } if (CheckIfVarUnset(interp, varPtr,varIndex)) { return TCL_ERROR; } - typeName = Tcl_GetString(objv[3]); - if ((targetType = Tcl_GetObjType(typeName)) == NULL) { + if ((targetType = Tcl_GetObjType(Tcl_GetString(objv[3]))) == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "no type ", typeName, " found", NULL); + "no type ", Tcl_GetString(objv[3]), " found", NULL); return TCL_ERROR; } if (Tcl_ConvertToType(interp, varPtr[varIndex], targetType) @@ -1030,15 +1014,13 @@ TestobjCmd( if (objc != 4) { goto wrongNumArgs; } - index = Tcl_GetString(objv[2]); - if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { + if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) { return TCL_ERROR; } if (CheckIfVarUnset(interp, varPtr,varIndex)) { return TCL_ERROR; } - string = Tcl_GetString(objv[3]); - if (GetVariableIndex(interp, string, &destIndex) != TCL_OK) { + if (GetVariableIndex(interp, objv[3], &destIndex) != TCL_OK) { return TCL_ERROR; } SetVarToObj(varPtr, destIndex, Tcl_DuplicateObj(varPtr[varIndex])); @@ -1057,8 +1039,7 @@ TestobjCmd( if (objc != 3) { goto wrongNumArgs; } - index = Tcl_GetString(objv[2]); - if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { + if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) { return TCL_ERROR; } if (CheckIfVarUnset(interp, varPtr,varIndex)) { @@ -1070,8 +1051,7 @@ TestobjCmd( if (objc != 3) { goto wrongNumArgs; } - index = Tcl_GetString(objv[2]); - if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { + if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) { return TCL_ERROR; } SetVarToObj(varPtr, varIndex, Tcl_NewObj()); @@ -1100,8 +1080,7 @@ TestobjCmd( if (objc != 3) { goto wrongNumArgs; } - index = Tcl_GetString(objv[2]); - if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { + if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) { return TCL_ERROR; } if (CheckIfVarUnset(interp, varPtr,varIndex)) { @@ -1112,8 +1091,7 @@ TestobjCmd( if (objc != 3) { goto wrongNumArgs; } - index = Tcl_GetString(objv[2]); - if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { + if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) { return TCL_ERROR; } if (CheckIfVarUnset(interp, varPtr,varIndex)) { @@ -1174,10 +1152,11 @@ TeststringobjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_UniChar *unicode; - int varIndex, option, i, length; - int size; + size_t varIndex; + int size, option, i; + Tcl_WideInt length; #define MAX_STRINGS 11 - const char *index, *string, *strings[MAX_STRINGS+1]; + const char *string, *strings[MAX_STRINGS+1]; String *strPtr; Tcl_Obj **varPtr; static const char *const options[] = { @@ -1193,8 +1172,7 @@ TeststringobjCmd( } varPtr = GetVarPtr(interp); - index = Tcl_GetString(objv[2]); - if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) { + if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) { return TCL_ERROR; } @@ -1207,7 +1185,7 @@ TeststringobjCmd( if (objc != 5) { goto wrongNumArgs; } - if (Tcl_GetIntFromObj(interp, objv[4], &length) != TCL_OK) { + if (Tcl_GetWideIntFromObj(interp, objv[4], &length) != TCL_OK) { return TCL_ERROR; } if (varPtr[varIndex] == NULL) { @@ -1222,8 +1200,7 @@ TeststringobjCmd( if (Tcl_IsShared(varPtr[varIndex])) { SetVarToObj(varPtr, varIndex, Tcl_DuplicateObj(varPtr[varIndex])); } - string = Tcl_GetString(objv[3]); - Tcl_AppendToObj(varPtr[varIndex], string, length); + Tcl_AppendToObj(varPtr[varIndex], Tcl_GetString(objv[3]), length); Tcl_SetObjResult(interp, varPtr[varIndex]); break; case 1: /* appendstrings */ @@ -1270,14 +1247,13 @@ TeststringobjCmd( if (CheckIfVarUnset(interp, varPtr, varIndex)) { return TCL_ERROR; } - string = Tcl_GetString(varPtr[varIndex]); - Tcl_AppendToObj(Tcl_GetObjResult(interp), string, -1); + Tcl_AppendToObj(Tcl_GetObjResult(interp), Tcl_GetString(varPtr[varIndex]), -1); break; case 4: /* length */ if (objc != 3) { goto wrongNumArgs; } - Tcl_SetIntObj(Tcl_GetObjResult(interp), (varPtr[varIndex] != NULL) + Tcl_SetWideIntObj(Tcl_GetObjResult(interp), (varPtr[varIndex] != NULL) ? varPtr[varIndex]->length : -1); break; case 5: /* length2 */ @@ -1292,7 +1268,7 @@ TeststringobjCmd( } else { length = -1; } - Tcl_SetIntObj(Tcl_GetObjResult(interp), length); + Tcl_SetWideIntObj(Tcl_GetObjResult(interp), length); break; case 6: /* set */ if (objc != 4) { @@ -1327,7 +1303,7 @@ TeststringobjCmd( if (objc != 4) { goto wrongNumArgs; } - if (Tcl_GetIntFromObj(interp, objv[3], &length) != TCL_OK) { + if (Tcl_GetWideIntFromObj(interp, objv[3], &length) != TCL_OK) { return TCL_ERROR; } if (varPtr[varIndex] != NULL) { @@ -1346,7 +1322,7 @@ TeststringobjCmd( } else { length = -1; } - Tcl_SetIntObj(Tcl_GetObjResult(interp), length); + Tcl_SetWideIntObj(Tcl_GetObjResult(interp), length); break; case 10: /* appendself */ if (objc != 4) { @@ -1367,16 +1343,16 @@ TeststringobjCmd( string = Tcl_GetStringFromObj(varPtr[varIndex], &size); - if (Tcl_GetIntFromObj(interp, objv[3], &i) != TCL_OK) { + if (Tcl_GetWideIntFromObj(interp, objv[3], &length) != TCL_OK) { return TCL_ERROR; } - if ((i < 0) || (i > size)) { + if ((length < 0) || (length > size)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "index value out of range", -1)); return TCL_ERROR; } - Tcl_AppendToObj(varPtr[varIndex], string + i, size - i); + Tcl_AppendToObj(varPtr[varIndex], string + length, size - length); Tcl_SetObjResult(interp, varPtr[varIndex]); break; case 11: /* appendself2 */ @@ -1398,16 +1374,16 @@ TeststringobjCmd( unicode = Tcl_GetUnicodeFromObj(varPtr[varIndex], &size); - if (Tcl_GetIntFromObj(interp, objv[3], &i) != TCL_OK) { + if (Tcl_GetWideIntFromObj(interp, objv[3], &length) != TCL_OK) { return TCL_ERROR; } - if ((i < 0) || (i > size)) { + if ((length < 0) || (length > size)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "index value out of range", -1)); return TCL_ERROR; } - Tcl_AppendUnicodeToObj(varPtr[varIndex], unicode + i, size - i); + Tcl_AppendUnicodeToObj(varPtr[varIndex], unicode + length, size - length); Tcl_SetObjResult(interp, varPtr[varIndex]); break; } @@ -1437,7 +1413,7 @@ TeststringobjCmd( static void SetVarToObj( Tcl_Obj **varPtr, - int varIndex, /* Designates the assignment variable. */ + size_t varIndex, /* Designates the assignment variable. */ Tcl_Obj *objPtr) /* Points to object to assign to var. */ { if (varPtr[varIndex] != NULL) { @@ -1468,14 +1444,14 @@ SetVarToObj( static int GetVariableIndex( Tcl_Interp *interp, /* Interpreter for error reporting. */ - const char *string, /* String containing a variable index + Tcl_Obj *obj, /* The variable index * specified as a nonnegative number less than * NUMBER_OF_OBJECT_VARS. */ - int *indexPtr) /* Place to store converted result. */ + size_t *indexPtr) /* Place to store converted result. */ { - int index; + Tcl_WideInt index; - if (Tcl_GetInt(interp, string, &index) != TCL_OK) { + if (Tcl_GetWideIntFromObj(interp, obj, &index) != TCL_OK) { return TCL_ERROR; } if (index < 0 || index >= NUMBER_OF_OBJECT_VARS) { @@ -1510,12 +1486,12 @@ static int CheckIfVarUnset( Tcl_Interp *interp, /* Interpreter for error reporting. */ Tcl_Obj ** varPtr, - int varIndex) /* Index of the test variable to check. */ + size_t varIndex) /* Index of the test variable to check. */ { if (varPtr[varIndex] == NULL) { char buf[32 + TCL_INTEGER_SPACE]; - sprintf(buf, "variable %d is unset (NULL)", varIndex); + sprintf(buf, "variable %" TCL_Z_MODIFIER "u is unset (NULL)", varIndex); Tcl_ResetResult(interp); Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1); return 1; -- cgit v0.12 From a455c140eaab90a3f1f588ce4e8a841e2b260fa6 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 10 Mar 2022 10:26:01 +0000 Subject: Unused variable warning --- generic/tclTestObj.c | 2 ++ 1 file changed, 2 insertions(+) diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c index 9081bcf..a235002 100644 --- a/generic/tclTestObj.c +++ b/generic/tclTestObj.c @@ -659,7 +659,9 @@ TestintobjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { size_t varIndex; +#if (INT_MAX != LONG_MAX) /* int is not the same size as long */ int i; +#endif Tcl_WideInt wideValue; const char *subCmd; Tcl_Obj **varPtr; -- cgit v0.12 From a9c0e83fb00eef6b3be5db888dfa2cfad2c0eb52 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 10 Mar 2022 10:37:44 +0000 Subject: Eliminate nmake build warning --- win/makefile.vc | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/win/makefile.vc b/win/makefile.vc index 6b2a682..1ef64f2 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -819,7 +819,8 @@ $(TMP_DIR)\tclEvent.obj: $(GENERICDIR)\tclEvent.c $(TMP_DIR)\tclUuid.h -Fo$@ $(GENERICDIR)\tclEvent.c $(TMP_DIR)\tclTest.obj: $(GENERICDIR)\tclTest.c $(TMP_DIR)\tclUuid.h - $(cc32) $(appcflags) -I$(TMP_DIR) -Fo$@ $? + $(cc32) $(appcflags) -I$(TMP_DIR) \ + -Fo$@ $(GENERICDIR)\tclTest.c $(TMP_DIR)\tclTestObj.obj: $(GENERICDIR)\tclTestObj.c $(cc32) $(appcflags) -Fo$@ $? -- cgit v0.12 From 500e2ceb70e7a57505c5d12828ed6a1145736ae9 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 10 Mar 2022 11:43:16 +0000 Subject: Add ::tcl::test::build-info command to tcl::test package, so we can find out which compiler/options the test package is compiled with (TIP #599) --- generic/tclTest.c | 90 ++++++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 89 insertions(+), 1 deletion(-) diff --git a/generic/tclTest.c b/generic/tclTest.c index 1564bd5..ee29cb1 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -41,6 +41,8 @@ */ #include "tclIO.h" +#include "tclUuid.h" + /* * Declare external functions used in Windows tests. */ @@ -438,10 +440,84 @@ static const Tcl_Filesystem simpleFilesystem = { *---------------------------------------------------------------------- */ +#ifndef STRINGIFY +# define STRINGIFY(x) STRINGIFY1(x) +# define STRINGIFY1(x) #x +#endif + +static const char version[] = 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 +#if defined(__cplusplus) && !defined(__OBJC__) + ".cplusplus" +#endif +#ifndef NDEBUG + ".debug" +#endif +#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 +#ifdef TCL_MEM_DEBUG + ".memdebug" +#endif +#if defined(_MSC_VER) + ".msvc-" STRINGIFY(_MSC_VER) +#endif +#ifdef USE_NMAKE + ".nmake" +#endif +#if !TCL_THREADS + ".no-thread" +#endif +#ifndef TCL_CFG_OPTIMIZED + ".no-optimize" +#endif +#ifdef __OBJC__ + ".objective-c" +#if defined(__cplusplus) + "plusplus" +#endif +#endif +#ifdef TCL_CFG_PROFILED + ".profile" +#endif +#ifdef PURIFY + ".purify" +#endif +#ifdef STATIC_BUILD + ".static" +#endif +#if TCL_UTF_MAX < 4 + ".utf-16" +#endif +; + int Tcltest_Init( Tcl_Interp *interp) /* Interpreter for application. */ { + Tcl_CmdInfo info; Tcl_Obj **objv, *objPtr; int objc, index; static const char *const specialOptions[] = { @@ -460,8 +536,11 @@ Tcltest_Init( if (Tcl_OOInitStubs(interp) == NULL) { return TCL_ERROR; } - /* TIP #268: Full patchlevel instead of just major.minor */ + if (Tcl_GetCommandInfo(interp, "::tcl::build-info", &info)) { + Tcl_CreateObjCommand(interp, "::tcl::test::build-info", + info.objProc, (void *)version, NULL); + } if (Tcl_PkgProvideEx(interp, "tcl::test", TCL_PATCH_LEVEL, NULL) == TCL_ERROR) { return TCL_ERROR; } @@ -706,9 +785,18 @@ int Tcltest_SafeInit( Tcl_Interp *interp) /* Interpreter for application. */ { + Tcl_CmdInfo info; + if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) { return TCL_ERROR; } + if (Tcl_GetCommandInfo(interp, "::tcl::build-info", &info)) { + Tcl_CreateObjCommand(interp, "::tcl::test::build-info", + info.objProc, (void *)version, NULL); + } + if (Tcl_PkgProvideEx(interp, "tcl::test", TCL_PATCH_LEVEL, NULL) == TCL_ERROR) { + return TCL_ERROR; + } return Procbodytest_SafeInit(interp); } -- cgit v0.12 From e5fe428a4336e7ec7bf809c207bbf610877bb21e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 11 Mar 2022 13:34:58 +0000 Subject: clarify 'yieldparameter'. Eliminate variable 'unused', reduce coroutine stackspace --- generic/tclBasic.c | 25 +++++++++++-------------- generic/tclExecute.c | 4 ++-- 2 files changed, 13 insertions(+), 16 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index ae7a3dc..1131a09 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -233,8 +233,8 @@ MODULE_SCOPE const TclStubs tclStubs; * after particular kinds of [yield]. */ -#define CORO_ACTIVATE_YIELD PTR2INT(NULL) -#define CORO_ACTIVATE_YIELDM PTR2INT(NULL)+1 +#define CORO_ACTIVATE_YIELD (0) +#define CORO_ACTIVATE_YIELDM (1) #define COROUTINE_ARGUMENTS_SINGLE_OPTIONAL (-1) #define COROUTINE_ARGUMENTS_ARBITRARY (-2) @@ -9724,9 +9724,6 @@ TclNRCoroutineActivateCallback( TCL_UNUSED(int) /*result*/) { CoroutineData *corPtr = (CoroutineData *)data[0]; - int type = PTR2INT(data[1]); - int numLevels, unused; - int *stackLevel = &unused; if (!corPtr->stackLevel) { /* @@ -9743,8 +9740,8 @@ TclNRCoroutineActivateCallback( * the interp's environment to make it suitable to run this coroutine. */ - corPtr->stackLevel = stackLevel; - numLevels = corPtr->auxNumLevels; + corPtr->stackLevel = &corPtr; + int numLevels = corPtr->auxNumLevels; corPtr->auxNumLevels = iPtr->numLevels; SAVE_CONTEXT(corPtr->caller); @@ -9757,7 +9754,7 @@ TclNRCoroutineActivateCallback( * Coroutine is active: yield */ - if (corPtr->stackLevel != stackLevel) { + if (corPtr->stackLevel != &corPtr) { NRE_callback *runPtr; iPtr->execEnvPtr = corPtr->callerEEPtr; @@ -9781,6 +9778,7 @@ TclNRCoroutineActivateCallback( return TCL_ERROR; } + int type = PTR2INT(data[1]); if (type == CORO_ACTIVATE_YIELD) { corPtr->nargs = COROUTINE_ARGUMENTS_SINGLE_OPTIONAL; } else if (type == CORO_ACTIVATE_YIELDM) { @@ -9792,7 +9790,7 @@ TclNRCoroutineActivateCallback( corPtr->yieldPtr = NULL; corPtr->stackLevel = NULL; - numLevels = iPtr->numLevels; + int numLevels = iPtr->numLevels; iPtr->numLevels = corPtr->auxNumLevels; corPtr->auxNumLevels = numLevels - corPtr->auxNumLevels; @@ -9939,7 +9937,6 @@ TclNRCoroInjectObjCmd( Tcl_Obj *const objv[]) { CoroutineData *corPtr; - ExecEnv *savedEEPtr = iPtr->execEnvPtr; /* * Usage more or less like tailcall: @@ -9968,6 +9965,7 @@ TclNRCoroInjectObjCmd( * to happen when the coro is resumed. */ + ExecEnv *savedEEPtr = iPtr->execEnvPtr; iPtr->execEnvPtr = corPtr->eePtr; TclNRAddCallback(interp, InjectHandler, corPtr, Tcl_NewListObj(objc - 2, objv + 2), INT2PTR(corPtr->nargs), NULL); @@ -9983,10 +9981,9 @@ TclNRCoroProbeObjCmd( int objc, Tcl_Obj *const objv[]) { - CoroutineData *corPtr; ExecEnv *savedEEPtr = iPtr->execEnvPtr; - int numLevels, unused; - int *stackLevel = &unused; + int numLevels; + CoroutineData *corPtr; /* * Usage more or less like tailcall: @@ -10036,7 +10033,7 @@ TclNRCoroProbeObjCmd( * the interp's environment to make it suitable to run this coroutine. */ - corPtr->stackLevel = stackLevel; + corPtr->stackLevel = &corPtr; numLevels = corPtr->auxNumLevels; corPtr->auxNumLevels = iPtr->numLevels; diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 0279218..a890d83 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -2453,7 +2453,7 @@ TEBCresume( fflush(stdout); } #endif - yieldParameter = 0; + yieldParameter = PTR2INT(NULL); /*==CORO_ACTIVATE_YIELD*/ Tcl_SetObjResult(interp, OBJ_AT_TOS); goto doYield; @@ -2508,7 +2508,7 @@ TEBCresume( TclSetTailcall(interp, valuePtr); corPtr->yieldPtr = valuePtr; iPtr->execEnvPtr = corPtr->eePtr; - yieldParameter = (PTR2INT(NULL)+1); /*==CORO_ACTIVATE_YIELDM*/ + yieldParameter = PTR2INT(NULL)+1; /*==CORO_ACTIVATE_YIELDM*/ doYield: /* TIP #280: Record the last piece of info needed by -- cgit v0.12 From 1dd0bb1ddca878a48f9d226c2ad859665022eaaf Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 11 Mar 2022 13:58:49 +0000 Subject: More tweaks --- generic/tclBasic.c | 8 ++++---- generic/tclExecute.c | 8 ++++---- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 1131a09..4e56088 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -233,8 +233,8 @@ MODULE_SCOPE const TclStubs tclStubs; * after particular kinds of [yield]. */ -#define CORO_ACTIVATE_YIELD (0) -#define CORO_ACTIVATE_YIELDM (1) +#define CORO_ACTIVATE_YIELD NULL +#define CORO_ACTIVATE_YIELDM INT2PTR(1) #define COROUTINE_ARGUMENTS_SINGLE_OPTIONAL (-1) #define COROUTINE_ARGUMENTS_ARBITRARY (-2) @@ -9563,7 +9563,7 @@ TclNRYieldToObjCmd( corPtr->yieldPtr = listPtr; iPtr->execEnvPtr = corPtr->eePtr; - return TclNRYieldObjCmd(INT2PTR(CORO_ACTIVATE_YIELDM), interp, 1, objv); + return TclNRYieldObjCmd(CORO_ACTIVATE_YIELDM, interp, 1, objv); } static int @@ -9778,7 +9778,7 @@ TclNRCoroutineActivateCallback( return TCL_ERROR; } - int type = PTR2INT(data[1]); + void *type = data[1]; if (type == CORO_ACTIVATE_YIELD) { corPtr->nargs = COROUTINE_ARGUMENTS_SINGLE_OPTIONAL; } else if (type == CORO_ACTIVATE_YIELDM) { diff --git a/generic/tclExecute.c b/generic/tclExecute.c index a890d83..0ec2404 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -2425,7 +2425,7 @@ TEBCresume( { CoroutineData *corPtr; - int yieldParameter; + void *yieldParameter; case INST_YIELD: corPtr = iPtr->execEnvPtr->corPtr; @@ -2453,7 +2453,7 @@ TEBCresume( fflush(stdout); } #endif - yieldParameter = PTR2INT(NULL); /*==CORO_ACTIVATE_YIELD*/ + yieldParameter = NULL; /*==CORO_ACTIVATE_YIELD*/ Tcl_SetObjResult(interp, OBJ_AT_TOS); goto doYield; @@ -2508,7 +2508,7 @@ TEBCresume( TclSetTailcall(interp, valuePtr); corPtr->yieldPtr = valuePtr; iPtr->execEnvPtr = corPtr->eePtr; - yieldParameter = PTR2INT(NULL)+1; /*==CORO_ACTIVATE_YIELDM*/ + yieldParameter = INT2PTR(1); /*==CORO_ACTIVATE_YIELDM*/ doYield: /* TIP #280: Record the last piece of info needed by @@ -2526,7 +2526,7 @@ TEBCresume( cleanup = 1; TEBC_YIELD(); TclNRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr, - INT2PTR(yieldParameter), NULL, NULL); + yieldParameter, NULL, NULL); return TCL_OK; } -- cgit v0.12 From f4a4c6610033116db3172a719caf8cc7d32bac4f Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 11 Mar 2022 15:12:26 +0000 Subject: TIP #617 implementation fix: Don't panic on Tcl_UniCharLen() when compiled with TCL_UTF_MAX=4 --- generic/tclDecls.h | 1 - generic/tclStubInit.c | 2 -- 2 files changed, 3 deletions(-) diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 87a90af..e84a7e8 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -4122,7 +4122,6 @@ extern const TclStubs *tclStubsPtr; #undef Tcl_GetStringResult #undef Tcl_GetDefaultEncodingDir #undef Tcl_SetDefaultEncodingDir -#undef Tcl_UniCharLen #undef Tcl_UniCharNcmp #undef Tcl_EvalTokens #undef Tcl_UniCharNcasecmp diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 6374ab5..1aec652 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -93,7 +93,6 @@ static void uniCodePanic(void) { # define Tcl_AppendUnicodeToObj (void(*)(Tcl_Obj *, const Tcl_UniChar *, int))(void *)uniCodePanic # define Tcl_UniCharNcasecmp (int(*)(const Tcl_UniChar *, const Tcl_UniChar *, unsigned long))(void *)uniCodePanic # define Tcl_UniCharCaseMatch (int(*)(const Tcl_UniChar *, const Tcl_UniChar *, int))(void *)uniCodePanic -# define Tcl_UniCharLen (int(*)(const Tcl_UniChar *))(void *)uniCodePanic # define Tcl_UniCharNcmp (int(*)(const Tcl_UniChar *, const Tcl_UniChar *, unsigned long))(void *)uniCodePanic #endif @@ -688,7 +687,6 @@ static int utfNcasecmp(const char *s1, const char *s2, unsigned int n){ #if TCL_UTF_MAX < 4 # define Tcl_AppendUnicodeToObj 0 # define Tcl_UniCharCaseMatch 0 -# define Tcl_UniCharLen 0 # define Tcl_UniCharNcasecmp 0 # define Tcl_UniCharNcmp 0 #endif -- cgit v0.12 From 9e3724ae417191dfc027b285d015f7ca332c9204 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 14 Mar 2022 20:59:44 +0000 Subject: Eliminate useless "const int" usage, where "const" has no meaning. VC-2015 has problem when the signatures don't match --- generic/rege_dfa.c | 2 +- generic/regexec.c | 2 +- generic/tclInt.decls | 10 +++++----- generic/tclInt.h | 16 ++++++++-------- generic/tclIntDecls.h | 23 +++++++++++------------ generic/tclOOCall.c | 4 ++-- generic/tclVar.c | 40 ++++++++++++++++++++-------------------- 7 files changed, 48 insertions(+), 49 deletions(-) diff --git a/generic/rege_dfa.c b/generic/rege_dfa.c index f38c8c9..eddfea2 100644 --- a/generic/rege_dfa.c +++ b/generic/rege_dfa.c @@ -419,7 +419,7 @@ freeDFA( static unsigned hash( unsigned *const uv, - const int n) + int n) { int i; unsigned h; diff --git a/generic/regexec.c b/generic/regexec.c index c085ac6..510fb1d 100644 --- a/generic/regexec.c +++ b/generic/regexec.c @@ -145,7 +145,7 @@ static chr *shortest(struct vars *const, struct dfa *const, chr *const, chr *con static chr *lastCold(struct vars *const, struct dfa *const); static struct dfa *newDFA(struct vars *const, struct cnfa *const, struct colormap *const, struct smalldfa *); static void freeDFA(struct dfa *const); -static unsigned hash(unsigned *const, const int); +static unsigned hash(unsigned *const, int); static struct sset *initialize(struct vars *const, struct dfa *const, chr *const); static struct sset *miss(struct vars *const, struct dfa *const, struct sset *const, const pcolor, chr *const, chr *const); static int checkLAConstraint(struct vars *const, struct cnfa *const, chr *const, const pcolor); diff --git a/generic/tclInt.decls b/generic/tclInt.decls index 0b3ea9e..8cefc34 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -904,7 +904,7 @@ declare 229 { declare 230 { Var *TclObjLookupVar(Tcl_Interp *interp, Tcl_Obj *part1Ptr, const char *part2, int flags, const char *msg, - const int createPart1, const int createPart2, Var **arrayPtrPtr) + int createPart1, int createPart2, Var **arrayPtrPtr) } declare 231 { int TclGetNamespaceFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, @@ -1005,17 +1005,17 @@ declare 251 { declare 252 { Tcl_Obj *TclPtrGetVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, - const int flags) + int flags) } declare 253 { Tcl_Obj *TclPtrSetVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, - Tcl_Obj *newValuePtr, const int flags) + Tcl_Obj *newValuePtr, int flags) } declare 254 { Tcl_Obj *TclPtrIncrObjVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, - Tcl_Obj *incrPtr, const int flags) + Tcl_Obj *incrPtr, int flags) } declare 255 { int TclPtrObjMakeUpvar(Tcl_Interp *interp, Tcl_Var otherPtr, @@ -1023,7 +1023,7 @@ declare 255 { } declare 256 { int TclPtrUnsetVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, - Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const int flags) + Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags) } declare 257 { void TclStaticLibrary(Tcl_Interp *interp, const char *prefix, diff --git a/generic/tclInt.h b/generic/tclInt.h index 2873ad3..3f2d1ad 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4126,30 +4126,30 @@ MODULE_SCOPE Tcl_Obj * TclStringReverse(Tcl_Obj *objPtr, int flags); MODULE_SCOPE Var * TclObjLookupVarEx(Tcl_Interp * interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags, - const char *msg, const int createPart1, - const int createPart2, Var **arrayPtrPtr); + const char *msg, int createPart1, + int createPart2, Var **arrayPtrPtr); MODULE_SCOPE Var * TclLookupArrayElement(Tcl_Interp *interp, Tcl_Obj *arrayNamePtr, Tcl_Obj *elNamePtr, - const int flags, const char *msg, - const int createPart1, const int createPart2, + int flags, const char *msg, + int createPart1, int createPart2, Var *arrayPtr, int index); MODULE_SCOPE Tcl_Obj * TclPtrGetVarIdx(Tcl_Interp *interp, Var *varPtr, Var *arrayPtr, Tcl_Obj *part1Ptr, - Tcl_Obj *part2Ptr, const int flags, int index); + Tcl_Obj *part2Ptr, int flags, int index); MODULE_SCOPE Tcl_Obj * TclPtrSetVarIdx(Tcl_Interp *interp, Var *varPtr, Var *arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr, - const int flags, int index); + int flags, int index); MODULE_SCOPE Tcl_Obj * TclPtrIncrObjVarIdx(Tcl_Interp *interp, Var *varPtr, Var *arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, - const int flags, int index); + int flags, int index); MODULE_SCOPE int TclPtrObjMakeUpvarIdx(Tcl_Interp *interp, Var *otherPtr, Tcl_Obj *myNamePtr, int myFlags, int index); MODULE_SCOPE int TclPtrUnsetVarIdx(Tcl_Interp *interp, Var *varPtr, Var *arrayPtr, Tcl_Obj *part1Ptr, - Tcl_Obj *part2Ptr, const int flags, + Tcl_Obj *part2Ptr, int flags, int index); MODULE_SCOPE void TclInvalidateNsPath(Namespace *nsPtr); MODULE_SCOPE void TclFindArrayPtrElements(Var *arrayPtr, diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index 75f4a68..f4e657b 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -562,9 +562,8 @@ EXTERN int TclPtrMakeUpvar(Tcl_Interp *interp, Var *otherP1Ptr, /* 230 */ EXTERN Var * TclObjLookupVar(Tcl_Interp *interp, Tcl_Obj *part1Ptr, const char *part2, - int flags, const char *msg, - const int createPart1, const int createPart2, - Var **arrayPtrPtr); + int flags, const char *msg, int createPart1, + int createPart2, Var **arrayPtrPtr); /* 231 */ EXTERN int TclGetNamespaceFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Namespace **nsPtrPtr); @@ -631,17 +630,17 @@ EXTERN int TclRegisterLiteral(void *envPtr, const char *bytes, /* 252 */ EXTERN Tcl_Obj * TclPtrGetVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, - Tcl_Obj *part2Ptr, const int flags); + Tcl_Obj *part2Ptr, int flags); /* 253 */ EXTERN Tcl_Obj * TclPtrSetVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr, - const int flags); + int flags); /* 254 */ EXTERN Tcl_Obj * TclPtrIncrObjVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, - const int flags); + int flags); /* 255 */ EXTERN int TclPtrObjMakeUpvar(Tcl_Interp *interp, Tcl_Var otherPtr, Tcl_Obj *myNamePtr, @@ -649,7 +648,7 @@ EXTERN int TclPtrObjMakeUpvar(Tcl_Interp *interp, /* 256 */ EXTERN int TclPtrUnsetVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, - Tcl_Obj *part2Ptr, const int flags); + Tcl_Obj *part2Ptr, int flags); /* 257 */ EXTERN void TclStaticLibrary(Tcl_Interp *interp, const char *prefix, @@ -895,7 +894,7 @@ typedef struct TclIntStubs { void (*tclSetNsPath) (Namespace *nsPtr, int pathLength, Tcl_Namespace *pathAry[]); /* 227 */ void (*reserved228)(void); int (*tclPtrMakeUpvar) (Tcl_Interp *interp, Var *otherP1Ptr, const char *myName, int myFlags, int index); /* 229 */ - Var * (*tclObjLookupVar) (Tcl_Interp *interp, Tcl_Obj *part1Ptr, const char *part2, int flags, const char *msg, const int createPart1, const int createPart2, Var **arrayPtrPtr); /* 230 */ + Var * (*tclObjLookupVar) (Tcl_Interp *interp, Tcl_Obj *part1Ptr, const char *part2, int flags, const char *msg, int createPart1, int createPart2, Var **arrayPtrPtr); /* 230 */ int (*tclGetNamespaceFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Namespace **nsPtrPtr); /* 231 */ int (*tclEvalObjEx) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags, const CmdFrame *invoker, int word); /* 232 */ void (*tclGetSrcInfoForPc) (CmdFrame *contextPtr); /* 233 */ @@ -917,11 +916,11 @@ typedef struct TclIntStubs { char * (*tclDoubleDigits) (double dv, int ndigits, int flags, int *decpt, int *signum, char **endPtr); /* 249 */ void (*tclSetChildCancelFlags) (Tcl_Interp *interp, int flags, int force); /* 250 */ int (*tclRegisterLiteral) (void *envPtr, const char *bytes, int length, int flags); /* 251 */ - Tcl_Obj * (*tclPtrGetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const int flags); /* 252 */ - Tcl_Obj * (*tclPtrSetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr, const int flags); /* 253 */ - Tcl_Obj * (*tclPtrIncrObjVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, const int flags); /* 254 */ + Tcl_Obj * (*tclPtrGetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags); /* 252 */ + Tcl_Obj * (*tclPtrSetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr, int flags); /* 253 */ + Tcl_Obj * (*tclPtrIncrObjVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, int flags); /* 254 */ int (*tclPtrObjMakeUpvar) (Tcl_Interp *interp, Tcl_Var otherPtr, Tcl_Obj *myNamePtr, int myFlags); /* 255 */ - int (*tclPtrUnsetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const int flags); /* 256 */ + int (*tclPtrUnsetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags); /* 256 */ void (*tclStaticLibrary) (Tcl_Interp *interp, const char *prefix, Tcl_LibraryInitProc *initProc, Tcl_LibraryInitProc *safeInitProc); /* 257 */ Tcl_Obj * (*tclpCreateTemporaryDirectory) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj); /* 258 */ void (*tclUnusedStubEntry) (void); /* 259 */ diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c index 71db6c1..d265c1a 100644 --- a/generic/tclOOCall.c +++ b/generic/tclOOCall.c @@ -91,7 +91,7 @@ typedef struct { static void AddClassFiltersToCallContext(Object *const oPtr, Class *clsPtr, struct ChainBuilder *const cbPtr, Tcl_HashTable *const doneFilters, int flags); -static void AddClassMethodNames(Class *clsPtr, const int flags, +static void AddClassMethodNames(Class *clsPtr, int flags, Tcl_HashTable *const namesPtr, Tcl_HashTable *const examinedClassesPtr); static inline void AddDefinitionNamespaceToChain(Class *const definerCls, @@ -671,7 +671,7 @@ CmpStr( static void AddClassMethodNames( Class *clsPtr, /* Class to get method names from. */ - const int flags, /* Whether we are interested in just the + int flags, /* Whether we are interested in just the * public method names. */ Tcl_HashTable *const namesPtr, /* Reference to the hash table to put the diff --git a/generic/tclVar.c b/generic/tclVar.c index 5a59fde..6d948dd 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -200,7 +200,7 @@ static Tcl_Var ObjFindNamespaceVar(Tcl_Interp *interp, int flags); static int ObjMakeUpvar(Tcl_Interp *interp, CallFrame *framePtr, Tcl_Obj *otherP1Ptr, - const char *otherP2, const int otherFlags, + const char *otherP2, int otherFlags, Tcl_Obj *myNamePtr, int myFlags, int index); static ArraySearch * ParseSearchId(Tcl_Interp *interp, const Var *varPtr, Tcl_Obj *varNamePtr, Tcl_Obj *handleObj); @@ -224,7 +224,7 @@ static void SetArrayDefault(Var *arrayPtr, Tcl_Obj *defaultObj); */ MODULE_SCOPE Var * TclLookupSimpleVar(Tcl_Interp *interp, - Tcl_Obj *varNamePtr, int flags, const int create, + Tcl_Obj *varNamePtr, int flags, int create, const char **errMsgPtr, int *indexPtr); static Tcl_DupInternalRepProc DupLocalVarName; @@ -541,10 +541,10 @@ TclObjLookupVar( const char *msg, /* Verb to use in error messages, e.g. "read" * or "set". Only needed if TCL_LEAVE_ERR_MSG * is set in flags. */ - const int createPart1, /* If 1, create hash table entry for part 1 of + int createPart1, /* If 1, create hash table entry for part 1 of * name, if it doesn't already exist. If 0, * return error if it doesn't exist. */ - const int createPart2, /* If 1, create hash table entry for part 2 of + int createPart2, /* If 1, create hash table entry for part 2 of * name, if it doesn't already exist. If 0, * return error if it doesn't exist. */ Var **arrayPtrPtr) /* If the name refers to an element of an @@ -591,10 +591,10 @@ TclObjLookupVarEx( const char *msg, /* Verb to use in error messages, e.g. "read" * or "set". Only needed if TCL_LEAVE_ERR_MSG * is set in flags. */ - const int createPart1, /* If 1, create hash table entry for part 1 of + int createPart1, /* If 1, create hash table entry for part 1 of * name, if it doesn't already exist. If 0, * return error if it doesn't exist. */ - const int createPart2, /* If 1, create hash table entry for part 2 of + int createPart2, /* If 1, create hash table entry for part 2 of * name, if it doesn't already exist. If 0, * return error if it doesn't exist. */ Var **arrayPtrPtr) /* If the name refers to an element of an @@ -827,7 +827,7 @@ TclLookupSimpleVar( int flags, /* Only TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, * TCL_AVOID_RESOLVERS and TCL_LEAVE_ERR_MSG * bits matter. */ - const int create, /* If 1, create hash table entry for varname, + int create, /* If 1, create hash table entry for varname, * if it doesn't already exist. If 0, return * error if it doesn't exist. */ const char **errMsgPtr, @@ -1062,15 +1062,15 @@ TclLookupArrayElement( Tcl_Obj *arrayNamePtr, /* This is the name of the array, or NULL if * index>= 0. */ Tcl_Obj *elNamePtr, /* Name of element within array. */ - const int flags, /* Only TCL_LEAVE_ERR_MSG bit matters. */ + int flags, /* Only TCL_LEAVE_ERR_MSG bit matters. */ const char *msg, /* Verb to use in error messages, e.g. "read" * or "set". Only needed if TCL_LEAVE_ERR_MSG * is set in flags. */ - const int createArray, /* If 1, transform arrayName to be an array if + int createArray, /* If 1, transform arrayName to be an array if * it isn't one yet and the transformation is * possible. If 0, return error if it isn't * already an array. */ - const int createElem, /* If 1, create hash table entry for the + int createElem, /* If 1, create hash table entry for the * element, if it doesn't already exist. If 0, * return error if it doesn't exist. */ Var *arrayPtr, /* Pointer to the array's Var structure. */ @@ -1383,7 +1383,7 @@ TclPtrGetVar( * the name of a variable. */ Tcl_Obj *part2Ptr, /* If non-NULL, gives the name of an element * in the array part1. */ - const int flags) /* OR-ed combination of TCL_GLOBAL_ONLY, and + int flags) /* OR-ed combination of TCL_GLOBAL_ONLY, and * TCL_LEAVE_ERR_MSG bits. */ { if (varPtr == NULL) { @@ -1429,7 +1429,7 @@ TclPtrGetVarIdx( * the name of a variable. */ Tcl_Obj *part2Ptr, /* If non-NULL, gives the name of an element * in the array part1. */ - const int flags, /* OR-ed combination of TCL_GLOBAL_ONLY, and + int flags, /* OR-ed combination of TCL_GLOBAL_ONLY, and * TCL_LEAVE_ERR_MSG bits. */ int index) /* Index into the local variable table of the * variable, or -1. Only used when part1Ptr is @@ -1822,7 +1822,7 @@ TclPtrSetVar( Tcl_Obj *part2Ptr, /* If non-NULL, gives the name of an element * in the array part1. */ Tcl_Obj *newValuePtr, /* New value for variable. */ - const int flags) /* OR-ed combination of TCL_GLOBAL_ONLY, and + int flags) /* OR-ed combination of TCL_GLOBAL_ONLY, and * TCL_LEAVE_ERR_MSG bits. */ { if (varPtr == NULL) { @@ -2001,7 +2001,7 @@ TclPtrSetVarIdx( Tcl_Obj *part2Ptr, /* If non-NULL, gives the name of an element * in the array part1. */ Tcl_Obj *newValuePtr, /* New value for variable. */ - const int flags, /* OR-ed combination of TCL_GLOBAL_ONLY, and + int flags, /* OR-ed combination of TCL_GLOBAL_ONLY, and * TCL_LEAVE_ERR_MSG bits. */ int index) /* Index of local var where part1 is to be * found. */ @@ -2247,7 +2247,7 @@ TclPtrIncrObjVar( * part1Ptr. */ Tcl_Obj *incrPtr, /* Increment value. */ /* TODO: Which of these flag values really make sense? */ - const int flags) /* Various flags that tell how to incr value: + int flags) /* Various flags that tell how to incr value: * any of TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, * TCL_APPEND_VALUE, TCL_LIST_ELEMENT, * TCL_LEAVE_ERR_MSG. */ @@ -2303,7 +2303,7 @@ TclPtrIncrObjVarIdx( * part1Ptr. */ Tcl_Obj *incrPtr, /* Increment value. */ /* TODO: Which of these flag values really make sense? */ - const int flags, /* Various flags that tell how to incr value: + int flags, /* Various flags that tell how to incr value: * any of TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, * TCL_APPEND_VALUE, TCL_LIST_ELEMENT, * TCL_LEAVE_ERR_MSG. */ @@ -2532,7 +2532,7 @@ TclPtrUnsetVar( * the name of a variable. */ Tcl_Obj *part2Ptr, /* If non-NULL, gives the name of an element * in the array part1. */ - const int flags) /* OR-ed combination of any of + int flags) /* OR-ed combination of any of * TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, * TCL_LEAVE_ERR_MSG. */ { @@ -2579,7 +2579,7 @@ TclPtrUnsetVarIdx( * the name of a variable. */ Tcl_Obj *part2Ptr, /* If non-NULL, gives the name of an element * in the array part1. */ - const int flags, /* OR-ed combination of any of + int flags, /* OR-ed combination of any of * TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, * TCL_LEAVE_ERR_MSG. */ int index) /* Index into the local variable table of the @@ -4373,7 +4373,7 @@ ArrayUnsetCmd( Tcl_Obj *varNameObj, *patternObj, *nameObj; Tcl_HashSearch search; const char *pattern; - const int unsetFlags = 0; /* Should this be TCL_LEAVE_ERR_MSG? */ + int unsetFlags = 0; /* Should this be TCL_LEAVE_ERR_MSG? */ int isArray; switch (objc) { @@ -4552,7 +4552,7 @@ ObjMakeUpvar( * NULL means use global :: context. */ Tcl_Obj *otherP1Ptr, const char *otherP2, /* Two-part name of variable in framePtr. */ - const int otherFlags, /* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY: + int otherFlags, /* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY: * indicates scope of "other" variable. */ Tcl_Obj *myNamePtr, /* Name of variable which will refer to * otherP1/otherP2. Must be a scalar. */ -- cgit v0.12 From e7f2a43ec4ace15bc0e3baf0cf965132eee20632 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 15 Mar 2022 07:52:56 +0000 Subject: Even though Tcl_UniChar == int (in this "#if TCL_UTF_MAX>3 block), use the correct signature for Tcl_GetUnicode/Tcl_GetUnicodeFromObj/Tcl_NewUnicodeObj here --- generic/tclStubInit.c | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 1aec652..221ff67 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -86,9 +86,9 @@ static void uniCodePanic(void) { Tcl_Panic("This extension uses a deprecated function, not available now: Tcl is compiled with -DTCL_UTF_MAX==%d", TCL_UTF_MAX); } -# define Tcl_GetUnicode (int *(*)(Tcl_Obj *))(void *)uniCodePanic -# define Tcl_GetUnicodeFromObj (int *(*)(Tcl_Obj *, Tcl_UniChar *))(void *)uniCodePanic -# define Tcl_NewUnicodeObj (Tcl_Obj *(*)(const int *, Tcl_UniChar))(void *)uniCodePanic +# define Tcl_GetUnicode (Tcl_UniChar *(*)(Tcl_Obj *))(void *)uniCodePanic +# define Tcl_GetUnicodeFromObj (Tcl_UniChar *(*)(Tcl_Obj *, int *))(void *)uniCodePanic +# define Tcl_NewUnicodeObj (Tcl_Obj *(*)(const int *, int))(void *)uniCodePanic # define Tcl_SetUnicodeObj (void(*)(Tcl_Obj *, const Tcl_UniChar *, int))(void *)uniCodePanic # define Tcl_AppendUnicodeToObj (void(*)(Tcl_Obj *, const Tcl_UniChar *, int))(void *)uniCodePanic # define Tcl_UniCharNcasecmp (int(*)(const Tcl_UniChar *, const Tcl_UniChar *, unsigned long))(void *)uniCodePanic -- cgit v0.12 From 21c68a2e1d7a0c5a9b78091d5dffd972a01dede8 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 17 Mar 2022 16:47:03 +0000 Subject: Use TCL_ENCODING_NOCOMPLAIN flag in stead of TCL_ENCODING_STOPONERROR when possible, since TCL_ENCODING_STOPONERROR becomes meaningless in 9.0 --- generic/tclCmdAH.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 60a2c42..c87bc46 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -600,7 +600,7 @@ encConvFromOK: } result = Tcl_ExternalToUtfDStringEx(encoding, bytesPtr, length, flags, &ds); - if ((flags & TCL_ENCODING_STOPONERROR) && (result != (size_t)-1)) { + if (!(flags & TCL_ENCODING_NOCOMPLAIN) && (result != (size_t)-1)) { char buf[TCL_INTEGER_SPACE]; sprintf(buf, "%" TCL_Z_MODIFIER "u", result); Tcl_SetObjResult(interp, Tcl_ObjPrintf("unexpected byte sequence starting at index %" @@ -696,7 +696,7 @@ encConvToOK: stringPtr = TclGetStringFromObj(data, &length); result = Tcl_UtfToExternalDStringEx(encoding, stringPtr, length, flags, &ds); - if ((flags & TCL_ENCODING_STOPONERROR) && (result != (size_t)-1)) { + if (!(flags & TCL_ENCODING_NOCOMPLAIN) && (result != (size_t)-1)) { size_t pos = Tcl_NumUtfChars(stringPtr, result); int ucs4; char buf[TCL_INTEGER_SPACE]; -- cgit v0.12 From d8c018f1a22a3dd5e68107869456c01488a13823 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 18 Mar 2022 13:04:39 +0000 Subject: Add proper cleanup to testcases --- tests/chanio.test | 30 ++++++++++++++++++++---------- tests/http.test | 1 + tests/io.test | 30 ++++++++++++++++++++---------- 3 files changed, 41 insertions(+), 20 deletions(-) diff --git a/tests/chanio.test b/tests/chanio.test index 578dc9f..38f3d90 100644 --- a/tests/chanio.test +++ b/tests/chanio.test @@ -249,7 +249,7 @@ test chan-io-3.3 {WriteChars: compatibility with WriteBytes: flush on line} -bod } -cleanup { chan close $f } -result "\r\n12" -test chan-io-3.4 {WriteChars: loop over stage buffer} deprecated { +test chan-io-3.4 {WriteChars: loop over stage buffer} -constraints deprecated -body { # stage buffer maps to more than can be queued at once. set f [open $path(test1) w] chan configure $f -encoding jis0208 -buffersize 16 @@ -257,8 +257,10 @@ test chan-io-3.4 {WriteChars: loop over stage buffer} deprecated { set x [list [contents $path(test1)]] chan close $f lappend x [contents $path(test1)] -} [list "!)!)!)!)!)!)!)!)" "!)!)!)!)!)!)!)!)!)!)!)!)!)!)!)"] -test chan-io-3.5 {WriteChars: saved != 0} deprecated { +} -cleanup { + catch {chan close $f} +} -result [list "!)!)!)!)!)!)!)!)" "!)!)!)!)!)!)!)!)!)!)!)!)!)!)!)"] +test chan-io-3.5 {WriteChars: saved != 0} -constraints deprecated -body { # Bytes produced by UtfToExternal from end of last channel buffer had to # be moved to beginning of next channel buffer to preserve requested # buffersize. @@ -268,8 +270,10 @@ test chan-io-3.5 {WriteChars: saved != 0} deprecated { set x [list [contents $path(test1)]] chan close $f lappend x [contents $path(test1)] -} [list "!)!)!)!)!)!)!)!)!" "!)!)!)!)!)!)!)!)!)!)!)!)!)!)!)"] -test chan-io-3.6 {WriteChars: (stageRead + dstWrote == 0)} { +} -cleanup { + catch {chan close $f} +} -result [list "!)!)!)!)!)!)!)!)!" "!)!)!)!)!)!)!)!)!)!)!)!)!)!)!)"] +test chan-io-3.6 {WriteChars: (stageRead + dstWrote == 0)} -body { # One incomplete UTF-8 character at end of staging buffer. Backup in src # to the beginning of that UTF-8 character and try again. # @@ -284,8 +288,10 @@ test chan-io-3.6 {WriteChars: (stageRead + dstWrote == 0)} { set x [list [contents $path(test1)]] chan close $f lappend x [contents $path(test1)] -} [list "12345678901234\x82\x60" "12345678901234\x82\x60\x82\x61"] -test chan-io-3.7 {WriteChars: (bufPtr->nextAdded > bufPtr->length)} deprecated { +} -cleanup { + catch {chan close $f} +} -result [list "12345678901234\x82\x60" "12345678901234\x82\x60\x82\x61"] +test chan-io-3.7 {WriteChars: (bufPtr->nextAdded > bufPtr->length)} -constraints deprecated -body { # When translating UTF-8 to external, the produced bytes went past end of # the channel buffer. This is done on purpose - we then truncate the bytes # at the end of the partial character to preserve the requested blocksize @@ -297,8 +303,10 @@ test chan-io-3.7 {WriteChars: (bufPtr->nextAdded > bufPtr->length)} deprecated { set x [list [contents $path(test1)]] chan close $f lappend x [contents $path(test1)] -} [list "!)!)!)!)!)!)!)!)!" "!)!)!)!)!)!)!)!)!)!)!)!)!)!)!)"] -test chan-io-3.8 {WriteChars: reset sawLF after each buffer} { +} -cleanup { + catch {chan close $f} +} -result [list "!)!)!)!)!)!)!)!)!" "!)!)!)!)!)!)!)!)!)!)!)!)!)!)!)"] +test chan-io-3.8 {WriteChars: reset sawLF after each buffer} -body { set f [open $path(test1) w] chan configure $f -encoding ascii -buffering line -translation lf \ -buffersize 16 @@ -306,7 +314,9 @@ test chan-io-3.8 {WriteChars: reset sawLF after each buffer} { set x [list [contents $path(test1)]] chan close $f lappend x [contents $path(test1)] -} [list "abcdefg\nhijklmno" "abcdefg\nhijklmnopqrstuvwxyz"] +} -cleanup { + catch {chan close $f} +} -result [list "abcdefg\nhijklmno" "abcdefg\nhijklmnopqrstuvwxyz"] test chan-io-4.1 {TranslateOutputEOL: lf} { # search for \n diff --git a/tests/http.test b/tests/http.test index 93998fe..a34b168 100644 --- a/tests/http.test +++ b/tests/http.test @@ -15,6 +15,7 @@ if {"::tcltest" ni [namespace children]} { package require tcltest 2.5 namespace import -force ::tcltest::* } +package require tcltests if {[catch {package require http 2} version]} { if {[info exists http2]} { diff --git a/tests/io.test b/tests/io.test index 821b11e..e22fa8a 100644 --- a/tests/io.test +++ b/tests/io.test @@ -268,7 +268,7 @@ test io-3.3 {WriteChars: compatibility with WriteBytes: flush on line} { close $f set x } "\r\n12" -test io-3.4 {WriteChars: loop over stage buffer} deprecated { +test io-3.4 {WriteChars: loop over stage buffer} -constraints deprecated -body { # stage buffer maps to more than can be queued at once. set f [open $path(test1) w] @@ -277,8 +277,10 @@ test io-3.4 {WriteChars: loop over stage buffer} deprecated { set x [list [contents $path(test1)]] close $f lappend x [contents $path(test1)] -} [list "!)!)!)!)!)!)!)!)" "!)!)!)!)!)!)!)!)!)!)!)!)!)!)!)"] -test io-3.5 {WriteChars: saved != 0} deprecated { +} -cleanup { + catch {close $f} +} -result [list "!)!)!)!)!)!)!)!)" "!)!)!)!)!)!)!)!)!)!)!)!)!)!)!)"] +test io-3.5 {WriteChars: saved != 0} -constraints deprecated -body { # Bytes produced by UtfToExternal from end of last channel buffer # had to be moved to beginning of next channel buffer to preserve # requested buffersize. @@ -289,7 +291,9 @@ test io-3.5 {WriteChars: saved != 0} deprecated { set x [list [contents $path(test1)]] close $f lappend x [contents $path(test1)] -} [list "!)!)!)!)!)!)!)!)!" "!)!)!)!)!)!)!)!)!)!)!)!)!)!)!)"] +} -cleanup { + catch {close $f} +} -result [list "!)!)!)!)!)!)!)!)!" "!)!)!)!)!)!)!)!)!)!)!)!)!)!)!)"] test io-3.6 {WriteChars: (stageRead + dstWrote == 0)} { # One incomplete UTF-8 character at end of staging buffer. Backup # in src to the beginning of that UTF-8 character and try again. @@ -307,7 +311,7 @@ test io-3.6 {WriteChars: (stageRead + dstWrote == 0)} { close $f lappend x [contents $path(test1)] } [list "12345678901234\x82\x60" "12345678901234\x82\x60\x82\x61"] -test io-3.7 {WriteChars: (bufPtr->nextAdded > bufPtr->length)} deprecated { +test io-3.7 {WriteChars: (bufPtr->nextAdded > bufPtr->length)} -constraints deprecated -body { # When translating UTF-8 to external, the produced bytes went past end # of the channel buffer. This is done purpose -- we then truncate the # bytes at the end of the partial character to preserve the requested @@ -320,7 +324,9 @@ test io-3.7 {WriteChars: (bufPtr->nextAdded > bufPtr->length)} deprecated { set x [list [contents $path(test1)]] close $f lappend x [contents $path(test1)] -} [list "!)!)!)!)!)!)!)!)!" "!)!)!)!)!)!)!)!)!)!)!)!)!)!)!)"] +} -cleanup { + catch {close $f} +} -result [list "!)!)!)!)!)!)!)!)!" "!)!)!)!)!)!)!)!)!)!)!)!)!)!)!)"] test io-3.8 {WriteChars: reset sawLF after each buffer} { set f [open $path(test1) w] fconfigure $f -encoding ascii -buffering line -translation lf \ @@ -1532,7 +1538,7 @@ test io-12.8 {ReadChars: multibyte chars split} { close $f scan [string index $in end] %c } 160 -test io-12.9 {ReadChars: multibyte chars split} deprecated { +test io-12.9 {ReadChars: multibyte chars split} -constraints deprecated -body { set f [open $path(test1) w] fconfigure $f -translation binary puts -nonewline $f [string repeat a 9]\xC2 @@ -1542,8 +1548,10 @@ test io-12.9 {ReadChars: multibyte chars split} deprecated { set in [read $f] close $f scan [string index $in end] %c -} 194 -test io-12.10 {ReadChars: multibyte chars split} deprecated { +} -cleanup { + catch {close $f} +} -result 194 +test io-12.10 {ReadChars: multibyte chars split} -constraints deprecated -body { set f [open $path(test1) w] fconfigure $f -translation binary puts -nonewline $f [string repeat a 9]\xC2 @@ -1553,7 +1561,9 @@ test io-12.10 {ReadChars: multibyte chars split} deprecated { set in [read $f] close $f scan [string index $in end] %c -} 194 +} -cleanup { + catch {close $f} +} -result 194 test io-13.1 {TranslateInputEOL: cr mode} {} { set f [open $path(test1) w] -- cgit v0.12 From 92e97aec374dfefc0a80edf3fcd4cde7c5cda86c Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 18 Mar 2022 13:05:50 +0000 Subject: Fix meaning of "testConstraint deprepcated" in encoding.test: Those testcases tested the behavior of -DTCL_NO_DEPRECATED --- tests/encoding.test | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/tests/encoding.test b/tests/encoding.test index bf82493..21e5df1 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -22,7 +22,7 @@ catch { package require -exact tcl::test [info patchlevel] } -testConstraint deprecated [expr {![info exists tcl_precision]}] +package require tcltests proc toutf {args} { variable x @@ -639,28 +639,28 @@ test encoding-24.11 {Parse valid or invalid utf-8} { } 1 test encoding-24.12 {Parse valid or invalid utf-8} -constraints deprecated -body { encoding convertfrom utf-8 "\xC0\x81" -} -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\xC0'} +} -result \xC0\x81 test encoding-24.13 {Parse valid or invalid utf-8} -constraints deprecated -body { encoding convertfrom utf-8 "\xC1\xBF" -} -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\xC1'} +} -result \xC1\xBF test encoding-24.14 {Parse valid or invalid utf-8} { string length [encoding convertfrom utf-8 "\xC2\x80"] } 1 test encoding-24.15 {Parse valid or invalid utf-8} -constraints deprecated -body { encoding convertfrom utf-8 "Z\xE0\x80" -} -returnCodes 1 -result {unexpected byte sequence starting at index 1: '\xE0'} -test encoding-24.16 {Parse valid or invalid utf-8} -constraints {testbytestring deprecated} -body { +} -result Z\xE0\x80 +test encoding-24.16 {Parse valid or invalid utf-8} -constraints testbytestring -body { encoding convertto utf-8 [testbytestring "Z\u4343\x80"] } -returnCodes 1 -result {expected byte sequence but character 1 was '䍃€' (U+004343)} -test encoding-24.17 {Parse valid or invalid utf-8} -constraints {testbytestring deprecated} -body { +test encoding-24.17 {Parse valid or invalid utf-8} -constraints testbytestring -body { encoding convertto utf-8 [testbytestring "Z\xE0\x80"] } -result "Z\xC3\xA0\xE2\x82\xAC" -test encoding-24.18 {Parse valid or invalid utf-8} -constraints {testbytestring deprecated} -body { +test encoding-24.18 {Parse valid or invalid utf-8} -constraints testbytestring -body { encoding convertto utf-8 [testbytestring "Z\xE0\x80xxxxxx"] } -result "Z\xC3\xA0\xE2\x82\xACxxxxxx" test encoding-24.19 {Parse valid or invalid utf-8} -constraints deprecated -body { encoding convertto utf-8 "ZX\uD800" -} -returnCodes 1 -match glob -result "unexpected character at index 2: 'U+00D800'" +} -result ZX\xED\xA0\x80 test encoding-24.20 {Parse with -nocomplain but without providing encoding} { string length [encoding convertfrom -nocomplain "\x20"] } 1 -- cgit v0.12 From 4ae2452d30d79d0dec8956c0cb67171651fb51e6 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 18 Mar 2022 15:39:44 +0000 Subject: See [4dbfa46caa]: Remove "constraint deprecated" from failing testcases which should pass --- tests/chanio.test | 6 +++--- tests/io.test | 10 +++++----- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/tests/chanio.test b/tests/chanio.test index 38f3d90..8d922a2 100644 --- a/tests/chanio.test +++ b/tests/chanio.test @@ -249,7 +249,7 @@ test chan-io-3.3 {WriteChars: compatibility with WriteBytes: flush on line} -bod } -cleanup { chan close $f } -result "\r\n12" -test chan-io-3.4 {WriteChars: loop over stage buffer} -constraints deprecated -body { +test chan-io-3.4 {WriteChars: loop over stage buffer} -body { # stage buffer maps to more than can be queued at once. set f [open $path(test1) w] chan configure $f -encoding jis0208 -buffersize 16 @@ -260,7 +260,7 @@ test chan-io-3.4 {WriteChars: loop over stage buffer} -constraints deprecated -b } -cleanup { catch {chan close $f} } -result [list "!)!)!)!)!)!)!)!)" "!)!)!)!)!)!)!)!)!)!)!)!)!)!)!)"] -test chan-io-3.5 {WriteChars: saved != 0} -constraints deprecated -body { +test chan-io-3.5 {WriteChars: saved != 0} -body { # Bytes produced by UtfToExternal from end of last channel buffer had to # be moved to beginning of next channel buffer to preserve requested # buffersize. @@ -291,7 +291,7 @@ test chan-io-3.6 {WriteChars: (stageRead + dstWrote == 0)} -body { } -cleanup { catch {chan close $f} } -result [list "12345678901234\x82\x60" "12345678901234\x82\x60\x82\x61"] -test chan-io-3.7 {WriteChars: (bufPtr->nextAdded > bufPtr->length)} -constraints deprecated -body { +test chan-io-3.7 {WriteChars: (bufPtr->nextAdded > bufPtr->length)} -body { # When translating UTF-8 to external, the produced bytes went past end of # the channel buffer. This is done on purpose - we then truncate the bytes # at the end of the partial character to preserve the requested blocksize diff --git a/tests/io.test b/tests/io.test index e22fa8a..f07fa8d 100644 --- a/tests/io.test +++ b/tests/io.test @@ -268,7 +268,7 @@ test io-3.3 {WriteChars: compatibility with WriteBytes: flush on line} { close $f set x } "\r\n12" -test io-3.4 {WriteChars: loop over stage buffer} -constraints deprecated -body { +test io-3.4 {WriteChars: loop over stage buffer} -body { # stage buffer maps to more than can be queued at once. set f [open $path(test1) w] @@ -280,7 +280,7 @@ test io-3.4 {WriteChars: loop over stage buffer} -constraints deprecated -body { } -cleanup { catch {close $f} } -result [list "!)!)!)!)!)!)!)!)" "!)!)!)!)!)!)!)!)!)!)!)!)!)!)!)"] -test io-3.5 {WriteChars: saved != 0} -constraints deprecated -body { +test io-3.5 {WriteChars: saved != 0} -body { # Bytes produced by UtfToExternal from end of last channel buffer # had to be moved to beginning of next channel buffer to preserve # requested buffersize. @@ -311,7 +311,7 @@ test io-3.6 {WriteChars: (stageRead + dstWrote == 0)} { close $f lappend x [contents $path(test1)] } [list "12345678901234\x82\x60" "12345678901234\x82\x60\x82\x61"] -test io-3.7 {WriteChars: (bufPtr->nextAdded > bufPtr->length)} -constraints deprecated -body { +test io-3.7 {WriteChars: (bufPtr->nextAdded > bufPtr->length)} -body { # When translating UTF-8 to external, the produced bytes went past end # of the channel buffer. This is done purpose -- we then truncate the # bytes at the end of the partial character to preserve the requested @@ -1538,7 +1538,7 @@ test io-12.8 {ReadChars: multibyte chars split} { close $f scan [string index $in end] %c } 160 -test io-12.9 {ReadChars: multibyte chars split} -constraints deprecated -body { +test io-12.9 {ReadChars: multibyte chars split} -body { set f [open $path(test1) w] fconfigure $f -translation binary puts -nonewline $f [string repeat a 9]\xC2 @@ -1551,7 +1551,7 @@ test io-12.9 {ReadChars: multibyte chars split} -constraints deprecated -body { } -cleanup { catch {close $f} } -result 194 -test io-12.10 {ReadChars: multibyte chars split} -constraints deprecated -body { +test io-12.10 {ReadChars: multibyte chars split} -body { set f [open $path(test1) w] fconfigure $f -translation binary puts -nonewline $f [string repeat a 9]\xC2 -- cgit v0.12 From a0b26511ec3f53545e575b609822ad525be69118 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 20 Mar 2022 20:41:30 +0000 Subject: TIP #601 minor improvement: Use 'int' type, so we can use TCL_INDEX_NONE to test for errors in Tcl_UtfToExternalDStringEx/Tcl_ExternalToUtfDStringEx --- doc/Encoding.3 | 8 ++++---- generic/tcl.decls | 4 ++-- generic/tclCmdAH.c | 18 +++++++++--------- generic/tclDecls.h | 8 ++++---- generic/tclEncoding.c | 12 ++++++------ 5 files changed, 25 insertions(+), 25 deletions(-) diff --git a/doc/Encoding.3 b/doc/Encoding.3 index dc37519..86c5a78 100644 --- a/doc/Encoding.3 +++ b/doc/Encoding.3 @@ -25,13 +25,13 @@ int char * \fBTcl_ExternalToUtfDString\fR(\fIencoding, src, srcLen, dstPtr\fR) .sp -size_t +int \fBTcl_ExternalToUtfDStringEx\fR(\fIencoding, src, srcLen, flags, dstPtr\fR) .sp char * \fBTcl_UtfToExternalDString\fR(\fIencoding, src, srcLen, dstPtr\fR) .sp -size_t +int \fBTcl_UtfToExternalDStringEx\fR(\fIencoding, src, srcLen, flags, dstPtr\fR) .sp int @@ -220,7 +220,7 @@ used. The return value is a pointer to the value stored in the DString. \fBTcl_ExternalToUtfDStringEx\fR is the same as \fBTcl_ExternalToUtfDString\fR, but it has an additional flags parameter. The return value is the index of the first byte in the input string causing a conversion error. -Or (size_t)-1 if all is OK. +Or TCL_INDEX_NONE if all is OK. .PP \fBTcl_ExternalToUtf\fR converts a source buffer \fIsrc\fR from the specified \fIencoding\fR into UTF-8. Up to \fIsrcLen\fR bytes are converted from the @@ -263,7 +263,7 @@ a pointer to the value stored in the DString. \fBTcl_UtfToExternalDStringEx\fR is the same as \fBTcl_UtfToExternalDString\fR, but it has an additional flags parameter. The return value is the index of the first byte of an utf-8 byte-sequence in the input string causing a -conversion error. Or (size_t)-1 if all is OK. +conversion error. Or TCL_INDEX_NONE if all is OK. .PP \fBTcl_UtfToExternal\fR converts a source buffer \fIsrc\fR from UTF-8 into the specified \fIencoding\fR. Up to \fIsrcLen\fR bytes are converted from diff --git a/generic/tcl.decls b/generic/tcl.decls index a33ea56..3cf794e 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2437,11 +2437,11 @@ declare 657 { int Tcl_UniCharIsUnicode(int ch) } declare 658 { - size_t Tcl_ExternalToUtfDStringEx(Tcl_Encoding encoding, + int Tcl_ExternalToUtfDStringEx(Tcl_Encoding encoding, const char *src, int srcLen, int flags, Tcl_DString *dsPtr) } declare 659 { - size_t Tcl_UtfToExternalDStringEx(Tcl_Encoding encoding, + int Tcl_UtfToExternalDStringEx(Tcl_Encoding encoding, const char *src, int srcLen, int flags, Tcl_DString *dsPtr) } diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index c87bc46..401b14a 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -555,7 +555,7 @@ EncodingConvertfromObjCmd( #else int flags = TCL_ENCODING_NOCOMPLAIN; #endif - size_t result; + int result; if (objc == 2) { encoding = Tcl_GetEncoding(interp, NULL); @@ -600,11 +600,11 @@ encConvFromOK: } result = Tcl_ExternalToUtfDStringEx(encoding, bytesPtr, length, flags, &ds); - if (!(flags & TCL_ENCODING_NOCOMPLAIN) && (result != (size_t)-1)) { + if (!(flags & TCL_ENCODING_NOCOMPLAIN) && (result != TCL_INDEX_NONE)) { char buf[TCL_INTEGER_SPACE]; - sprintf(buf, "%" TCL_Z_MODIFIER "u", result); + sprintf(buf, "%u", result); Tcl_SetObjResult(interp, Tcl_ObjPrintf("unexpected byte sequence starting at index %" - TCL_Z_MODIFIER "u: '\\x%X'", result, UCHAR(bytesPtr[result]))); + "u: '\\x%X'", result, UCHAR(bytesPtr[result]))); Tcl_SetErrorCode(interp, "TCL", "ENCODING", "ILLEGALSEQUENCE", buf, NULL); Tcl_DStringFree(&ds); @@ -653,7 +653,7 @@ EncodingConverttoObjCmd( Tcl_Encoding encoding; /* Encoding to use */ int length; /* Length of the string being converted */ const char *stringPtr; /* Pointer to the first byte of the string */ - size_t result; + int result; #if TCL_MAJOR_VERSION > 8 || defined(TCL_NO_DEPRECATED) int flags = TCL_ENCODING_STOPONERROR; #else @@ -696,14 +696,14 @@ encConvToOK: stringPtr = TclGetStringFromObj(data, &length); result = Tcl_UtfToExternalDStringEx(encoding, stringPtr, length, flags, &ds); - if (!(flags & TCL_ENCODING_NOCOMPLAIN) && (result != (size_t)-1)) { - size_t pos = Tcl_NumUtfChars(stringPtr, result); + if (!(flags & TCL_ENCODING_NOCOMPLAIN) && (result != TCL_INDEX_NONE)) { + int pos = Tcl_NumUtfChars(stringPtr, result); int ucs4; char buf[TCL_INTEGER_SPACE]; TclUtfToUCS4(&stringPtr[result], &ucs4); - sprintf(buf, "%" TCL_Z_MODIFIER "u", result); + sprintf(buf, "%u", result); Tcl_SetObjResult(interp, Tcl_ObjPrintf("unexpected character at index %" - TCL_Z_MODIFIER "u: 'U+%06X'", pos, ucs4)); + "u: 'U+%06X'", pos, ucs4)); Tcl_SetErrorCode(interp, "TCL", "ENCODING", "ILLEGALSEQUENCE", buf, NULL); Tcl_DStringFree(&ds); diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 0830a11..57574b8 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1944,11 +1944,11 @@ EXTERN const char * Tcl_UtfPrev(const char *src, const char *start); /* 657 */ EXTERN int Tcl_UniCharIsUnicode(int ch); /* 658 */ -EXTERN size_t Tcl_ExternalToUtfDStringEx(Tcl_Encoding encoding, +EXTERN int Tcl_ExternalToUtfDStringEx(Tcl_Encoding encoding, const char *src, int srcLen, int flags, Tcl_DString *dsPtr); /* 659 */ -EXTERN size_t Tcl_UtfToExternalDStringEx(Tcl_Encoding encoding, +EXTERN int Tcl_UtfToExternalDStringEx(Tcl_Encoding encoding, const char *src, int srcLen, int flags, Tcl_DString *dsPtr); /* 660 */ @@ -2656,8 +2656,8 @@ typedef struct TclStubs { const char * (*tcl_UtfNext) (const char *src); /* 655 */ const char * (*tcl_UtfPrev) (const char *src, const char *start); /* 656 */ int (*tcl_UniCharIsUnicode) (int ch); /* 657 */ - size_t (*tcl_ExternalToUtfDStringEx) (Tcl_Encoding encoding, const char *src, int srcLen, int flags, Tcl_DString *dsPtr); /* 658 */ - size_t (*tcl_UtfToExternalDStringEx) (Tcl_Encoding encoding, const char *src, int srcLen, int flags, Tcl_DString *dsPtr); /* 659 */ + int (*tcl_ExternalToUtfDStringEx) (Tcl_Encoding encoding, const char *src, int srcLen, int flags, Tcl_DString *dsPtr); /* 658 */ + int (*tcl_UtfToExternalDStringEx) (Tcl_Encoding encoding, const char *src, int srcLen, int flags, Tcl_DString *dsPtr); /* 659 */ int (*tcl_AsyncMarkFromSignal) (Tcl_AsyncHandler async, int sigNumber); /* 660 */ void (*reserved661)(void); void (*reserved662)(void); diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index b6d5dcf..78c96fd 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -1142,7 +1142,7 @@ Tcl_ExternalToUtfDString( Tcl_DString *dstPtr) /* Uninitialized or free DString in which the * converted string is stored. */ { - Tcl_ExternalToUtfDStringEx(encoding, src, srcLen, 0, dstPtr); + Tcl_ExternalToUtfDStringEx(encoding, src, srcLen, TCL_ENCODING_NOCOMPLAIN, dstPtr); return Tcl_DStringValue(dstPtr); } @@ -1176,7 +1176,7 @@ Tcl_ExternalToUtfDString( *------------------------------------------------------------------------- */ -size_t +int Tcl_ExternalToUtfDStringEx( Tcl_Encoding encoding, /* The encoding for the source string, or NULL * for the default system encoding. */ @@ -1221,7 +1221,7 @@ Tcl_ExternalToUtfDStringEx( src += srcRead; if (result != TCL_CONVERT_NOSPACE) { Tcl_DStringSetLength(dstPtr, soFar); - return (result == TCL_OK) ? (size_t)-1 : (size_t)(src - srcStart); + return (result == TCL_OK) ? TCL_INDEX_NONE : (int)(src - srcStart); } flags &= ~TCL_ENCODING_START; srcLen -= srcRead; @@ -1380,7 +1380,7 @@ Tcl_UtfToExternalDString( Tcl_DString *dstPtr) /* Uninitialized or free DString in which the * converted string is stored. */ { - Tcl_UtfToExternalDStringEx(encoding, src, srcLen, 0, dstPtr); + Tcl_UtfToExternalDStringEx(encoding, src, srcLen, TCL_ENCODING_NOCOMPLAIN, dstPtr); return Tcl_DStringValue(dstPtr); } @@ -1415,7 +1415,7 @@ Tcl_UtfToExternalDString( *------------------------------------------------------------------------- */ -size_t +int Tcl_UtfToExternalDStringEx( Tcl_Encoding encoding, /* The encoding for the converted string, or * NULL for the default system encoding. */ @@ -1459,7 +1459,7 @@ Tcl_UtfToExternalDStringEx( while (i >= soFar) { Tcl_DStringSetLength(dstPtr, i--); } - return (result == TCL_OK) ? (size_t)-1 : (size_t)(src - srcStart); + return (result == TCL_OK) ? TCL_INDEX_NONE : (int)(src - srcStart); } flags &= ~TCL_ENCODING_START; -- cgit v0.12 From f18c5e4638cd2246475e9fabb96410e8696bea81 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Tue, 22 Mar 2022 00:46:17 +0000 Subject: Fix [ac601b59bab7] by making only unloading a library from the process if it has an Unload functions. --- generic/tclLoad.c | 25 ++++++++++++++++++++----- tests/pkgMkIndex.test | 2 +- 2 files changed, 21 insertions(+), 6 deletions(-) diff --git a/generic/tclLoad.c b/generic/tclLoad.c index 7ea1ebd..ee1862d 100644 --- a/generic/tclLoad.c +++ b/generic/tclLoad.c @@ -544,7 +544,7 @@ Tcl_LoadObjCmd( * * Tcl_UnloadObjCmd -- * - * This function is invoked to process the "unload" Tcl command. See the + * Implements the the "unload" Tcl command. See the * user documentation for details on what it does. * * Results: @@ -764,6 +764,23 @@ Tcl_UnloadObjCmd( return code; } + +/* + *---------------------------------------------------------------------- + * + * UnloadLibrary -- + * + * Unloads a library from an interpreter, and also from the process if it + * is unloadable, i.e. if it provides an "unload" function. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See description. + * + *---------------------------------------------------------------------- + */ static int UnloadLibrary( Tcl_Interp *interp, @@ -884,11 +901,9 @@ UnloadLibrary( } /* - * The unload function executed fine. Examine the reference count to see - * if we unload the DLL. + * The unload function was called succesfully. */ - Tcl_MutexLock(&libraryMutex); if (Tcl_IsSafe(target)) { libraryPtr->safeInterpRefCount--; @@ -917,7 +932,7 @@ UnloadLibrary( code = TCL_OK; if (libraryPtr->safeInterpRefCount <= 0 && libraryPtr->interpRefCount <= 0 - && !keepLibrary) { + && (unloadProc != NULL) && !keepLibrary) { /* * Unload the shared library from the application memory... */ diff --git a/tests/pkgMkIndex.test b/tests/pkgMkIndex.test index 62bd3d4..25840c6 100644 --- a/tests/pkgMkIndex.test +++ b/tests/pkgMkIndex.test @@ -591,7 +591,7 @@ test pkgMkIndex-10.2 {package in DLL hidden by -load} [list exec $dll] { "[list pkg_mkIndex -lazy -load Pkg* $fullPkgPath [file tail $x]]" exec [interpreter] << $script pkgtest::runCreatedIndex {0 {}} -lazy -load Pkg* -- $fullPkgPath pkga[info sharedlibextension] -} "0 {{pkga:1.0 {tclPkgSetup {pkga[info sharedlibextension] load {pkga_eq pkga_quote}}}}}" +} "0 {}" if {[testConstraint $dll]} { file delete -force [file join $fullPkgPath [file tail $x]] -- cgit v0.12 From 04474c7892335151b65a951ac743b2855dfaba26 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 25 Mar 2022 15:31:10 +0000 Subject: Fix [9c1dc88f86]: warning about different signedness when compile TCL on Windows. --- generic/tclLink.c | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/generic/tclLink.c b/generic/tclLink.c index 39f5345..ee77654 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -1071,7 +1071,7 @@ LinkTraceProc( if (linkPtr->flags & LINK_ALLOC_LAST) { for (i=0; i < objc; i++) { if (GetInt(objv[i], &valueInt) - || !InRange(0, valueInt, UCHAR_MAX)) { + || !InRange(0, valueInt, (int)UCHAR_MAX)) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); return (char *) @@ -1081,7 +1081,7 @@ LinkTraceProc( } } else { if (GetInt(valueObj, &valueInt) - || !InRange(0, valueInt, UCHAR_MAX)) { + || !InRange(0, valueInt, (int)UCHAR_MAX)) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); return (char *) "variable must have unsigned char value"; @@ -1117,7 +1117,7 @@ LinkTraceProc( if (linkPtr->flags & LINK_ALLOC_LAST) { for (i=0; i < objc; i++) { if (GetInt(objv[i], &valueInt) - || !InRange(0, valueInt, USHRT_MAX)) { + || !InRange(0, valueInt, (int)USHRT_MAX)) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); return (char *) @@ -1127,7 +1127,7 @@ LinkTraceProc( } } else { if (GetInt(valueObj, &valueInt) - || !InRange(0, valueInt, USHRT_MAX)) { + || !InRange(0, valueInt, (int)USHRT_MAX)) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); return (char *) "variable must have unsigned short value"; @@ -1141,7 +1141,7 @@ LinkTraceProc( if (linkPtr->flags & LINK_ALLOC_LAST) { for (i=0; i < objc; i++) { if (GetWide(objv[i], &valueWide) - || !InRange(0, valueWide, UINT_MAX)) { + || !InRange(0, valueWide, (Tcl_WideInt)UINT_MAX)) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); return (char *) @@ -1151,7 +1151,7 @@ LinkTraceProc( } } else { if (GetWide(valueObj, &valueWide) - || !InRange(0, valueWide, UINT_MAX)) { + || !InRange(0, valueWide, (Tcl_WideInt)UINT_MAX)) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); return (char *) "variable must have unsigned int value"; -- cgit v0.12 From 5cb710df9af162eecdda7380baae24d5afd8fa3d Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 28 Mar 2022 11:39:18 +0000 Subject: More usage of TCLFLEXARRAY. Make current_malloc_packets/maximum_malloc_packets type size_t --- generic/tclCkalloc.c | 34 +++++++++++++++++----------------- generic/tclIO.c | 4 ++-- 2 files changed, 19 insertions(+), 19 deletions(-) diff --git a/generic/tclCkalloc.c b/generic/tclCkalloc.c index d0fa300..fbf7b81 100644 --- a/generic/tclCkalloc.c +++ b/generic/tclCkalloc.c @@ -36,7 +36,7 @@ typedef struct MemTag { size_t refCount; /* Number of mem_headers referencing this * tag. */ - char string[1]; /* Actual size of string will be as large as + char string[TCLFLEXARRAY]; /* Actual size of string will be as large as * needed for actual tag. This must be the * last field in the structure. */ } MemTag; @@ -65,7 +65,7 @@ struct mem_header { /* Aligns body on 8-byte boundary, plus * provides at least 8 additional guard bytes * to detect underruns. */ - char body[1]; /* First byte of client's space. Actual size + char body[TCLFLEXARRAY]; /* First byte of client's space. Actual size * of this field will be larger than one. */ }; @@ -93,8 +93,8 @@ static unsigned int total_mallocs = 0; static unsigned int total_frees = 0; static size_t current_bytes_malloced = 0; static size_t maximum_bytes_malloced = 0; -static unsigned int current_malloc_packets = 0; -static unsigned int maximum_malloc_packets = 0; +static size_t current_malloc_packets = 0; +static size_t maximum_malloc_packets = 0; static unsigned int break_on_malloc = 0; static unsigned int trace_on_at_malloc = 0; static int alloc_tracing = FALSE; @@ -188,9 +188,9 @@ TclDumpMemoryInfo( sprintf(buf, "total mallocs %10u\n" "total frees %10u\n" - "current packets allocated %10u\n" + "current packets allocated %10" TCL_Z_MODIFIER "u\n" "current bytes allocated %10" TCL_Z_MODIFIER "u\n" - "maximum packets allocated %10u\n" + "maximum packets allocated %10" TCL_Z_MODIFIER "u\n" "maximum bytes allocated %10" TCL_Z_MODIFIER "u\n", total_mallocs, total_frees, @@ -252,7 +252,7 @@ ValidateMemory( } } if (guard_failed) { - TclDumpMemoryInfo((ClientData) stderr, 0); + TclDumpMemoryInfo(stderr, 0); fprintf(stderr, "low guard failed at %p, %s %d\n", memHeaderP->body, file, line); fflush(stderr); /* In case name pointer is bad. */ @@ -274,7 +274,7 @@ ValidateMemory( } if (guard_failed) { - TclDumpMemoryInfo((ClientData) stderr, 0); + TclDumpMemoryInfo(stderr, 0); fprintf(stderr, "high guard failed at %p, %s %d\n", memHeaderP->body, file, line); fflush(stderr); /* In case name pointer is bad. */ @@ -406,13 +406,13 @@ Tcl_DbCkalloc( } /* Don't let size argument to TclpAlloc overflow */ - if (size <= UINT_MAX - HIGH_GUARD_SIZE -sizeof(struct mem_header)) { + if (size <= UINT_MAX - offsetof(struct mem_header, body) - 1U - HIGH_GUARD_SIZE) { result = (struct mem_header *) TclpAlloc(size + - sizeof(struct mem_header) + HIGH_GUARD_SIZE); + offsetof(struct mem_header, body) + 1U + HIGH_GUARD_SIZE); } if (result == NULL) { fflush(stdout); - TclDumpMemoryInfo((ClientData) stderr, 0); + TclDumpMemoryInfo(stderr, 0); Tcl_Panic("unable to alloc %u bytes, %s line %d", size, file, line); } @@ -424,7 +424,7 @@ Tcl_DbCkalloc( if (init_malloced_bodies) { memset(result, GUARD_VALUE, - size + sizeof(struct mem_header) + HIGH_GUARD_SIZE); + offsetof(struct mem_header, body) + 1U + HIGH_GUARD_SIZE + size); } else { memset(result->low_guard, GUARD_VALUE, LOW_GUARD_SIZE); memset(result->body + size, GUARD_VALUE, HIGH_GUARD_SIZE); @@ -496,13 +496,13 @@ Tcl_AttemptDbCkalloc( } /* Don't let size argument to TclpAlloc overflow */ - if (size <= UINT_MAX - HIGH_GUARD_SIZE - sizeof(struct mem_header)) { + if (size <= UINT_MAX - offsetof(struct mem_header, body) - 1U - HIGH_GUARD_SIZE) { result = (struct mem_header *) TclpAlloc(size + - sizeof(struct mem_header) + HIGH_GUARD_SIZE); + offsetof(struct mem_header, body) + 1U + HIGH_GUARD_SIZE); } if (result == NULL) { fflush(stdout); - TclDumpMemoryInfo((ClientData) stderr, 0); + TclDumpMemoryInfo(stderr, 0); return NULL; } @@ -513,7 +513,7 @@ Tcl_AttemptDbCkalloc( */ if (init_malloced_bodies) { memset(result, GUARD_VALUE, - size + sizeof(struct mem_header) + HIGH_GUARD_SIZE); + offsetof(struct mem_header, body) + 1U + HIGH_GUARD_SIZE + size); } else { memset(result->low_guard, GUARD_VALUE, LOW_GUARD_SIZE); memset(result->body + size, GUARD_VALUE, HIGH_GUARD_SIZE); @@ -857,7 +857,7 @@ MemoryCmd( } if (strcmp(TclGetString(objv[1]),"info") == 0) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "%-25s %10u\n%-25s %10u\n%-25s %10u\n%-25s %10" TCL_Z_MODIFIER"u\n%-25s %10u\n%-25s %10" TCL_Z_MODIFIER "u\n", + "%-25s %10u\n%-25s %10u\n%-25s %10" TCL_Z_MODIFIER "u\n%-25s %10" TCL_Z_MODIFIER "u\n%-25s %10" TCL_Z_MODIFIER "u\n%-25s %10" TCL_Z_MODIFIER "u\n", "total mallocs", total_mallocs, "total frees", total_frees, "current packets allocated", current_malloc_packets, "current bytes allocated", current_bytes_malloced, diff --git a/generic/tclIO.c b/generic/tclIO.c index 9d88948..92bd91b 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -103,7 +103,7 @@ typedef struct CopyState { Tcl_Interp *interp; /* Interp that started the copy. */ Tcl_Obj *cmdPtr; /* Command to be invoked at completion. */ int bufSize; /* Size of appended buffer. */ - char buffer[1]; /* Copy buffer, this must be the last + char buffer[TCLFLEXARRAY]; /* Copy buffer, this must be the last * field. */ } CopyState; @@ -9246,7 +9246,7 @@ TclCopyChannel( * completed. */ - csPtr = (CopyState *)ckalloc(sizeof(CopyState) + !moveBytes * inStatePtr->bufSize); + csPtr = (CopyState *)ckalloc(offsetof(CopyState, buffer) + 1U + !moveBytes * inStatePtr->bufSize); csPtr->bufSize = !moveBytes * inStatePtr->bufSize; csPtr->readPtr = inPtr; csPtr->writePtr = outPtr; -- cgit v0.12 From ad983c6d746da6b31a177f9137e0f0fd1b4b46f9 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 29 Mar 2022 13:40:05 +0000 Subject: Don't bother UINT2PTR, since INT2PTR is just as good. --- generic/tclHash.c | 2 +- generic/tclInt.h | 13 ++++++++----- win/tclWinThrd.c | 2 +- 3 files changed, 10 insertions(+), 7 deletions(-) diff --git a/generic/tclHash.c b/generic/tclHash.c index fa30cee..7538821 100644 --- a/generic/tclHash.c +++ b/generic/tclHash.c @@ -354,7 +354,7 @@ CreateHashEntry( } hPtr->tablePtr = tablePtr; - hPtr->hash = UINT2PTR(hash); + hPtr->hash = INT2PTR(hash); hPtr->nextPtr = tablePtr->buckets[index]; tablePtr->buckets[index] = hPtr; tablePtr->numEntries++; diff --git a/generic/tclInt.h b/generic/tclInt.h index 3f2d1ad..af839fc 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -128,21 +128,24 @@ typedef int ptrdiff_t; * to/from pointer from/to integer of different size". */ -#if !defined(INT2PTR) && !defined(PTR2INT) +#if !defined(INT2PTR) # if defined(HAVE_INTPTR_T) || defined(intptr_t) # define INT2PTR(p) ((void *)(intptr_t)(p)) -# define PTR2INT(p) ((intptr_t)(p)) # else # define INT2PTR(p) ((void *)(p)) +# endif +#endif +#if !defined(PTR2INT) +# if defined(HAVE_INTPTR_T) || defined(intptr_t) +# define PTR2INT(p) ((intptr_t)(p)) +# else # define PTR2INT(p) ((long)(p)) # endif #endif -#if !defined(UINT2PTR) && !defined(PTR2UINT) +#if !defined(PTR2UINT) # if defined(HAVE_UINTPTR_T) || defined(uintptr_t) -# define UINT2PTR(p) ((void *)(uintptr_t)(p)) # define PTR2UINT(p) ((uintptr_t)(p)) # else -# define UINT2PTR(p) ((void *)(p)) # define PTR2UINT(p) ((unsigned long)(p)) # endif #endif diff --git a/win/tclWinThrd.c b/win/tclWinThrd.c index 86db837..b69fbfc 100644 --- a/win/tclWinThrd.c +++ b/win/tclWinThrd.c @@ -326,7 +326,7 @@ TclpThreadExit( Tcl_ThreadId Tcl_GetCurrentThread(void) { - return (Tcl_ThreadId)(size_t)GetCurrentThreadId(); + return (Tcl_ThreadId)INT2PTR(GetCurrentThreadId()); } /* -- cgit v0.12 From 64e68a04f46b82826e8f501c58dc45fbf940f413 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 4 Apr 2022 08:51:12 +0000 Subject: Fix TIP #613 implementation, when (indexPtr) is more than a simple variable name. Thanks, @ashok! --- generic/tclDecls.h | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 57574b8..6161bff 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -4250,29 +4250,29 @@ extern const TclStubs *tclStubsPtr; #endif #if defined(USE_TCL_STUBS) #define Tcl_GetBytesFromObj(interp, objPtr, sizePtr) \ - (sizeof(*sizePtr) <= sizeof(int) ? tclStubsPtr->tclGetBytesFromObj(interp, objPtr, (int *)sizePtr) : tclStubsPtr->tcl_GetBytesFromObj(interp, objPtr, (size_t *)sizePtr)) + (sizeof(*(sizePtr)) <= sizeof(int) ? tclStubsPtr->tclGetBytesFromObj(interp, objPtr, (int *)sizePtr) : tclStubsPtr->tcl_GetBytesFromObj(interp, objPtr, (size_t *)sizePtr)) #define Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, indexPtr) \ - (tclStubsPtr->tcl_GetIndexFromObjStruct((interp), (objPtr), (tablePtr), (offset), (msg), (flags)|(int)(sizeof(*indexPtr)<<8), (indexPtr))) + (tclStubsPtr->tcl_GetIndexFromObjStruct((interp), (objPtr), (tablePtr), (offset), (msg), (flags)|(int)(sizeof(*(indexPtr))<<8), (indexPtr))) #ifdef TCL_NO_DEPRECATED #define Tcl_GetStringFromObj(objPtr, sizePtr) \ - (sizeof(*sizePtr) <= sizeof(int) ? tclStubsPtr->tcl_GetStringFromObj(objPtr, (int *)sizePtr) : tclStubsPtr->tclGetStringFromObj(objPtr, (size_t *)sizePtr)) + (sizeof(*(sizePtr)) <= sizeof(int) ? tclStubsPtr->tcl_GetStringFromObj(objPtr, (int *)sizePtr) : tclStubsPtr->tclGetStringFromObj(objPtr, (size_t *)sizePtr)) #define Tcl_GetByteArrayFromObj(objPtr, sizePtr) \ - (sizeof(*sizePtr) <= sizeof(int) ? tclStubsPtr->tcl_GetByteArrayFromObj(objPtr, (int *)sizePtr) : tclStubsPtr->tclGetByteArrayFromObj(objPtr, (size_t *)sizePtr)) + (sizeof(*(sizePtr)) <= sizeof(int) ? tclStubsPtr->tcl_GetByteArrayFromObj(objPtr, (int *)sizePtr) : tclStubsPtr->tclGetByteArrayFromObj(objPtr, (size_t *)sizePtr)) #define Tcl_GetUnicodeFromObj(objPtr, sizePtr) \ - (sizeof(*sizePtr) <= sizeof(int) ? tclStubsPtr->tcl_GetUnicodeFromObj(objPtr, (int *)sizePtr) : tclStubsPtr->tclGetUnicodeFromObj(objPtr, (size_t *)sizePtr)) + (sizeof(*(sizePtr)) <= sizeof(int) ? tclStubsPtr->tcl_GetUnicodeFromObj(objPtr, (int *)sizePtr) : tclStubsPtr->tclGetUnicodeFromObj(objPtr, (size_t *)sizePtr)) #endif #else #define Tcl_GetBytesFromObj(interp, objPtr, sizePtr) \ - (sizeof(*sizePtr) <= sizeof(int) ? (TclGetBytesFromObj)(interp, objPtr, (int *)sizePtr) : (Tcl_GetBytesFromObj)(interp, objPtr, (size_t *)sizePtr)) + (sizeof(*(sizePtr)) <= sizeof(int) ? (TclGetBytesFromObj)(interp, objPtr, (int *)sizePtr) : (Tcl_GetBytesFromObj)(interp, objPtr, (size_t *)sizePtr)) #define Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, indexPtr) \ - ((Tcl_GetIndexFromObjStruct)((interp), (objPtr), (tablePtr), (offset), (msg), (flags)|(int)(sizeof(*indexPtr)<<8), (indexPtr))) + ((Tcl_GetIndexFromObjStruct)((interp), (objPtr), (tablePtr), (offset), (msg), (flags)|(int)(sizeof(*(indexPtr))<<8), (indexPtr))) #ifdef TCL_NO_DEPRECATED #define Tcl_GetStringFromObj(objPtr, sizePtr) \ - (sizeof(*sizePtr) <= sizeof(int) ? (Tcl_GetStringFromObj)(objPtr, (int *)sizePtr) : (TclGetStringFromObj)(objPtr, (size_t *)sizePtr)) + (sizeof(*(sizePtr)) <= sizeof(int) ? (Tcl_GetStringFromObj)(objPtr, (int *)sizePtr) : (TclGetStringFromObj)(objPtr, (size_t *)sizePtr)) #define Tcl_GetByteArrayFromObj(objPtr, sizePtr) \ - (sizeof(*sizePtr) <= sizeof(int) ? (Tcl_GetByteArrayFromObj)(objPtr, (int *)sizePtr) : TclGetByteArrayFromObj(objPtr, (size_t *)sizePtr)) + (sizeof(*(sizePtr)) <= sizeof(int) ? (Tcl_GetByteArrayFromObj)(objPtr, (int *)sizePtr) : TclGetByteArrayFromObj(objPtr, (size_t *)sizePtr)) #define Tcl_GetUnicodeFromObj(objPtr, sizePtr) \ - (sizeof(*sizePtr) <= sizeof(int) ? (Tcl_GetUnicodeFromObj)(objPtr, (int *)sizePtr) : TclGetUnicodeFromObj(objPtr, (size_t *)sizePtr)) + (sizeof(*(sizePtr)) <= sizeof(int) ? (Tcl_GetUnicodeFromObj)(objPtr, (int *)sizePtr) : TclGetUnicodeFromObj(objPtr, (size_t *)sizePtr)) #endif #endif -- cgit v0.12 From 403ba3fe0d4ff125a0eb88ae9ee245e328c09350 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 4 Apr 2022 11:30:15 +0000 Subject: Additional braces for (sizePtr), just to be sure --- generic/tclDecls.h | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 6161bff..790cddb 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -4250,29 +4250,29 @@ extern const TclStubs *tclStubsPtr; #endif #if defined(USE_TCL_STUBS) #define Tcl_GetBytesFromObj(interp, objPtr, sizePtr) \ - (sizeof(*(sizePtr)) <= sizeof(int) ? tclStubsPtr->tclGetBytesFromObj(interp, objPtr, (int *)sizePtr) : tclStubsPtr->tcl_GetBytesFromObj(interp, objPtr, (size_t *)sizePtr)) + (sizeof(*(sizePtr)) <= sizeof(int) ? tclStubsPtr->tclGetBytesFromObj(interp, objPtr, (int *)(sizePtr)) : tclStubsPtr->tcl_GetBytesFromObj(interp, objPtr, (size_t *)(sizePtr))) #define Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, indexPtr) \ (tclStubsPtr->tcl_GetIndexFromObjStruct((interp), (objPtr), (tablePtr), (offset), (msg), (flags)|(int)(sizeof(*(indexPtr))<<8), (indexPtr))) #ifdef TCL_NO_DEPRECATED #define Tcl_GetStringFromObj(objPtr, sizePtr) \ - (sizeof(*(sizePtr)) <= sizeof(int) ? tclStubsPtr->tcl_GetStringFromObj(objPtr, (int *)sizePtr) : tclStubsPtr->tclGetStringFromObj(objPtr, (size_t *)sizePtr)) + (sizeof(*(sizePtr)) <= sizeof(int) ? tclStubsPtr->tcl_GetStringFromObj(objPtr, (int *)(sizePtr)) : tclStubsPtr->tclGetStringFromObj(objPtr, (size_t *)(sizePtr))) #define Tcl_GetByteArrayFromObj(objPtr, sizePtr) \ - (sizeof(*(sizePtr)) <= sizeof(int) ? tclStubsPtr->tcl_GetByteArrayFromObj(objPtr, (int *)sizePtr) : tclStubsPtr->tclGetByteArrayFromObj(objPtr, (size_t *)sizePtr)) + (sizeof(*(sizePtr)) <= sizeof(int) ? tclStubsPtr->tcl_GetByteArrayFromObj(objPtr, (int *)(sizePtr)) : tclStubsPtr->tclGetByteArrayFromObj(objPtr, (size_t *)(sizePtr))) #define Tcl_GetUnicodeFromObj(objPtr, sizePtr) \ - (sizeof(*(sizePtr)) <= sizeof(int) ? tclStubsPtr->tcl_GetUnicodeFromObj(objPtr, (int *)sizePtr) : tclStubsPtr->tclGetUnicodeFromObj(objPtr, (size_t *)sizePtr)) + (sizeof(*(sizePtr)) <= sizeof(int) ? tclStubsPtr->tcl_GetUnicodeFromObj(objPtr, (int *)(sizePtr)) : tclStubsPtr->tclGetUnicodeFromObj(objPtr, (size_t *)(sizePtr))) #endif #else #define Tcl_GetBytesFromObj(interp, objPtr, sizePtr) \ - (sizeof(*(sizePtr)) <= sizeof(int) ? (TclGetBytesFromObj)(interp, objPtr, (int *)sizePtr) : (Tcl_GetBytesFromObj)(interp, objPtr, (size_t *)sizePtr)) + (sizeof(*(sizePtr)) <= sizeof(int) ? (TclGetBytesFromObj)(interp, objPtr, (int *)(sizePtr)) : (Tcl_GetBytesFromObj)(interp, objPtr, (size_t *)(sizePtr))) #define Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, indexPtr) \ ((Tcl_GetIndexFromObjStruct)((interp), (objPtr), (tablePtr), (offset), (msg), (flags)|(int)(sizeof(*(indexPtr))<<8), (indexPtr))) #ifdef TCL_NO_DEPRECATED #define Tcl_GetStringFromObj(objPtr, sizePtr) \ - (sizeof(*(sizePtr)) <= sizeof(int) ? (Tcl_GetStringFromObj)(objPtr, (int *)sizePtr) : (TclGetStringFromObj)(objPtr, (size_t *)sizePtr)) + (sizeof(*(sizePtr)) <= sizeof(int) ? (Tcl_GetStringFromObj)(objPtr, (int *)(sizePtr)) : (TclGetStringFromObj)(objPtr, (size_t *)(sizePtr))) #define Tcl_GetByteArrayFromObj(objPtr, sizePtr) \ - (sizeof(*(sizePtr)) <= sizeof(int) ? (Tcl_GetByteArrayFromObj)(objPtr, (int *)sizePtr) : TclGetByteArrayFromObj(objPtr, (size_t *)sizePtr)) + (sizeof(*(sizePtr)) <= sizeof(int) ? (Tcl_GetByteArrayFromObj)(objPtr, (int *)(sizePtr)) : TclGetByteArrayFromObj(objPtr, (size_t *)(sizePtr))) #define Tcl_GetUnicodeFromObj(objPtr, sizePtr) \ - (sizeof(*(sizePtr)) <= sizeof(int) ? (Tcl_GetUnicodeFromObj)(objPtr, (int *)sizePtr) : TclGetUnicodeFromObj(objPtr, (size_t *)sizePtr)) + (sizeof(*(sizePtr)) <= sizeof(int) ? (Tcl_GetUnicodeFromObj)(objPtr, (int *)(sizePtr)) : TclGetUnicodeFromObj(objPtr, (size_t *)(sizePtr))) #endif #endif -- cgit v0.12 From 84ff1fb2d98ae85007f676e3872803497dbea1fe Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 4 Apr 2022 14:32:57 +0000 Subject: In tclCkalloc.c, count malloc/free's using size_t in stead of unsigned int. --- generic/tclCkalloc.c | 44 ++++++++++++++++++++++---------------------- 1 file changed, 22 insertions(+), 22 deletions(-) diff --git a/generic/tclCkalloc.c b/generic/tclCkalloc.c index fbf7b81..18a6400 100644 --- a/generic/tclCkalloc.c +++ b/generic/tclCkalloc.c @@ -33,7 +33,7 @@ * "memory tag" command is invoked, to hold the current tag. */ -typedef struct MemTag { +typedef struct { size_t refCount; /* Number of mem_headers referencing this * tag. */ char string[TCLFLEXARRAY]; /* Actual size of string will be as large as @@ -71,7 +71,7 @@ struct mem_header { static struct mem_header *allocHead = NULL; /* List of allocated structures */ -#define GUARD_VALUE 0141 +#define GUARD_VALUE 0x61 /* * The following macro determines the amount of guard space *above* each chunk @@ -89,14 +89,14 @@ static struct mem_header *allocHead = NULL; /* List of allocated structures */ #define BODY_OFFSET \ ((size_t) (&((struct mem_header *) 0)->body)) -static unsigned int total_mallocs = 0; -static unsigned int total_frees = 0; +static size_t total_mallocs = 0; +static size_t total_frees = 0; static size_t current_bytes_malloced = 0; static size_t maximum_bytes_malloced = 0; static size_t current_malloc_packets = 0; static size_t maximum_malloc_packets = 0; -static unsigned int break_on_malloc = 0; -static unsigned int trace_on_at_malloc = 0; +static size_t break_on_malloc = 0; +static size_t trace_on_at_malloc = 0; static int alloc_tracing = FALSE; static int init_malloced_bodies = TRUE; #ifdef MEM_VALIDATE @@ -186,8 +186,8 @@ TclDumpMemoryInfo( return 0; } sprintf(buf, - "total mallocs %10u\n" - "total frees %10u\n" + "total mallocs %10" TCL_Z_MODIFIER "u\n" + "total frees %10" TCL_Z_MODIFIER "u\n" "current packets allocated %10" TCL_Z_MODIFIER "u\n" "current bytes allocated %10" TCL_Z_MODIFIER "u\n" "maximum packets allocated %10" TCL_Z_MODIFIER "u\n" @@ -247,7 +247,7 @@ ValidateMemory( guard_failed = TRUE; fflush(stdout); byte &= 0xFF; - fprintf(stderr, "low guard byte %d is 0x%x \t%c\n", (int)idx, byte, + fprintf(stderr, "low guard byte %" TCL_Z_MODIFIER "u is 0x%x \t%c\n", idx, byte, (isprint(UCHAR(byte)) ? byte : ' ')); /* INTL: bytes */ } } @@ -268,7 +268,7 @@ ValidateMemory( guard_failed = TRUE; fflush(stdout); byte &= 0xFF; - fprintf(stderr, "hi guard byte %d is 0x%x \t%c\n", (int)idx, byte, + fprintf(stderr, "hi guard byte %" TCL_Z_MODIFIER "u is 0x%x \t%c\n", idx, byte, (isprint(UCHAR(byte)) ? byte : ' ')); /* INTL: bytes */ } } @@ -451,7 +451,7 @@ Tcl_DbCkalloc( total_mallocs++; if (trace_on_at_malloc && (total_mallocs >= trace_on_at_malloc)) { (void) fflush(stdout); - fprintf(stderr, "reached malloc trace enable point (%u)\n", + fprintf(stderr, "reached malloc trace enable point (%" TCL_Z_MODIFIER "u)\n", total_mallocs); fflush(stderr); alloc_tracing = TRUE; @@ -466,7 +466,7 @@ Tcl_DbCkalloc( if (break_on_malloc && (total_mallocs >= break_on_malloc)) { break_on_malloc = 0; (void) fflush(stdout); - Tcl_Panic("reached malloc break limit (%u)", total_mallocs); + Tcl_Panic("reached malloc break limit (%" TCL_Z_MODIFIER "u)", total_mallocs); } current_malloc_packets++; @@ -540,7 +540,7 @@ Tcl_AttemptDbCkalloc( total_mallocs++; if (trace_on_at_malloc && (total_mallocs >= trace_on_at_malloc)) { (void) fflush(stdout); - fprintf(stderr, "reached malloc trace enable point (%d)\n", + fprintf(stderr, "reached malloc trace enable point (%" TCL_Z_MODIFIER "u)\n", total_mallocs); fflush(stderr); alloc_tracing = TRUE; @@ -555,7 +555,7 @@ Tcl_AttemptDbCkalloc( if (break_on_malloc && (total_mallocs >= break_on_malloc)) { break_on_malloc = 0; (void) fflush(stdout); - Tcl_Panic("reached malloc break limit (%d)", total_mallocs); + Tcl_Panic("reached malloc break limit (%" TCL_Z_MODIFIER "u)", total_mallocs); } current_malloc_packets++; @@ -692,7 +692,7 @@ Tcl_DbCkrealloc( if (copySize > memp->length) { copySize = memp->length; } - newPtr = Tcl_DbCkalloc(size, file, line); + newPtr = (char *)Tcl_DbCkalloc(size, file, line); memcpy(newPtr, ptr, copySize); Tcl_DbCkfree(ptr, file, line); return newPtr; @@ -723,7 +723,7 @@ Tcl_AttemptDbCkrealloc( if (copySize > memp->length) { copySize = memp->length; } - newPtr = Tcl_AttemptDbCkalloc(size, file, line); + newPtr = (char *)Tcl_AttemptDbCkalloc(size, file, line); if (newPtr == NULL) { return NULL; } @@ -845,19 +845,19 @@ MemoryCmd( return TCL_OK; } if (strcmp(TclGetString(objv[1]),"break_on_malloc") == 0) { - int value; + Tcl_WideInt value; if (objc != 3) { goto argError; } - if (Tcl_GetIntFromObj(interp, objv[2], &value) != TCL_OK) { + if (Tcl_GetWideIntFromObj(interp, objv[2], &value) != TCL_OK) { return TCL_ERROR; } - break_on_malloc = (unsigned int) value; + break_on_malloc = value; return TCL_OK; } if (strcmp(TclGetString(objv[1]),"info") == 0) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "%-25s %10u\n%-25s %10u\n%-25s %10" TCL_Z_MODIFIER "u\n%-25s %10" TCL_Z_MODIFIER "u\n%-25s %10" TCL_Z_MODIFIER "u\n%-25s %10" TCL_Z_MODIFIER "u\n", + "%-25s %10" TCL_Z_MODIFIER "u\n%-25s %10" TCL_Z_MODIFIER "u\n%-25s %10" TCL_Z_MODIFIER "u\n%-25s %10" TCL_Z_MODIFIER "u\n%-25s %10" TCL_Z_MODIFIER "u\n%-25s %10" TCL_Z_MODIFIER "u\n", "total mallocs", total_mallocs, "total frees", total_frees, "current packets allocated", current_malloc_packets, "current bytes allocated", current_bytes_malloced, @@ -930,11 +930,11 @@ MemoryCmd( } if (strcmp(TclGetString(objv[1]),"trace_on_at_malloc") == 0) { - int value; + Tcl_WideInt value; if (objc != 3) { goto argError; } - if (Tcl_GetIntFromObj(interp, objv[2], &value) != TCL_OK) { + if (Tcl_GetWideIntFromObj(interp, objv[2], &value) != TCL_OK) { return TCL_ERROR; } trace_on_at_malloc = value; -- cgit v0.12 From ecd8e8bce1ae18281cf79ca447cbafe017127afb Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 8 Apr 2022 12:10:35 +0000 Subject: Use INT2PTR/PTR2INT macro's as appropriate --- generic/tclThreadTest.c | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/generic/tclThreadTest.c b/generic/tclThreadTest.c index 9f08d83..49633f2 100644 --- a/generic/tclThreadTest.c +++ b/generic/tclThreadTest.c @@ -271,7 +271,7 @@ ThreadObjCmd( } else { result = NULL; } - return ThreadCancel(interp, (Tcl_ThreadId) (size_t) id, result, flags); + return ThreadCancel(interp, (Tcl_ThreadId) INT2PTR(id), result, flags); } case THREAD_CREATE: { const char *script; @@ -335,11 +335,11 @@ ThreadObjCmd( */ if (objc == 2) { - idObj = Tcl_NewWideIntObj((Tcl_WideInt)(size_t)Tcl_GetCurrentThread()); + idObj = Tcl_NewWideIntObj((Tcl_WideInt)PTR2INT(Tcl_GetCurrentThread())); } else if (objc == 3 && strcmp("-main", Tcl_GetString(objv[2])) == 0) { Tcl_MutexLock(&threadMutex); - idObj = Tcl_NewWideIntObj((Tcl_WideInt)(size_t)mainThreadId); + idObj = Tcl_NewWideIntObj((Tcl_WideInt)PTR2INT(mainThreadId)); Tcl_MutexUnlock(&threadMutex); } else { Tcl_WrongNumArgs(interp, 2, objv, NULL); @@ -364,7 +364,7 @@ ThreadObjCmd( return TCL_ERROR; } - result = Tcl_JoinThread((Tcl_ThreadId)(size_t)id, &status); + result = Tcl_JoinThread((Tcl_ThreadId)INT2PTR(id), &status); if (result == TCL_OK) { Tcl_SetIntObj(Tcl_GetObjResult(interp), status); } else { @@ -406,7 +406,7 @@ ThreadObjCmd( } arg++; script = Tcl_GetString(objv[arg]); - return ThreadSend(interp, (Tcl_ThreadId)(size_t)id, script, wait); + return ThreadSend(interp, (Tcl_ThreadId)INT2PTR(id), script, wait); } case THREAD_EVENT: { if (objc > 2) { -- cgit v0.12 From 875d378d39f1fc5f50cdec1bd338dc1a3da0a24b Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 12 Apr 2022 14:34:59 +0000 Subject: Adapt tclZipfs.c to zlib 1.2.12 (due to the changes in crc32 handling) --- generic/tclZipfs.c | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c index afd3db5..c936a15 100644 --- a/generic/tclZipfs.c +++ b/generic/tclZipfs.c @@ -27,7 +27,6 @@ #define MAP_FILE 0 #endif /* !MAP_FILE */ #define NOBYFOUR -#define crc32tab crc_table[0] #ifndef TBLS #define TBLS 1 #endif @@ -75,6 +74,8 @@ #include "zutil.h" #include "crc32.h" +static const z_crc_t* crc32tab; + /* ** We are compiling as part of the core. ** TIP430 style zipfs prefix @@ -1864,6 +1865,7 @@ ZipfsSetup(void) Tcl_MutexUnlock(&ZipFSMutex); #endif /* TCL_THREADS */ + crc32tab = get_crc_table(); Tcl_FSRegister(NULL, &zipfsFilesystem); Tcl_InitHashTable(&ZipFS.fileHash, TCL_STRING_KEYS); Tcl_InitHashTable(&ZipFS.zipHash, TCL_STRING_KEYS); -- cgit v0.12 From 947765ea8e861dc97a9be4ad0ccbe48711bd6336 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 14 Apr 2022 06:13:41 +0000 Subject: It looks like minizip is broken, so let's use zip --- .github/workflows/win-build.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/win-build.yml b/.github/workflows/win-build.yml index 52fa62b..dce303b 100644 --- a/.github/workflows/win-build.yml +++ b/.github/workflows/win-build.yml @@ -64,7 +64,7 @@ jobs: uses: msys2/setup-msys2@v2 with: msystem: MINGW64 - install: git mingw-w64-x86_64-toolchain make + install: git mingw-w64-x86_64-toolchain make zip - name: Checkout uses: actions/checkout@v2 - name: Prepare -- cgit v0.12 From 13bc6164ae80bf7754d741a93f5a2c6e396ed43d Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 14 Apr 2022 08:48:53 +0000 Subject: Change the actual value of TCL_INDEX_NULL_OK (TIP #613) to a better value which conflicts less with other flags --- generic/tcl.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tcl.h b/generic/tcl.h index ef0fa75..eff58b3 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -985,7 +985,7 @@ typedef struct Tcl_DString { #define TCL_EXACT 1 #define TCL_INDEX_TEMP_TABLE 2 -#define TCL_INDEX_NULL_OK 4 +#define TCL_INDEX_NULL_OK 32 /* *---------------------------------------------------------------------------- -- cgit v0.12 From c89ef9ea024c6edbc2ced2f4d00d63cdc66f9e8e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 14 Apr 2022 14:05:38 +0000 Subject: Proposed fix for [5294e6feca]: minizip for TIP #430 broken --- .github/workflows/win-build.yml | 2 +- compat/zlib/contrib/minizip/ioapi.c | 6 +- compat/zlib/contrib/minizip/minizip.c | 270 ++++++----- compat/zlib/contrib/minizip/tinydir.h | 816 ++++++++++++++++++++++++++++++++++ 4 files changed, 979 insertions(+), 115 deletions(-) create mode 100644 compat/zlib/contrib/minizip/tinydir.h diff --git a/.github/workflows/win-build.yml b/.github/workflows/win-build.yml index dce303b..52fa62b 100644 --- a/.github/workflows/win-build.yml +++ b/.github/workflows/win-build.yml @@ -64,7 +64,7 @@ jobs: uses: msys2/setup-msys2@v2 with: msystem: MINGW64 - install: git mingw-w64-x86_64-toolchain make zip + install: git mingw-w64-x86_64-toolchain make - name: Checkout uses: actions/checkout@v2 - name: Prepare diff --git a/compat/zlib/contrib/minizip/ioapi.c b/compat/zlib/contrib/minizip/ioapi.c index d666e5a..ffcb937 100644 --- a/compat/zlib/contrib/minizip/ioapi.c +++ b/compat/zlib/contrib/minizip/ioapi.c @@ -14,7 +14,11 @@ #define _CRT_SECURE_NO_WARNINGS #endif -#if defined(__APPLE__) || defined(IOAPI_NO_64) +#if defined(_WIN32) +#define FOPEN_FUNC(filename, mode) fopen(filename, mode) +#define FTELLO_FUNC(stream) _ftelli64(stream) +#define FSEEKO_FUNC(stream, offset, origin) _fseeki64(stream, offset, origin) +#elif defined(__APPLE__) || defined(IOAPI_NO_64) // In darwin and perhaps other BSD variants off_t is a 64 bit value, hence no need for specific 64 bit functions #define FOPEN_FUNC(filename, mode) fopen(filename, mode) #define FTELLO_FUNC(stream) ftello(stream) diff --git a/compat/zlib/contrib/minizip/minizip.c b/compat/zlib/contrib/minizip/minizip.c index 7f937aa..e03e2b1 100644 --- a/compat/zlib/contrib/minizip/minizip.c +++ b/compat/zlib/contrib/minizip/minizip.c @@ -28,7 +28,11 @@ #endif #endif -#ifdef __APPLE__ +#if defined(_WIN32) +#define FOPEN_FUNC(filename, mode) fopen(filename, mode) +#define FTELLO_FUNC(stream) _ftelli64(stream) +#define FSEEKO_FUNC(stream, offset, origin) _fseeki64(stream, offset, origin) +#elif defined(__APPLE__) || defined(IOAPI_NO_64) // In darwin and perhaps other BSD variants off_t is a 64 bit value, hence no need for specific 64 bit functions #define FOPEN_FUNC(filename, mode) fopen(filename, mode) #define FTELLO_FUNC(stream) ftello(stream) @@ -39,8 +43,7 @@ #define FSEEKO_FUNC(stream, offset, origin) fseeko64(stream, offset, origin) #endif - - +#include "tinydir.h" #include #include #include @@ -138,7 +141,7 @@ static int filetime(f, tmzip, dt) return ret; } #else -uLong filetime(f, tmzip, dt) +static int filetime(f, tmzip, dt) const char *f; /* name of file to get info on */ tm_zip *tmzip; /* return value: access, modific. and creation times */ uLong *dt; /* dostime */ @@ -173,6 +176,7 @@ static void do_banner() static void do_help() { printf("Usage : minizip [-o] [-a] [-0 to -9] [-p password] [-j] file.zip [files_to_add]\n\n" \ + " -r Scan directories recursively\n" \ " -o Overwrite existing file.zip\n" \ " -a Append to existing file.zip\n" \ " -0 Store only\n" \ @@ -244,12 +248,153 @@ static int isLargeFile(const char* filename) return largeFile; } +void addFileToZip(zipFile zf, const char *filenameinzip, const char *password, int opt_exclude_path,int opt_compress_level) { + FILE * fin; + int size_read; + const char *savefilenameinzip; + zip_fileinfo zi; + unsigned long crcFile=0; + int zip64 = 0; + int err=0; + int size_buf=WRITEBUFFERSIZE; + unsigned char buf[WRITEBUFFERSIZE]; + zi.tmz_date.tm_sec = zi.tmz_date.tm_min = zi.tmz_date.tm_hour = + zi.tmz_date.tm_mday = zi.tmz_date.tm_mon = zi.tmz_date.tm_year = 0; + zi.dosDate = 0; + zi.internal_fa = 0; + zi.external_fa = 0; + filetime(filenameinzip,&zi.tmz_date,&zi.dosDate); + +/* + err = zipOpenNewFileInZip(zf,filenameinzip,&zi, + NULL,0,NULL,0,NULL / * comment * /, + (opt_compress_level != 0) ? Z_DEFLATED : 0, + opt_compress_level); +*/ + if ((password != NULL) && (err==ZIP_OK)) + err = getFileCrc(filenameinzip,buf,size_buf,&crcFile); + + zip64 = isLargeFile(filenameinzip); + + /* The path name saved, should not include a leading slash. */ + /*if it did, windows/xp and dynazip couldn't read the zip file. */ + savefilenameinzip = filenameinzip; + while( savefilenameinzip[0] == '\\' || savefilenameinzip[0] == '/' ) + { + savefilenameinzip++; + } + + /*should the zip file contain any path at all?*/ + if( opt_exclude_path ) + { + const char *tmpptr; + const char *lastslash = 0; + for( tmpptr = savefilenameinzip; *tmpptr; tmpptr++) + { + if( *tmpptr == '\\' || *tmpptr == '/') + { + lastslash = tmpptr; + } + } + if( lastslash != NULL ) + { + savefilenameinzip = lastslash+1; // base filename follows last slash. + } + } + + /**/ + err = zipOpenNewFileInZip3_64(zf,savefilenameinzip,&zi, + NULL,0,NULL,0,NULL /* comment*/, + (opt_compress_level != 0) ? Z_DEFLATED : 0, + opt_compress_level,0, + /* -MAX_WBITS, DEF_MEM_LEVEL, Z_DEFAULT_STRATEGY, */ + -MAX_WBITS, DEF_MEM_LEVEL, Z_DEFAULT_STRATEGY, + password,crcFile, zip64); + + if (err != ZIP_OK) + printf("error in opening %s in zipfile\n",filenameinzip); + else + { + fin = FOPEN_FUNC(filenameinzip,"rb"); + if (fin==NULL) + { + err=ZIP_ERRNO; + printf("error in opening %s for reading\n",filenameinzip); + } + } + + if (err == ZIP_OK) + do + { + err = ZIP_OK; + size_read = (int)fread(buf,1,size_buf,fin); + if (size_read < size_buf) + if (feof(fin)==0) + { + printf("error in reading %s\n",filenameinzip); + err = ZIP_ERRNO; + } + + if (size_read>0) + { + err = zipWriteInFileInZip (zf,buf,size_read); + if (err<0) + { + printf("error in writing %s in the zipfile\n", + filenameinzip); + } + + } + } while ((err == ZIP_OK) && (size_read>0)); + + if (fin) + fclose(fin); + + if (err<0) + err=ZIP_ERRNO; + else + { + err = zipCloseFileInZip(zf); + if (err!=ZIP_OK) + printf("error in closing %s in the zipfile\n", + filenameinzip); + } +} + + +void addPathToZip(zipFile zf, const char *filenameinzip, const char *password, int opt_exclude_path,int opt_compress_level) { + tinydir_dir dir; + int i; + char newname[512]; + + tinydir_open_sorted(&dir, filenameinzip); + + for (i = 0; i < dir.n_files; i++) + { + tinydir_file file; + tinydir_readfile_n(&dir, &file, i); + if(strcmp(file.name,".")==0) continue; + if(strcmp(file.name,"..")==0) continue; + sprintf(newname,"%s/%s",dir.path,file.name); + if (file.is_dir) + { + addPathToZip(zf,newname,password,opt_exclude_path,opt_compress_level); + } else { + addFileToZip(zf,newname,password,opt_exclude_path,opt_compress_level); + } + } + + tinydir_close(&dir); +} + + int main(argc,argv) int argc; char *argv[]; { int i; - int opt_overwrite=0; + int opt_recursive=0; + int opt_overwrite=1; int opt_compress_level=Z_DEFAULT_COMPRESSION; int opt_exclude_path=0; int zipfilenamearg = 0; @@ -286,6 +431,8 @@ int main(argc,argv) opt_compress_level = c-'0'; if ((c=='j') || (c=='J')) opt_exclude_path = 1; + if ((c=='r') || (c=='R')) + opt_recursive = 1; if (((c=='p') || (c=='P')) && (i+1='0') || (argv[i][1]<='9'))) && (strlen(argv[i]) == 2))) { - FILE * fin; - size_t size_read; - const char* filenameinzip = argv[i]; - const char *savefilenameinzip; - zip_fileinfo zi; - unsigned long crcFile=0; - int zip64 = 0; - - zi.tmz_date.tm_sec = zi.tmz_date.tm_min = zi.tmz_date.tm_hour = - zi.tmz_date.tm_mday = zi.tmz_date.tm_mon = zi.tmz_date.tm_year = 0; - zi.dosDate = 0; - zi.internal_fa = 0; - zi.external_fa = 0; - filetime(filenameinzip,&zi.tmz_date,&zi.dosDate); - -/* - err = zipOpenNewFileInZip(zf,filenameinzip,&zi, - NULL,0,NULL,0,NULL / * comment * /, - (opt_compress_level != 0) ? Z_DEFLATED : 0, - opt_compress_level); -*/ - if ((password != NULL) && (err==ZIP_OK)) - err = getFileCrc(filenameinzip,buf,size_buf,&crcFile); - - zip64 = isLargeFile(filenameinzip); - - /* The path name saved, should not include a leading slash. */ - /*if it did, windows/xp and dynazip couldn't read the zip file. */ - savefilenameinzip = filenameinzip; - while( savefilenameinzip[0] == '\\' || savefilenameinzip[0] == '/' ) - { - savefilenameinzip++; - } - - /*should the zip file contain any path at all?*/ - if( opt_exclude_path ) - { - const char *tmpptr; - const char *lastslash = 0; - for( tmpptr = savefilenameinzip; *tmpptr; tmpptr++) - { - if( *tmpptr == '\\' || *tmpptr == '/') - { - lastslash = tmpptr; - } - } - if( lastslash != NULL ) - { - savefilenameinzip = lastslash+1; // base filename follows last slash. - } - } - - /**/ - err = zipOpenNewFileInZip3_64(zf,savefilenameinzip,&zi, - NULL,0,NULL,0,NULL /* comment*/, - (opt_compress_level != 0) ? Z_DEFLATED : 0, - opt_compress_level,0, - /* -MAX_WBITS, DEF_MEM_LEVEL, Z_DEFAULT_STRATEGY, */ - -MAX_WBITS, DEF_MEM_LEVEL, Z_DEFAULT_STRATEGY, - password,crcFile, zip64); - - if (err != ZIP_OK) - printf("error in opening %s in zipfile\n",filenameinzip); - else - { - fin = FOPEN_FUNC(filenameinzip,"rb"); - if (fin==NULL) - { - err=ZIP_ERRNO; - printf("error in opening %s for reading\n",filenameinzip); - } - } - - if (err == ZIP_OK) - do - { - err = ZIP_OK; - size_read = fread(buf,1,size_buf,fin); - if (size_read < size_buf) - if (feof(fin)==0) - { - printf("error in reading %s\n",filenameinzip); - err = ZIP_ERRNO; - } - - if (size_read>0) - { - err = zipWriteInFileInZip (zf,buf,(unsigned)size_read); - if (err<0) - { - printf("error in writing %s in the zipfile\n", - filenameinzip); - } - - } - } while ((err == ZIP_OK) && (size_read>0)); - - if (fin) - fclose(fin); - - if (err<0) - err=ZIP_ERRNO; - else - { - err = zipCloseFileInZip(zf); - if (err!=ZIP_OK) - printf("error in closing %s in the zipfile\n", - filenameinzip); + if(opt_recursive) { + addPathToZip(zf,argv[i],password,opt_exclude_path,opt_compress_level); + } else { + addFileToZip(zf,argv[i],password,opt_exclude_path,opt_compress_level); } } } diff --git a/compat/zlib/contrib/minizip/tinydir.h b/compat/zlib/contrib/minizip/tinydir.h new file mode 100644 index 0000000..eb34399 --- /dev/null +++ b/compat/zlib/contrib/minizip/tinydir.h @@ -0,0 +1,816 @@ +/* +Copyright (c) 2013-2017, tinydir authors: +- Cong Xu +- Lautis Sun +- Baudouin Feildel +- Andargor +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*/ +#ifndef TINYDIR_H +#define TINYDIR_H + +#ifdef __cplusplus +extern "C" { +#endif + +#if ((defined _UNICODE) && !(defined UNICODE)) +#define UNICODE +#endif + +#if ((defined UNICODE) && !(defined _UNICODE)) +#define _UNICODE +#endif + +#include +#include +#include +#ifdef _MSC_VER +# define WIN32_LEAN_AND_MEAN +# include +# include +# pragma warning(push) +# pragma warning (disable : 4996) +#else +# include +# include +# include +# include +#endif +#ifdef __MINGW32__ +# include +#endif + + +/* types */ + +/* Windows UNICODE wide character support */ +#if defined _MSC_VER || defined __MINGW32__ +# define _tinydir_char_t TCHAR +# define TINYDIR_STRING(s) _TEXT(s) +# define _tinydir_strlen _tcslen +# define _tinydir_strcpy _tcscpy +# define _tinydir_strcat _tcscat +# define _tinydir_strcmp _tcscmp +# define _tinydir_strrchr _tcsrchr +# define _tinydir_strncmp _tcsncmp +#else +# define _tinydir_char_t char +# define TINYDIR_STRING(s) s +# define _tinydir_strlen strlen +# define _tinydir_strcpy strcpy +# define _tinydir_strcat strcat +# define _tinydir_strcmp strcmp +# define _tinydir_strrchr strrchr +# define _tinydir_strncmp strncmp +#endif + +#if (defined _MSC_VER || defined __MINGW32__) +# include +# define _TINYDIR_PATH_MAX MAX_PATH +#elif defined __linux__ +# include +# define _TINYDIR_PATH_MAX PATH_MAX +#elif defined(__unix__) || (defined(__APPLE__) && defined(__MACH__)) +# include +# if defined(BSD) +# include +# define _TINYDIR_PATH_MAX PATH_MAX +# endif +#endif + +#ifndef _TINYDIR_PATH_MAX +#define _TINYDIR_PATH_MAX 4096 +#endif + +#ifdef _MSC_VER +/* extra chars for the "\\*" mask */ +# define _TINYDIR_PATH_EXTRA 2 +#else +# define _TINYDIR_PATH_EXTRA 0 +#endif + +#define _TINYDIR_FILENAME_MAX 256 + +#if (defined _MSC_VER || defined __MINGW32__) +#define _TINYDIR_DRIVE_MAX 3 +#endif + +#ifdef _MSC_VER +# define _TINYDIR_FUNC static __inline +#elif !defined __STDC_VERSION__ || __STDC_VERSION__ < 199901L +# define _TINYDIR_FUNC static __inline__ +#else +# define _TINYDIR_FUNC static inline +#endif + +/* readdir_r usage; define TINYDIR_USE_READDIR_R to use it (if supported) */ +#ifdef TINYDIR_USE_READDIR_R + +/* readdir_r is a POSIX-only function, and may not be available under various + * environments/settings, e.g. MinGW. Use readdir fallback */ +#if _POSIX_C_SOURCE >= 1 || _XOPEN_SOURCE || _BSD_SOURCE || _SVID_SOURCE ||\ + _POSIX_SOURCE +# define _TINYDIR_HAS_READDIR_R +#endif +#if _POSIX_C_SOURCE >= 200112L +# define _TINYDIR_HAS_FPATHCONF +# include +#endif +#if _BSD_SOURCE || _SVID_SOURCE || \ + (_POSIX_C_SOURCE >= 200809L || _XOPEN_SOURCE >= 700) +# define _TINYDIR_HAS_DIRFD +# include +#endif +#if defined _TINYDIR_HAS_FPATHCONF && defined _TINYDIR_HAS_DIRFD &&\ + defined _PC_NAME_MAX +# define _TINYDIR_USE_FPATHCONF +#endif +#if defined __MINGW32__ || !defined _TINYDIR_HAS_READDIR_R ||\ + !(defined _TINYDIR_USE_FPATHCONF || defined NAME_MAX) +# define _TINYDIR_USE_READDIR +#endif + +/* Use readdir by default */ +#else +# define _TINYDIR_USE_READDIR +#endif + +/* MINGW32 has two versions of dirent, ASCII and UNICODE*/ +#ifndef _MSC_VER +#if (defined __MINGW32__) && (defined _UNICODE) +#define _TINYDIR_DIR _WDIR +#define _tinydir_dirent _wdirent +#define _tinydir_opendir _wopendir +#define _tinydir_readdir _wreaddir +#define _tinydir_closedir _wclosedir +#else +#define _TINYDIR_DIR DIR +#define _tinydir_dirent dirent +#define _tinydir_opendir opendir +#define _tinydir_readdir readdir +#define _tinydir_closedir closedir +#endif +#endif + +/* Allow user to use a custom allocator by defining _TINYDIR_MALLOC and _TINYDIR_FREE. */ +#if defined(_TINYDIR_MALLOC) && defined(_TINYDIR_FREE) +#elif !defined(_TINYDIR_MALLOC) && !defined(_TINYDIR_FREE) +#else +#error "Either define both alloc and free or none of them!" +#endif + +#if !defined(_TINYDIR_MALLOC) + #define _TINYDIR_MALLOC(_size) malloc(_size) + #define _TINYDIR_FREE(_ptr) free(_ptr) +#endif /* !defined(_TINYDIR_MALLOC) */ + +typedef struct tinydir_file +{ + _tinydir_char_t path[_TINYDIR_PATH_MAX]; + _tinydir_char_t name[_TINYDIR_FILENAME_MAX]; + _tinydir_char_t *extension; + int is_dir; + int is_reg; + +#ifndef _MSC_VER +#ifdef __MINGW32__ + struct _stat _s; +#else + struct stat _s; +#endif +#endif +} tinydir_file; + +typedef struct tinydir_dir +{ + _tinydir_char_t path[_TINYDIR_PATH_MAX]; + int has_next; + size_t n_files; + + tinydir_file *_files; +#ifdef _MSC_VER + HANDLE _h; + WIN32_FIND_DATA _f; +#else + _TINYDIR_DIR *_d; + struct _tinydir_dirent *_e; +#ifndef _TINYDIR_USE_READDIR + struct _tinydir_dirent *_ep; +#endif +#endif +} tinydir_dir; + + +/* declarations */ + +_TINYDIR_FUNC +int tinydir_open(tinydir_dir *dir, const _tinydir_char_t *path); +_TINYDIR_FUNC +int tinydir_open_sorted(tinydir_dir *dir, const _tinydir_char_t *path); +_TINYDIR_FUNC +void tinydir_close(tinydir_dir *dir); + +_TINYDIR_FUNC +int tinydir_next(tinydir_dir *dir); +_TINYDIR_FUNC +int tinydir_readfile(const tinydir_dir *dir, tinydir_file *file); +_TINYDIR_FUNC +int tinydir_readfile_n(const tinydir_dir *dir, tinydir_file *file, size_t i); +_TINYDIR_FUNC +int tinydir_open_subdir_n(tinydir_dir *dir, size_t i); + +_TINYDIR_FUNC +int tinydir_file_open(tinydir_file *file, const _tinydir_char_t *path); +_TINYDIR_FUNC +void _tinydir_get_ext(tinydir_file *file); +_TINYDIR_FUNC +int _tinydir_file_cmp(const void *a, const void *b); +#ifndef _MSC_VER +#ifndef _TINYDIR_USE_READDIR +_TINYDIR_FUNC +size_t _tinydir_dirent_buf_size(_TINYDIR_DIR *dirp); +#endif +#endif + + +/* definitions*/ + +_TINYDIR_FUNC +int tinydir_open(tinydir_dir *dir, const _tinydir_char_t *path) +{ +#ifndef _MSC_VER +#ifndef _TINYDIR_USE_READDIR + int error; + int size; /* using int size */ +#endif +#else + _tinydir_char_t path_buf[_TINYDIR_PATH_MAX]; +#endif + _tinydir_char_t *pathp; + + if (dir == NULL || path == NULL || _tinydir_strlen(path) == 0) + { + errno = EINVAL; + return -1; + } + if (_tinydir_strlen(path) + _TINYDIR_PATH_EXTRA >= _TINYDIR_PATH_MAX) + { + errno = ENAMETOOLONG; + return -1; + } + + /* initialise dir */ + dir->_files = NULL; +#ifdef _MSC_VER + dir->_h = INVALID_HANDLE_VALUE; +#else + dir->_d = NULL; +#ifndef _TINYDIR_USE_READDIR + dir->_ep = NULL; +#endif +#endif + tinydir_close(dir); + + _tinydir_strcpy(dir->path, path); + /* Remove trailing slashes */ + pathp = &dir->path[_tinydir_strlen(dir->path) - 1]; + while (pathp != dir->path && (*pathp == TINYDIR_STRING('\\') || *pathp == TINYDIR_STRING('/'))) + { + *pathp = TINYDIR_STRING('\0'); + pathp++; + } +#ifdef _MSC_VER + _tinydir_strcpy(path_buf, dir->path); + _tinydir_strcat(path_buf, TINYDIR_STRING("\\*")); +#if (defined WINAPI_FAMILY) && (WINAPI_FAMILY != WINAPI_FAMILY_DESKTOP_APP) + dir->_h = FindFirstFileEx(path_buf, FindExInfoStandard, &dir->_f, FindExSearchNameMatch, NULL, 0); +#else + dir->_h = FindFirstFile(path_buf, &dir->_f); +#endif + if (dir->_h == INVALID_HANDLE_VALUE) + { + errno = ENOENT; +#else + dir->_d = _tinydir_opendir(path); + if (dir->_d == NULL) + { +#endif + goto bail; + } + + /* read first file */ + dir->has_next = 1; +#ifndef _MSC_VER +#ifdef _TINYDIR_USE_READDIR + dir->_e = _tinydir_readdir(dir->_d); +#else + /* allocate dirent buffer for readdir_r */ + size = _tinydir_dirent_buf_size(dir->_d); /* conversion to int */ + if (size == -1) return -1; + dir->_ep = (struct _tinydir_dirent*)_TINYDIR_MALLOC(size); + if (dir->_ep == NULL) return -1; + + error = readdir_r(dir->_d, dir->_ep, &dir->_e); + if (error != 0) return -1; +#endif + if (dir->_e == NULL) + { + dir->has_next = 0; + } +#endif + + return 0; + +bail: + tinydir_close(dir); + return -1; +} + +_TINYDIR_FUNC +int tinydir_open_sorted(tinydir_dir *dir, const _tinydir_char_t *path) +{ + /* Count the number of files first, to pre-allocate the files array */ + size_t n_files = 0; + if (tinydir_open(dir, path) == -1) + { + return -1; + } + while (dir->has_next) + { + n_files++; + if (tinydir_next(dir) == -1) + { + goto bail; + } + } + tinydir_close(dir); + + if (tinydir_open(dir, path) == -1) + { + return -1; + } + + dir->n_files = 0; + dir->_files = (tinydir_file *)_TINYDIR_MALLOC(sizeof *dir->_files * n_files); + if (dir->_files == NULL) + { + goto bail; + } + while (dir->has_next) + { + tinydir_file *p_file; + dir->n_files++; + + p_file = &dir->_files[dir->n_files - 1]; + if (tinydir_readfile(dir, p_file) == -1) + { + goto bail; + } + + if (tinydir_next(dir) == -1) + { + goto bail; + } + + /* Just in case the number of files has changed between the first and + second reads, terminate without writing into unallocated memory */ + if (dir->n_files == n_files) + { + break; + } + } + + qsort(dir->_files, dir->n_files, sizeof(tinydir_file), _tinydir_file_cmp); + + return 0; + +bail: + tinydir_close(dir); + return -1; +} + +_TINYDIR_FUNC +void tinydir_close(tinydir_dir *dir) +{ + if (dir == NULL) + { + return; + } + + memset(dir->path, 0, sizeof(dir->path)); + dir->has_next = 0; + dir->n_files = 0; + _TINYDIR_FREE(dir->_files); + dir->_files = NULL; +#ifdef _MSC_VER + if (dir->_h != INVALID_HANDLE_VALUE) + { + FindClose(dir->_h); + } + dir->_h = INVALID_HANDLE_VALUE; +#else + if (dir->_d) + { + _tinydir_closedir(dir->_d); + } + dir->_d = NULL; + dir->_e = NULL; +#ifndef _TINYDIR_USE_READDIR + _TINYDIR_FREE(dir->_ep); + dir->_ep = NULL; +#endif +#endif +} + +_TINYDIR_FUNC +int tinydir_next(tinydir_dir *dir) +{ + if (dir == NULL) + { + errno = EINVAL; + return -1; + } + if (!dir->has_next) + { + errno = ENOENT; + return -1; + } + +#ifdef _MSC_VER + if (FindNextFile(dir->_h, &dir->_f) == 0) +#else +#ifdef _TINYDIR_USE_READDIR + dir->_e = _tinydir_readdir(dir->_d); +#else + if (dir->_ep == NULL) + { + return -1; + } + if (readdir_r(dir->_d, dir->_ep, &dir->_e) != 0) + { + return -1; + } +#endif + if (dir->_e == NULL) +#endif + { + dir->has_next = 0; +#ifdef _MSC_VER + if (GetLastError() != ERROR_SUCCESS && + GetLastError() != ERROR_NO_MORE_FILES) + { + tinydir_close(dir); + errno = EIO; + return -1; + } +#endif + } + + return 0; +} + +_TINYDIR_FUNC +int tinydir_readfile(const tinydir_dir *dir, tinydir_file *file) +{ + if (dir == NULL || file == NULL) + { + errno = EINVAL; + return -1; + } +#ifdef _MSC_VER + if (dir->_h == INVALID_HANDLE_VALUE) +#else + if (dir->_e == NULL) +#endif + { + errno = ENOENT; + return -1; + } + if (_tinydir_strlen(dir->path) + + _tinydir_strlen( +#ifdef _MSC_VER + dir->_f.cFileName +#else + dir->_e->d_name +#endif + ) + 1 + _TINYDIR_PATH_EXTRA >= + _TINYDIR_PATH_MAX) + { + /* the path for the file will be too long */ + errno = ENAMETOOLONG; + return -1; + } + if (_tinydir_strlen( +#ifdef _MSC_VER + dir->_f.cFileName +#else + dir->_e->d_name +#endif + ) >= _TINYDIR_FILENAME_MAX) + { + errno = ENAMETOOLONG; + return -1; + } + + _tinydir_strcpy(file->path, dir->path); + _tinydir_strcat(file->path, TINYDIR_STRING("/")); + _tinydir_strcpy(file->name, +#ifdef _MSC_VER + dir->_f.cFileName +#else + dir->_e->d_name +#endif + ); + _tinydir_strcat(file->path, file->name); +#ifndef _MSC_VER +#ifdef __MINGW32__ + if (_tstat( +#else + if (stat( +#endif + file->path, &file->_s) == -1) + { + return -1; + } +#endif + _tinydir_get_ext(file); + + file->is_dir = +#ifdef _MSC_VER + !!(dir->_f.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY); +#else + S_ISDIR(file->_s.st_mode); +#endif + file->is_reg = +#ifdef _MSC_VER + !!(dir->_f.dwFileAttributes & FILE_ATTRIBUTE_NORMAL) || + ( + !(dir->_f.dwFileAttributes & FILE_ATTRIBUTE_DEVICE) && + !(dir->_f.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY) && + !(dir->_f.dwFileAttributes & FILE_ATTRIBUTE_ENCRYPTED) && +#ifdef FILE_ATTRIBUTE_INTEGRITY_STREAM + !(dir->_f.dwFileAttributes & FILE_ATTRIBUTE_INTEGRITY_STREAM) && +#endif +#ifdef FILE_ATTRIBUTE_NO_SCRUB_DATA + !(dir->_f.dwFileAttributes & FILE_ATTRIBUTE_NO_SCRUB_DATA) && +#endif + !(dir->_f.dwFileAttributes & FILE_ATTRIBUTE_OFFLINE) && + !(dir->_f.dwFileAttributes & FILE_ATTRIBUTE_TEMPORARY)); +#else + S_ISREG(file->_s.st_mode); +#endif + + return 0; +} + +_TINYDIR_FUNC +int tinydir_readfile_n(const tinydir_dir *dir, tinydir_file *file, size_t i) +{ + if (dir == NULL || file == NULL) + { + errno = EINVAL; + return -1; + } + if (i >= dir->n_files) + { + errno = ENOENT; + return -1; + } + + memcpy(file, &dir->_files[i], sizeof(tinydir_file)); + _tinydir_get_ext(file); + + return 0; +} + +_TINYDIR_FUNC +int tinydir_open_subdir_n(tinydir_dir *dir, size_t i) +{ + _tinydir_char_t path[_TINYDIR_PATH_MAX]; + if (dir == NULL) + { + errno = EINVAL; + return -1; + } + if (i >= dir->n_files || !dir->_files[i].is_dir) + { + errno = ENOENT; + return -1; + } + + _tinydir_strcpy(path, dir->_files[i].path); + tinydir_close(dir); + if (tinydir_open_sorted(dir, path) == -1) + { + return -1; + } + + return 0; +} + +/* Open a single file given its path */ +_TINYDIR_FUNC +int tinydir_file_open(tinydir_file *file, const _tinydir_char_t *path) +{ + tinydir_dir dir; + int result = 0; + int found = 0; + _tinydir_char_t dir_name_buf[_TINYDIR_PATH_MAX]; + _tinydir_char_t file_name_buf[_TINYDIR_FILENAME_MAX]; + _tinydir_char_t *dir_name; + _tinydir_char_t *base_name; +#if (defined _MSC_VER || defined __MINGW32__) + _tinydir_char_t drive_buf[_TINYDIR_PATH_MAX]; + _tinydir_char_t ext_buf[_TINYDIR_FILENAME_MAX]; +#endif + + if (file == NULL || path == NULL || _tinydir_strlen(path) == 0) + { + errno = EINVAL; + return -1; + } + if (_tinydir_strlen(path) + _TINYDIR_PATH_EXTRA >= _TINYDIR_PATH_MAX) + { + errno = ENAMETOOLONG; + return -1; + } + + /* Get the parent path */ +#if (defined _MSC_VER || defined __MINGW32__) +#if ((defined _MSC_VER) && (_MSC_VER >= 1400)) + _tsplitpath_s( + path, + drive_buf, _TINYDIR_DRIVE_MAX, + dir_name_buf, _TINYDIR_FILENAME_MAX, + file_name_buf, _TINYDIR_FILENAME_MAX, + ext_buf, _TINYDIR_FILENAME_MAX); +#else + _tsplitpath( + path, + drive_buf, + dir_name_buf, + file_name_buf, + ext_buf); +#endif + +/* _splitpath_s not work fine with only filename and widechar support */ +#ifdef _UNICODE + if (drive_buf[0] == L'\xFEFE') + drive_buf[0] = '\0'; + if (dir_name_buf[0] == L'\xFEFE') + dir_name_buf[0] = '\0'; +#endif + + if (errno) + { + errno = EINVAL; + return -1; + } + /* Emulate the behavior of dirname by returning "." for dir name if it's + empty */ + if (drive_buf[0] == '\0' && dir_name_buf[0] == '\0') + { + _tinydir_strcpy(dir_name_buf, TINYDIR_STRING(".")); + } + /* Concatenate the drive letter and dir name to form full dir name */ + _tinydir_strcat(drive_buf, dir_name_buf); + dir_name = drive_buf; + /* Concatenate the file name and extension to form base name */ + _tinydir_strcat(file_name_buf, ext_buf); + base_name = file_name_buf; +#else + _tinydir_strcpy(dir_name_buf, path); + dir_name = dirname(dir_name_buf); + _tinydir_strcpy(file_name_buf, path); + base_name =basename(file_name_buf); +#endif + + /* Open the parent directory */ + if (tinydir_open(&dir, dir_name) == -1) + { + return -1; + } + + /* Read through the parent directory and look for the file */ + while (dir.has_next) + { + if (tinydir_readfile(&dir, file) == -1) + { + result = -1; + goto bail; + } + if (_tinydir_strcmp(file->name, base_name) == 0) + { + /* File found */ + found = 1; + break; + } + tinydir_next(&dir); + } + if (!found) + { + result = -1; + errno = ENOENT; + } + +bail: + tinydir_close(&dir); + return result; +} + +_TINYDIR_FUNC +void _tinydir_get_ext(tinydir_file *file) +{ + _tinydir_char_t *period = _tinydir_strrchr(file->name, TINYDIR_STRING('.')); + if (period == NULL) + { + file->extension = &(file->name[_tinydir_strlen(file->name)]); + } + else + { + file->extension = period + 1; + } +} + +_TINYDIR_FUNC +int _tinydir_file_cmp(const void *a, const void *b) +{ + const tinydir_file *fa = (const tinydir_file *)a; + const tinydir_file *fb = (const tinydir_file *)b; + if (fa->is_dir != fb->is_dir) + { + return -(fa->is_dir - fb->is_dir); + } + return _tinydir_strncmp(fa->name, fb->name, _TINYDIR_FILENAME_MAX); +} + +#ifndef _MSC_VER +#ifndef _TINYDIR_USE_READDIR +/* +The following authored by Ben Hutchings +from https://womble.decadent.org.uk/readdir_r-advisory.html +*/ +/* Calculate the required buffer size (in bytes) for directory * +* entries read from the given directory handle. Return -1 if this * +* this cannot be done. * +* * +* This code does not trust values of NAME_MAX that are less than * +* 255, since some systems (including at least HP-UX) incorrectly * +* define it to be a smaller value. */ +_TINYDIR_FUNC +size_t _tinydir_dirent_buf_size(_TINYDIR_DIR *dirp) +{ + long name_max; + size_t name_end; + /* parameter may be unused */ + (void)dirp; + +#if defined _TINYDIR_USE_FPATHCONF + name_max = fpathconf(dirfd(dirp), _PC_NAME_MAX); + if (name_max == -1) +#if defined(NAME_MAX) + name_max = (NAME_MAX > 255) ? NAME_MAX : 255; +#else + return (size_t)(-1); +#endif +#elif defined(NAME_MAX) + name_max = (NAME_MAX > 255) ? NAME_MAX : 255; +#else +#error "buffer size for readdir_r cannot be determined" +#endif + name_end = (size_t)offsetof(struct _tinydir_dirent, d_name) + name_max + 1; + return (name_end > sizeof(struct _tinydir_dirent) ? + name_end : sizeof(struct _tinydir_dirent)); +} +#endif +#endif + +#ifdef __cplusplus +} +#endif + +# if defined (_MSC_VER) +# pragma warning(pop) +# endif + +#endif -- cgit v0.12 From afc472854643657015d03437e75c87f10bc2d0eb Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 14 Apr 2022 14:23:15 +0000 Subject: Update to latest version of tinydir --- compat/zlib/contrib/minizip/tinydir.h | 120 ++++++++++++++++++++-------------- 1 file changed, 71 insertions(+), 49 deletions(-) diff --git a/compat/zlib/contrib/minizip/tinydir.h b/compat/zlib/contrib/minizip/tinydir.h index eb34399..ba20c3e 100644 --- a/compat/zlib/contrib/minizip/tinydir.h +++ b/compat/zlib/contrib/minizip/tinydir.h @@ -1,5 +1,5 @@ /* -Copyright (c) 2013-2017, tinydir authors: +Copyright (c) 2013-2021, tinydir authors: - Cong Xu - Lautis Sun - Baudouin Feildel @@ -45,7 +45,9 @@ extern "C" { #include #include #ifdef _MSC_VER -# define WIN32_LEAN_AND_MEAN +# ifndef WIN32_LEAN_AND_MEAN +# define WIN32_LEAN_AND_MEAN +# endif # include # include # pragma warning(push) @@ -89,12 +91,16 @@ extern "C" { # define _TINYDIR_PATH_MAX MAX_PATH #elif defined __linux__ # include -# define _TINYDIR_PATH_MAX PATH_MAX +# ifdef PATH_MAX +# define _TINYDIR_PATH_MAX PATH_MAX +# endif #elif defined(__unix__) || (defined(__APPLE__) && defined(__MACH__)) # include # if defined(BSD) # include -# define _TINYDIR_PATH_MAX PATH_MAX +# ifdef PATH_MAX +# define _TINYDIR_PATH_MAX PATH_MAX +# endif # endif #endif @@ -119,8 +125,13 @@ extern "C" { # define _TINYDIR_FUNC static __inline #elif !defined __STDC_VERSION__ || __STDC_VERSION__ < 199901L # define _TINYDIR_FUNC static __inline__ -#else +#elif defined(__cplusplus) # define _TINYDIR_FUNC static inline +#elif defined(__GNUC__) +/* Suppress unused function warning */ +# define _TINYDIR_FUNC __attribute__((unused)) static +#else +# define _TINYDIR_FUNC static #endif /* readdir_r usage; define TINYDIR_USE_READDIR_R to use it (if supported) */ @@ -365,7 +376,7 @@ int tinydir_open_sorted(tinydir_dir *dir, const _tinydir_char_t *path) } tinydir_close(dir); - if (tinydir_open(dir, path) == -1) + if (n_files == 0 || tinydir_open(dir, path) == -1) { return -1; } @@ -492,6 +503,7 @@ int tinydir_next(tinydir_dir *dir) _TINYDIR_FUNC int tinydir_readfile(const tinydir_dir *dir, tinydir_file *file) { + const _tinydir_char_t *filename; if (dir == NULL || file == NULL) { errno = EINVAL; @@ -506,45 +518,40 @@ int tinydir_readfile(const tinydir_dir *dir, tinydir_file *file) errno = ENOENT; return -1; } - if (_tinydir_strlen(dir->path) + - _tinydir_strlen( + filename = #ifdef _MSC_VER - dir->_f.cFileName + dir->_f.cFileName; #else - dir->_e->d_name + dir->_e->d_name; #endif - ) + 1 + _TINYDIR_PATH_EXTRA >= + if (_tinydir_strlen(dir->path) + + _tinydir_strlen(filename) + 1 + _TINYDIR_PATH_EXTRA >= _TINYDIR_PATH_MAX) { /* the path for the file will be too long */ errno = ENAMETOOLONG; return -1; } - if (_tinydir_strlen( -#ifdef _MSC_VER - dir->_f.cFileName -#else - dir->_e->d_name -#endif - ) >= _TINYDIR_FILENAME_MAX) + if (_tinydir_strlen(filename) >= _TINYDIR_FILENAME_MAX) { errno = ENAMETOOLONG; return -1; } _tinydir_strcpy(file->path, dir->path); - _tinydir_strcat(file->path, TINYDIR_STRING("/")); - _tinydir_strcpy(file->name, -#ifdef _MSC_VER - dir->_f.cFileName -#else - dir->_e->d_name -#endif - ); - _tinydir_strcat(file->path, file->name); + if (_tinydir_strcmp(dir->path, TINYDIR_STRING("/")) != 0) + _tinydir_strcat(file->path, TINYDIR_STRING("/")); + _tinydir_strcpy(file->name, filename); + _tinydir_strcat(file->path, filename); #ifndef _MSC_VER #ifdef __MINGW32__ if (_tstat( +#elif (defined _BSD_SOURCE) || (defined _DEFAULT_SOURCE) \ + || ((defined _XOPEN_SOURCE) && (_XOPEN_SOURCE >= 500)) \ + || ((defined _POSIX_C_SOURCE) && (_POSIX_C_SOURCE >= 200112L)) \ + || ((defined __APPLE__) && (defined __MACH__)) \ + || (defined BSD) + if (lstat( #else if (stat( #endif @@ -658,34 +665,34 @@ int tinydir_file_open(tinydir_file *file, const _tinydir_char_t *path) /* Get the parent path */ #if (defined _MSC_VER || defined __MINGW32__) #if ((defined _MSC_VER) && (_MSC_VER >= 1400)) - _tsplitpath_s( - path, - drive_buf, _TINYDIR_DRIVE_MAX, - dir_name_buf, _TINYDIR_FILENAME_MAX, - file_name_buf, _TINYDIR_FILENAME_MAX, - ext_buf, _TINYDIR_FILENAME_MAX); + errno = _tsplitpath_s( + path, + drive_buf, _TINYDIR_DRIVE_MAX, + dir_name_buf, _TINYDIR_FILENAME_MAX, + file_name_buf, _TINYDIR_FILENAME_MAX, + ext_buf, _TINYDIR_FILENAME_MAX); #else - _tsplitpath( - path, - drive_buf, - dir_name_buf, - file_name_buf, - ext_buf); -#endif - -/* _splitpath_s not work fine with only filename and widechar support */ -#ifdef _UNICODE - if (drive_buf[0] == L'\xFEFE') - drive_buf[0] = '\0'; - if (dir_name_buf[0] == L'\xFEFE') - dir_name_buf[0] = '\0'; + _tsplitpath( + path, + drive_buf, + dir_name_buf, + file_name_buf, + ext_buf); #endif if (errno) { - errno = EINVAL; return -1; } + +/* _splitpath_s not work fine with only filename and widechar support */ +#ifdef _UNICODE + if (drive_buf[0] == L'\xFEFE') + drive_buf[0] = '\0'; + if (dir_name_buf[0] == L'\xFEFE') + dir_name_buf[0] = '\0'; +#endif + /* Emulate the behavior of dirname by returning "." for dir name if it's empty */ if (drive_buf[0] == '\0' && dir_name_buf[0] == '\0') @@ -702,9 +709,24 @@ int tinydir_file_open(tinydir_file *file, const _tinydir_char_t *path) _tinydir_strcpy(dir_name_buf, path); dir_name = dirname(dir_name_buf); _tinydir_strcpy(file_name_buf, path); - base_name =basename(file_name_buf); + base_name = basename(file_name_buf); #endif + /* Special case: if the path is a root dir, open the parent dir as the file */ +#if (defined _MSC_VER || defined __MINGW32__) + if (_tinydir_strlen(base_name) == 0) +#else + if ((_tinydir_strcmp(base_name, TINYDIR_STRING("/"))) == 0) +#endif + { + memset(file, 0, sizeof * file); + file->is_dir = 1; + file->is_reg = 0; + _tinydir_strcpy(file->path, dir_name); + file->extension = file->path + _tinydir_strlen(file->path); + return 0; + } + /* Open the parent directory */ if (tinydir_open(&dir, dir_name) == -1) { -- cgit v0.12 From dc2006b9581892b70152a395ee9f799055a6eced Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 14 Apr 2022 20:45:52 +0000 Subject: Fix [da733cf8a6]: indexObj-6.7 fails --- tests/indexObj.test | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/indexObj.test b/tests/indexObj.test index c327274..f10bd2a 100644 --- a/tests/indexObj.test +++ b/tests/indexObj.test @@ -142,8 +142,8 @@ test indexObj-6.6 {Tcl_GetIndexFromObjStruct with NULL input} -constraints testi } -returnCodes error -result {ambiguous dummy "": must be a, c, or ee} test indexObj-6.7 {Tcl_GetIndexFromObjStruct} testindexobj { set x "" - testgetindexfromobjstruct $x -1 4 -} "wrong # args: should be \"testgetindexfromobjstruct {} -1 4\"" + testgetindexfromobjstruct $x -1 32 +} "wrong # args: should be \"testgetindexfromobjstruct {} -1 32\"" test indexObj-7.1 {Tcl_ParseArgsObjv} testparseargs { testparseargs -- cgit v0.12