From 45d0977a5ca8ae0ead48b66feeb51c65d1ce45b4 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 23 Oct 2017 17:06:57 +0000 Subject: Implementation branch for TIP 345: Kill the "identity" encoding. This checkin, completely does that. Bad news is it causes huge failures. We're still making a lot of use of this encoding, and cannot complete this TIP until the branch is repaired. --- generic/tclEncoding.c | 77 --------------------------------------------------- 1 file changed, 77 deletions(-) diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index e328340..37d5fb6 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -195,11 +195,6 @@ static unsigned short emptyPage[256]; * Functions used only in this module. */ -static int BinaryProc(ClientData clientData, - const char *src, int srcLen, int flags, - Tcl_EncodingState *statePtr, char *dst, int dstLen, - int *srcReadPtr, int *dstWrotePtr, - int *dstCharsPtr); static void DupEncodingIntRep(Tcl_Obj *srcPtr, Tcl_Obj *dupPtr); static void EscapeFreeProc(ClientData clientData); static int EscapeFromUtfProc(ClientData clientData, @@ -563,14 +558,6 @@ TclInitEncodingSubsystem(void) * formed UTF-8 into a properly formed stream. */ - type.encodingName = "identity"; - type.toUtfProc = BinaryProc; - type.fromUtfProc = BinaryProc; - type.freeProc = NULL; - type.nullSize = 1; - type.clientData = NULL; - tclIdentityEncoding = Tcl_CreateEncoding(&type); - type.encodingName = "utf-8"; type.toUtfProc = UtfExtToUtfIntProc; type.fromUtfProc = UtfIntToUtfExtProc; @@ -2083,70 +2070,6 @@ LoadEscapeEncoding( /* *------------------------------------------------------------------------- * - * BinaryProc -- - * - * The default conversion when no other conversion is specified. No - * translation is done; source bytes are copied directly to destination - * bytes. - * - * Results: - * Returns TCL_OK if conversion was successful. - * - * Side effects: - * None. - * - *------------------------------------------------------------------------- - */ - -static int -BinaryProc( - ClientData clientData, /* Not used. */ - const char *src, /* Source string (unknown encoding). */ - int srcLen, /* Source string length in bytes. */ - int flags, /* Conversion control flags. */ - Tcl_EncodingState *statePtr,/* Place for conversion routine to store state - * information used during a piecewise - * conversion. Contents of statePtr are - * initialized and/or reset by conversion - * routine under control of flags argument. */ - 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. */ - 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. */ -{ - int result; - - result = TCL_OK; - dstLen -= TCL_UTF_MAX - 1; - if (dstLen < 0) { - dstLen = 0; - } - if ((flags & TCL_ENCODING_CHAR_LIMIT) && srcLen > *dstCharsPtr) { - srcLen = *dstCharsPtr; - } - if (srcLen > dstLen) { - srcLen = dstLen; - result = TCL_CONVERT_NOSPACE; - } - - *srcReadPtr = srcLen; - *dstWrotePtr = srcLen; - *dstCharsPtr = srcLen; - memcpy(dst, src, (size_t) srcLen); - return result; -} - -/* - *------------------------------------------------------------------------- - * * UtfExtToUtfIntProc -- * * Convert from UTF-8 to UTF-8. While converting null-bytes from the -- cgit v0.12 From 319b71965b6c3a38ef712ac4e6b58fa7dae7e6f4 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 23 Oct 2017 17:58:07 +0000 Subject: backout initial commit; need more care. Binary writes internally make use of this encoding. Need to hide it instead of destroy it. --- generic/tclEncoding.c | 77 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 77 insertions(+) diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 37d5fb6..e328340 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -195,6 +195,11 @@ static unsigned short emptyPage[256]; * Functions used only in this module. */ +static int BinaryProc(ClientData clientData, + const char *src, int srcLen, int flags, + Tcl_EncodingState *statePtr, char *dst, int dstLen, + int *srcReadPtr, int *dstWrotePtr, + int *dstCharsPtr); static void DupEncodingIntRep(Tcl_Obj *srcPtr, Tcl_Obj *dupPtr); static void EscapeFreeProc(ClientData clientData); static int EscapeFromUtfProc(ClientData clientData, @@ -558,6 +563,14 @@ TclInitEncodingSubsystem(void) * formed UTF-8 into a properly formed stream. */ + type.encodingName = "identity"; + type.toUtfProc = BinaryProc; + type.fromUtfProc = BinaryProc; + type.freeProc = NULL; + type.nullSize = 1; + type.clientData = NULL; + tclIdentityEncoding = Tcl_CreateEncoding(&type); + type.encodingName = "utf-8"; type.toUtfProc = UtfExtToUtfIntProc; type.fromUtfProc = UtfIntToUtfExtProc; @@ -2070,6 +2083,70 @@ LoadEscapeEncoding( /* *------------------------------------------------------------------------- * + * BinaryProc -- + * + * The default conversion when no other conversion is specified. No + * translation is done; source bytes are copied directly to destination + * bytes. + * + * Results: + * Returns TCL_OK if conversion was successful. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static int +BinaryProc( + ClientData clientData, /* Not used. */ + const char *src, /* Source string (unknown encoding). */ + int srcLen, /* Source string length in bytes. */ + int flags, /* Conversion control flags. */ + Tcl_EncodingState *statePtr,/* Place for conversion routine to store state + * information used during a piecewise + * conversion. Contents of statePtr are + * initialized and/or reset by conversion + * routine under control of flags argument. */ + 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. */ + 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. */ +{ + int result; + + result = TCL_OK; + dstLen -= TCL_UTF_MAX - 1; + if (dstLen < 0) { + dstLen = 0; + } + if ((flags & TCL_ENCODING_CHAR_LIMIT) && srcLen > *dstCharsPtr) { + srcLen = *dstCharsPtr; + } + if (srcLen > dstLen) { + srcLen = dstLen; + result = TCL_CONVERT_NOSPACE; + } + + *srcReadPtr = srcLen; + *dstWrotePtr = srcLen; + *dstCharsPtr = srcLen; + memcpy(dst, src, (size_t) srcLen); + return result; +} + +/* + *------------------------------------------------------------------------- + * * UtfExtToUtfIntProc -- * * Convert from UTF-8 to UTF-8. While converting null-bytes from the -- cgit v0.12 From 9306fa604ca63f8626f859c1f6cb5154a659e504 Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 24 Oct 2017 14:11:16 +0000 Subject: Cherrypick: [fc1409fc91] Method cloning needs to be careful with body representations. --- generic/tclOOMethod.c | 1 + tests/oo.test | 11 +++++++++++ 2 files changed, 12 insertions(+) diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c index 99a8bfc..8da0fb3 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.c @@ -1314,6 +1314,7 @@ CloneProcedureMethod( */ bodyObj = Tcl_DuplicateObj(pmPtr->procPtr->bodyPtr); + Tcl_GetString(bodyObj); TclFreeIntRep(bodyObj); /* diff --git a/tests/oo.test b/tests/oo.test index 1ac6f37..61a5e01 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -2048,6 +2048,17 @@ test oo-15.14 {OO: object cloning with target NS} -setup { } -cleanup { Cls destroy } -result {{} ::dupens::test-15.14} +test oo-15.15 {method cloning must ensure that there is a string representation of bodies} -setup { + oo::class create cls +} -body { + cls create foo + oo::objdefine foo { + method m1 {} [string map {a b} {return hello}] + } + [oo::copy foo] m1 +} -cleanup { + cls destroy +} -result hello test oo-16.1 {OO: object introspection} -body { info object -- cgit v0.12 From 1552384787fef03116569d8281bc0a69a02d6e3f Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 24 Oct 2017 23:16:23 +0000 Subject: Extend Tcl_CreateEncoding() to be able to create an encoding without registering it when it has no name. Then use this to create "identity" encoding without naming it "identity". Then no one can look it up by that name. --- generic/tclEncoding.c | 38 +++++++++++++++++++++----------------- 1 file changed, 21 insertions(+), 17 deletions(-) diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index e328340..f43c0e1 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -563,7 +563,7 @@ TclInitEncodingSubsystem(void) * formed UTF-8 into a properly formed stream. */ - type.encodingName = "identity"; + type.encodingName = NULL; type.toUtfProc = BinaryProc; type.fromUtfProc = BinaryProc; type.freeProc = NULL; @@ -851,7 +851,9 @@ FreeEncoding( if (encodingPtr->hPtr != NULL) { Tcl_DeleteHashEntry(encodingPtr->hPtr); } - ckfree(encodingPtr->name); + if (encodingPtr->name) { + ckfree(encodingPtr->name); + } ckfree(encodingPtr); } } @@ -1040,9 +1042,24 @@ Tcl_CreateEncoding( const Tcl_EncodingType *typePtr) /* The encoding type. */ { + Encoding *encodingPtr = ckalloc(sizeof(Encoding)); + encodingPtr->name = NULL; + encodingPtr->toUtfProc = typePtr->toUtfProc; + encodingPtr->fromUtfProc = typePtr->fromUtfProc; + encodingPtr->freeProc = typePtr->freeProc; + encodingPtr->nullSize = typePtr->nullSize; + encodingPtr->clientData = typePtr->clientData; + if (typePtr->nullSize == 1) { + encodingPtr->lengthProc = (LengthProc *) strlen; + } else { + encodingPtr->lengthProc = (LengthProc *) unilen; + } + encodingPtr->refCount = 1; + encodingPtr->hPtr = NULL; + + if (typePtr->encodingName) { Tcl_HashEntry *hPtr; int isNew; - Encoding *encodingPtr; char *name; Tcl_MutexLock(&encodingMutex); @@ -1058,25 +1075,12 @@ Tcl_CreateEncoding( } name = ckalloc(strlen(typePtr->encodingName) + 1); - - encodingPtr = ckalloc(sizeof(Encoding)); encodingPtr->name = strcpy(name, typePtr->encodingName); - encodingPtr->toUtfProc = typePtr->toUtfProc; - encodingPtr->fromUtfProc = typePtr->fromUtfProc; - encodingPtr->freeProc = typePtr->freeProc; - encodingPtr->nullSize = typePtr->nullSize; - encodingPtr->clientData = typePtr->clientData; - if (typePtr->nullSize == 1) { - encodingPtr->lengthProc = (LengthProc *) strlen; - } else { - encodingPtr->lengthProc = (LengthProc *) unilen; - } - encodingPtr->refCount = 1; encodingPtr->hPtr = hPtr; Tcl_SetHashValue(hPtr, encodingPtr); Tcl_MutexUnlock(&encodingMutex); - + } return (Tcl_Encoding) encodingPtr; } -- cgit v0.12 From 40d9b81e23c10ebc3abfe4ac12af411d01318fb9 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 24 Oct 2017 23:30:35 +0000 Subject: Stop using "identity" as an encoding to test basic functionng of the [encoding] command. "iso8859-1" is another one always available. --- tests/cmdAH.test | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/tests/cmdAH.test b/tests/cmdAH.test index 3c58c1b..03f4d66 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -188,7 +188,7 @@ test cmdAH-4.5 {Tcl_EncodingObjCmd} -setup { test cmdAH-4.6 {Tcl_EncodingObjCmd} -setup { set system [encoding system] } -body { - encoding system identity + encoding system iso8859-1 encoding convertto jis0208 \u4e4e } -cleanup { encoding system $system @@ -210,7 +210,7 @@ test cmdAH-4.9 {Tcl_EncodingObjCmd} -setup { test cmdAH-4.10 {Tcl_EncodingObjCmd} -setup { set system [encoding system] } -body { - encoding system identity + encoding system iso8859-1 encoding convertfrom jis0208 8C } -cleanup { encoding system $system @@ -224,11 +224,11 @@ test cmdAH-4.12 {Tcl_EncodingObjCmd} -returnCodes error -body { test cmdAH-4.13 {Tcl_EncodingObjCmd} -setup { set system [encoding system] } -body { - encoding system identity + encoding system iso8859-1 encoding system } -cleanup { encoding system $system -} -result identity +} -result iso8859-1 test cmdAH-5.1 {Tcl_FileObjCmd} -returnCodes error -body { file -- cgit v0.12 From eb2cfa3e6f2fc11362ae54a2004ade43a57c86de Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 25 Oct 2017 02:23:12 +0000 Subject: Repair Tcl_CreateEncoding(); Modernize [testencoding]; Update most tests toying with identity encoding. --- generic/tclEncoding.c | 4 ++-- generic/tclTest.c | 9 ++++++--- tests/encoding.test | 12 ++++-------- 3 files changed, 12 insertions(+), 13 deletions(-) diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index f43c0e1..1f48a1c 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -1070,8 +1070,8 @@ Tcl_CreateEncoding( * reference goes away. */ - encodingPtr = Tcl_GetHashValue(hPtr); - encodingPtr->hPtr = NULL; + Encoding *replaceMe = Tcl_GetHashValue(hPtr); + replaceMe->hPtr = NULL; } name = ckalloc(strlen(typePtr->encodingName) + 1); diff --git a/generic/tclTest.c b/generic/tclTest.c index ebd90ae..c455d42 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -1985,9 +1985,12 @@ TestencodingObjCmd( if (objc != 3) { return TCL_ERROR; } - encoding = Tcl_GetEncoding(NULL, Tcl_GetString(objv[2])); - Tcl_FreeEncoding(encoding); - Tcl_FreeEncoding(encoding); + if (TCL_OK != Tcl_GetEncodingFromObj(interp, objv[2], &encoding)) { + return TCL_ERROR; + } + Tcl_FreeEncoding(encoding); /* Free returned reference */ + Tcl_FreeEncoding(encoding); /* Free to match CREATE */ + TclFreeIntRep(objv[2]); /* Free the cached ref */ break; } return TCL_OK; diff --git a/tests/encoding.test b/tests/encoding.test index be1f4d5..0ee08b6 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -75,11 +75,11 @@ test encoding-2.2 {Tcl_FreeEncoding: refcount != 0} -setup { encoding system shiftjis ;# incr ref count encoding dirs [list [pwd]] set x [encoding convertto shiftjis \u4e4e] ;# old one found - encoding system identity + encoding system iso8859-1 llength shiftjis ;# Shimmer away any cache of Tcl_Encoding lappend x [catch {encoding convertto shiftjis \u4e4e} msg] $msg } -cleanup { - encoding system identity + encoding system iso8859-1 encoding dirs $path encoding system $system } -result "\u008c\u00c1 1 {unknown encoding \"shiftjis\"}" @@ -136,7 +136,7 @@ test encoding-5.1 {Tcl_SetSystemEncoding} -setup { encoding system jis0208 encoding convertto \u4e4e } -cleanup { - encoding system identity + encoding system iso8859-1 encoding system $old } -result {8C} test encoding-5.2 {Tcl_SetSystemEncoding: test ref count} { @@ -259,7 +259,7 @@ test encoding-11.5.1 {LoadEncodingFile: escape file} { test encoding-11.6 {LoadEncodingFile: invalid file} -constraints {testencoding} -setup { set system [encoding system] set path [encoding dirs] - encoding system identity + encoding system iso8859-1 } -body { cd [temporaryDirectory] encoding dirs [file join tmp encoding] @@ -308,10 +308,6 @@ test encoding-13.1 {LoadEscapeTable} { viewable [set x [encoding convertto iso2022 ab\u4e4e\u68d9g]] } [viewable "ab\x1b\$B8C\x1b\$\(DD%\x1b(Bg"] -test encoding-14.1 {BinaryProc} { - encoding convertto identity \x12\x34\x56\xff\x69 -} "\x12\x34\x56\xc3\xbf\x69" - test encoding-15.1 {UtfToUtfProc} { encoding convertto utf-8 \xa3 } "\xc2\xa3" -- cgit v0.12 From 30c6827ee17807b25e79676f049f66877bf3d4ff Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 25 Oct 2017 02:54:24 +0000 Subject: Convert remaining tests to use [testbytestring]. encoding-15.3 still needs replacement for [encoding convertto identity]. That is, some testing command to expose objPtr->bytes. --- tests/encoding.test | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/tests/encoding.test b/tests/encoding.test index 0ee08b6..11f08ef 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -34,6 +34,7 @@ proc runtests {} { # Some tests require the testencoding command testConstraint testencoding [llength [info commands testencoding]] +testConstraint testbytestring [llength [info commands testbytestring]] testConstraint fullutf [expr {[format %c 0x010000] != "\ufffd"}] testConstraint exec [llength [info commands exec]] testConstraint testgetencpath [llength [info commands testgetencpath]] @@ -311,15 +312,14 @@ test encoding-13.1 {LoadEscapeTable} { test encoding-15.1 {UtfToUtfProc} { encoding convertto utf-8 \xa3 } "\xc2\xa3" -test encoding-15.2 {UtfToUtfProc null character output} { +test encoding-15.2 {UtfToUtfProc null character output} testbytestring { set x \u0000 - set y [encoding convertto utf-8 \u0000] - set y [encoding convertfrom identity $y] + set y [testbytestring [encoding convertto utf-8 \u0000]] binary scan $y H* z list [string bytelength $x] [string bytelength $y] $z } {2 1 00} -test encoding-15.3 {UtfToUtfProc null character input} { - set x [encoding convertfrom identity \x00] +test encoding-15.3 {UtfToUtfProc null character input} testbytestring { + set x [testbytestring \x00] set y [encoding convertfrom utf-8 $x] binary scan [encoding convertto identity $y] H* z list [string bytelength $x] [string bytelength $y] $z -- cgit v0.12 From 053a74e0facac37a830c2c317c90d11bc13e5264 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 26 Oct 2017 02:08:27 +0000 Subject: Create new testing command [teststringbytes] to probe the things that otherwise require [encoding convertto identity]. adapt encoding-15.3 to use. --- generic/tclTest.c | 38 ++++++++++++++++++++++++++++++++++++++ tests/encoding.test | 20 +++++++++----------- 2 files changed, 47 insertions(+), 11 deletions(-) diff --git a/generic/tclTest.c b/generic/tclTest.c index c455d42..834cd79 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -227,6 +227,9 @@ static int TestasyncCmd(ClientData dummy, static int TestbytestringObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); +static int TeststringbytesObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); static int TestcmdinfoCmd(ClientData dummy, Tcl_Interp *interp, int argc, const char **argv); static int TestcmdtokenCmd(ClientData dummy, @@ -581,6 +584,7 @@ Tcltest_Init( Tcl_CreateCommand(interp, "noop", NoopCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "noop", NoopObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testbytestring", TestbytestringObjCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "teststringbytes", TeststringbytesObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testwrongnumargs", TestWrongNumArgsObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testfilesystem", TestFilesystemObjCmd, @@ -5049,6 +5053,40 @@ NoopObjCmd( /* *---------------------------------------------------------------------- * + * TeststringbytesObjCmd -- + * Returns bytearray value of the bytes in argument string rep + * + * Results: + * Returns the TCL_OK result code. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TeststringbytesObjCmd( + ClientData unused, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* The argument objects. */ +{ + int n; + const unsigned char *p; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "value"); + return TCL_ERROR; + } + p = (const unsigned char *)Tcl_GetStringFromObj(objv[1], &n); + Tcl_SetObjResult(interp, Tcl_NewByteArrayObj(p, n)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * TestbytestringObjCmd -- * * This object-based procedure constructs a string which can diff --git a/tests/encoding.test b/tests/encoding.test index 11f08ef..e447c20 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -35,6 +35,7 @@ proc runtests {} { # Some tests require the testencoding command testConstraint testencoding [llength [info commands testencoding]] testConstraint testbytestring [llength [info commands testbytestring]] +testConstraint teststringbytes [llength [info commands teststringbytes]] testConstraint fullutf [expr {[format %c 0x010000] != "\ufffd"}] testConstraint exec [llength [info commands exec]] testConstraint testgetencpath [llength [info commands testgetencpath]] @@ -313,17 +314,14 @@ test encoding-15.1 {UtfToUtfProc} { encoding convertto utf-8 \xa3 } "\xc2\xa3" test encoding-15.2 {UtfToUtfProc null character output} testbytestring { - set x \u0000 - set y [testbytestring [encoding convertto utf-8 \u0000]] - binary scan $y H* z - list [string bytelength $x] [string bytelength $y] $z -} {2 1 00} -test encoding-15.3 {UtfToUtfProc null character input} testbytestring { - set x [testbytestring \x00] - set y [encoding convertfrom utf-8 $x] - binary scan [encoding convertto identity $y] H* z - list [string bytelength $x] [string bytelength $y] $z -} {1 2 c080} + binary scan [testbytestring [encoding convertto utf-8 \u0000]] H* z + set z +} 00 +test encoding-15.3 {UtfToUtfProc null character input} teststringbytes { + set y [encoding convertfrom utf-8 [encoding convertto utf-8 \u0000]] + binary scan [teststringbytes $y] H* z + set z +} c080 test encoding-16.1 {UnicodeToUtfProc} { set val [encoding convertfrom unicode NN] -- cgit v0.12 From fa2e7e8949ad5728da4d3dfdd796a4f7e3e0e811 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 27 Oct 2017 07:26:15 +0000 Subject: =?UTF-8?q?Fix=20timeout=20calculation=20in=20epoll-based=20notifi?= =?UTF-8?q?er.=20Proposed=20fix=20for=20[1a6a36d901dedead248ea96df09d5dc15?= =?UTF-8?q?9532652|1a6a36d901].=20Patch=20by=20Lucio=20Andr=C3=A9s=20Illan?= =?UTF-8?q?es=20Albornoz.=20Thanks!?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- unix/tclEpollNotfy.c | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/unix/tclEpollNotfy.c b/unix/tclEpollNotfy.c index 088f314..9d0053c 100644 --- a/unix/tclEpollNotfy.c +++ b/unix/tclEpollNotfy.c @@ -462,7 +462,10 @@ PlatformEventsWait( } else if (!timePtr->tv_sec && !timePtr->tv_usec) { timeout = 0; } else { - timeout = (int)timePtr->tv_sec; + timeout = (int)timePtr->tv_sec * 1000; + if (timePtr->tv_usec) { + timeout += (int)timePtr->tv_usec / 1000; + } } /* -- cgit v0.12 From 4ab9cb54181038d61f85f76f76a7b23e7a7c59ca Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 27 Oct 2017 12:23:28 +0000 Subject: Update tests that were still written on the outdated premise that Tcl's encoding subsystem had to initialize starting in the identity encoding. --- tests/cmdAH.test | 8 ++++---- tests/encoding.test | 8 ++++---- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/tests/cmdAH.test b/tests/cmdAH.test index 4ca90c6..45a867a 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -145,7 +145,7 @@ test cmdAH-4.5 {Tcl_EncodingObjCmd} { } 8C test cmdAH-4.6 {Tcl_EncodingObjCmd} { set system [encoding system] - encoding system identity + encoding system iso8859-1 set x [encoding convertto jis0208 \u4e4e] encoding system $system set x @@ -165,7 +165,7 @@ test cmdAH-4.9 {Tcl_EncodingObjCmd} { } \u4e4e test cmdAH-4.10 {Tcl_EncodingObjCmd} { set system [encoding system] - encoding system identity + encoding system iso8859-1 set x [encoding convertfrom jis0208 8C] encoding system $system set x @@ -178,11 +178,11 @@ test cmdAH-4.12 {Tcl_EncodingObjCmd} { } {1 {wrong # args: should be "encoding system ?encoding?"}} test cmdAH-4.13 {Tcl_EncodingObjCmd} { set system [encoding system] - encoding system identity + encoding system iso8859-1 set x [encoding system] encoding system $system set x -} identity +} iso8859-1 test cmdAH-5.1 {Tcl_FileObjCmd} { list [catch file msg] $msg diff --git a/tests/encoding.test b/tests/encoding.test index 85deb33..498e176 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -66,10 +66,10 @@ test encoding-2.2 {Tcl_FreeEncoding: refcount != 0} {testencoding} { encoding system shiftjis ;# incr ref count encoding dirs [list [pwd]] set x [encoding convertto shiftjis \u4e4e] ;# old one found - encoding system identity + encoding system iso8859-1 llength shiftjis lappend x [catch {encoding convertto shiftjis \u4e4e} msg] $msg - encoding system identity + encoding system iso8859-1 encoding dirs $path encoding system $system set x @@ -121,7 +121,7 @@ test encoding-5.1 {Tcl_SetSystemEncoding} { set old [encoding system] encoding system jis0208 set x [encoding convertto \u4e4e] - encoding system identity + encoding system iso8859-1 encoding system $old set x } {8C} @@ -245,7 +245,7 @@ test encoding-11.5.1 {LoadEncodingFile: escape file} { test encoding-11.6 {LoadEncodingFile: invalid file} {testencoding} { set system [encoding system] set path [encoding dirs] - encoding system identity + encoding system iso8859-1 cd [temporaryDirectory] encoding dirs [file join tmp encoding] makeDirectory tmp -- cgit v0.12 From 0a3f9ca6fcac186283561f4f377448ddd6444aa4 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 27 Oct 2017 12:57:15 +0000 Subject: oops --- tests/encoding.test | 1 - 1 file changed, 1 deletion(-) diff --git a/tests/encoding.test b/tests/encoding.test index eb58ea0..ed0e6a4 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -80,7 +80,6 @@ test encoding-2.2 {Tcl_FreeEncoding: refcount != 0} -setup { lappend x [catch {encoding convertto shiftjis \u4e4e} msg] $msg } -cleanup { encoding system iso8859-1 - encoding system identity encoding dirs $path encoding system $system } -result "\u008c\u00c1 1 {unknown encoding \"shiftjis\"}" -- cgit v0.12 From 1d0751deb7fafb3e276e1ba022ef023e795946fb Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 30 Oct 2017 02:55:30 +0000 Subject: Revise tests that relied on deprecated variable resolution rules. --- tests/assemble.test | 2 +- tests/execute.test | 6 +++--- tests/resolver.test | 9 +++------ 3 files changed, 7 insertions(+), 10 deletions(-) diff --git a/tests/assemble.test b/tests/assemble.test index a9c77e3..5231048 100644 --- a/tests/assemble.test +++ b/tests/assemble.test @@ -852,7 +852,7 @@ test assemble-8.5 {bad context} { -body { namespace eval assem { set x 1 - list [catch {assemble {load x}} result] $result $errorCode + list [catch {assemble {load x}} result opts] $result [dict get $opts -errorcode] } } -result {1 {cannot use this instruction to create a variable in a non-proc context} {TCL ASSEM LVT}} diff --git a/tests/execute.test b/tests/execute.test index 9a2ffbd..e1ed68b 100644 --- a/tests/execute.test +++ b/tests/execute.test @@ -724,7 +724,7 @@ test execute-6.14 {Tcl_ExprObj: exprcode context validation} -setup { } set result {} lappend result [expr $e] - lappend result [namespace eval foo {expr $e}] + lappend result [namespace eval foo [list expr $e]] } -cleanup { namespace delete foo } -result {1 2} @@ -733,11 +733,11 @@ test execute-6.15 {Tcl_ExprObj: exprcode name resolution epoch validation} -setu } -body { set e { [llength {}]+1 } set result {} - lappend result [namespace eval foo {expr $e}] + lappend result [namespace eval foo [list expr $e]] namespace eval foo { proc llength {args} {return 1} } - lappend result [namespace eval foo {expr $e}] + lappend result [namespace eval foo [list expr $e]] } -cleanup { namespace delete foo } -result {1 2} diff --git a/tests/resolver.test b/tests/resolver.test index 9bb4c08..b0b395d 100644 --- a/tests/resolver.test +++ b/tests/resolver.test @@ -139,13 +139,10 @@ test resolver-1.5 {cmdNameObj sharing vs. cmd resolver: other than global NS} -s variable r2 "" } } -constraints testinterpresolver -body { - set r0 [namespace eval ::ns2 {x}] - set r1 [namespace eval ::ns2 {z}] - namespace eval ::ns2 { + list [namespace eval ::ns2 {x}] [namespace eval ::ns2 {z}] [namespace eval ::ns2 { namespace import ::ns1::z - set r2 [z] - } - list $r0 $r1 $r2 + z + }] } -cleanup { testinterpresolver down namespace delete ::ns2 -- cgit v0.12 From c5865fcd241e9a0eec80a61152b696d9d066944b Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 30 Oct 2017 03:23:28 +0000 Subject: More test rewrites for robust var resolution. --- tests/platform.test | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/tests/platform.test b/tests/platform.test index c826444..8ee0ec7 100644 --- a/tests/platform.test +++ b/tests/platform.test @@ -16,7 +16,9 @@ namespace eval ::tcl::test::platform { namespace import ::tcltest::test namespace import ::tcltest::cleanupTests - variable ::tcl_platform + # This is not how [variable] works. See TIP 276. + #variable ::tcl_platform + namespace upvar :: tcl_platform tcl_platform ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] -- cgit v0.12 From a79bc3c8ce1f7c5fc723d0ab7e256cb9090433a8 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Mon, 30 Oct 2017 05:19:55 +0000 Subject: Fix for issue 9fd5c629c1, TclOO - aborts when a trace on command deletion deletes the object's namespace. --- generic/tclBasic.c | 8 ++++---- generic/tclFileName.c | 2 +- generic/tclOO.c | 35 ++++++++++++++++++++++++++--------- generic/tclOOCall.c | 8 ++++---- generic/tclOOInt.h | 16 ++++++++-------- tests/oo.test | 12 ++++++++++++ 6 files changed, 55 insertions(+), 26 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index d4fa833..e6022ac 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -3112,7 +3112,7 @@ Tcl_DeleteCommandFromToken( /* * We must delete this command, even though both traces and delete procs * may try to avoid this (renaming the command etc). Also traces and - * delete procs may try to delete the command themsevles. This flag + * delete procs may try to delete the command themselves. This flag * declares that a delete is in progress and that recursive deletes should * be ignored. */ @@ -7722,8 +7722,8 @@ ExprRandFunc( iPtr->flags |= RAND_SEED_INITIALIZED; /* - * Take into consideration the thread this interp is running in order - * to insure different seeds in different threads (bug #416643) + * To ensure different seeds in different threads (bug #416643), + * take into consideration the thread this interp is running in. */ iPtr->randSeed = TclpGetClicks() + (PTR2INT(Tcl_GetCurrentThread())<<12); @@ -9091,7 +9091,7 @@ TclNRCoroutineObjCmd( TclNRAddCallback(interp, NRCoroutineExitCallback, corPtr, NULL, NULL, NULL); - /* insure that the command is looked up in the correct namespace */ + /* ensure that the command is looked up in the correct namespace */ iPtr->lookupNsPtr = lookupNsPtr; Tcl_NREvalObj(interp, Tcl_NewListObj(objc-2, objv+2), 0); iPtr->numLevels--; diff --git a/generic/tclFileName.c b/generic/tclFileName.c index 150fb8c..15fcde7 100644 --- a/generic/tclFileName.c +++ b/generic/tclFileName.c @@ -1904,7 +1904,7 @@ TclGlob( } /* - * To process a [glob] invokation, this function may be called multiple + * To process a [glob] invocation, this function may be called multiple * times. Each time, the previously discovered filenames are in the * interpreter result. We stash that away here so the result is free for * error messsages. diff --git a/generic/tclOO.c b/generic/tclOO.c index 73acce8..e9ef2ce 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -880,7 +880,7 @@ ObjectRenamedTrace( * 2950259] */ - if (((Namespace *) oPtr->namespacePtr)->earlyDeleteProc != NULL) { + if (oPtr->namespacePtr && ((Namespace *) oPtr->namespacePtr)->earlyDeleteProc != NULL) { Tcl_DeleteNamespace(oPtr->namespacePtr); } if (oPtr->classPtr) { @@ -1168,7 +1168,7 @@ ObjectNamespaceDeleted( Class *clsPtr = oPtr->classPtr, *mixinPtr; Method *mPtr; Tcl_Obj *filterObj, *variableObj; - int i; + int deleteAlreadyInProgress = 0, i; /* * Instruct everyone to no longer use any allocated fields of the object. @@ -1178,6 +1178,14 @@ ObjectNamespaceDeleted( */ if (oPtr->command) { + if ((((Command *)oPtr->command)->flags && CMD_IS_DELETED)) { + /* + * Namespace deletion must have been triggered by a trace on command + * deletion , meaning that + */ + deleteAlreadyInProgress = 1; + } + Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->command); } if (oPtr->myCommand) { @@ -1273,14 +1281,17 @@ ObjectNamespaceDeleted( if (clsPtr->subclasses.list) { ckfree(clsPtr->subclasses.list); + clsPtr->subclasses.list = NULL; clsPtr->subclasses.num = 0; } if (clsPtr->instances.list) { ckfree(clsPtr->instances.list); + clsPtr->instances.list = NULL; clsPtr->instances.num = 0; } if (clsPtr->mixinSubs.list) { ckfree(clsPtr->mixinSubs.list); + clsPtr->mixinSubs.list = NULL; clsPtr->mixinSubs.num = 0; } @@ -1305,7 +1316,13 @@ ObjectNamespaceDeleted( * Delete the object structure itself. */ - DelRef(oPtr); + if (deleteAlreadyInProgress) { + oPtr->classPtr = NULL; + oPtr->namespacePtr = NULL; + } else { + DelRef(oPtr); + } + } /* @@ -2433,7 +2450,7 @@ Tcl_ObjectSetMetadata( * * PublicObjectCmd, PrivateObjectCmd, TclOOInvokeObject -- * - * Main entry point for object invokations. The Public* and Private* + * Main entry point for object invocations. The Public* and Private* * wrapper functions (implementations of both object instance commands * and [my]) are just thin wrappers round the main TclOOObjectCmdCore * function. Note that the core is function is NRE-aware. @@ -2518,8 +2535,8 @@ TclOOInvokeObject( * * TclOOObjectCmdCore, FinalizeObjectCall -- * - * Main function for object invokations. Does call chain creation, - * management and invokation. The function FinalizeObjectCall exists to + * Main function for object invocations. Does call chain creation, + * management and invocation. The function FinalizeObjectCall exists to * clean up after the non-recursive processing of TclOOObjectCmdCore. * * ---------------------------------------------------------------------- @@ -2531,7 +2548,7 @@ TclOOObjectCmdCore( Tcl_Interp *interp, /* The interpreter containing the object. */ int objc, /* How many arguments are being passed in. */ Tcl_Obj *const *objv, /* The array of arguments. */ - int flags, /* Whether this is an invokation through the + int flags, /* Whether this is an invocation through the * public or the private command interface. */ Class *startCls) /* Where to start in the call chain, or NULL * if we are to start at the front with @@ -2720,7 +2737,7 @@ Tcl_ObjectContextInvokeNext( * call context while we process the body. However, need to adjust the * argument-skip control because we're guaranteed to have a single prefix * arg (i.e., 'next') and not the variable amount that can happen because - * method invokations (i.e., '$obj meth' and 'my meth'), constructors + * method invocations (i.e., '$obj meth' and 'my meth'), constructors * (i.e., '$cls new' and '$cls create obj') and destructors (no args at * all) come through the same code. */ @@ -2789,7 +2806,7 @@ TclNRObjectContextInvokeNext( * call context while we process the body. However, need to adjust the * argument-skip control because we're guaranteed to have a single prefix * arg (i.e., 'next') and not the variable amount that can happen because - * method invokations (i.e., '$obj meth' and 'my meth'), constructors + * method invocations (i.e., '$obj meth' and 'my meth'), constructors * (i.e., '$cls new' and '$cls create obj') and destructors (no args at * all) come through the same code. */ diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c index 3e4f561..d4e1e34 100644 --- a/generic/tclOOCall.c +++ b/generic/tclOOCall.c @@ -233,7 +233,7 @@ FreeMethodNameRep( * TclOOInvokeContext -- * * Invokes a single step along a method call-chain context. Note that the - * invokation of a step along the chain can cause further steps along the + * invocation of a step along the chain can cause further steps along the * chain to be invoked. Note that this function is written to be as light * in stack usage as possible. * @@ -830,7 +830,7 @@ AddMethodToCallChain( * Call chain semantics states that methods come as *late* in the * call chain as possible. This is done by copying down the * following methods. Note that this does not change the number of - * method invokations in the call chain; it just rearranges them. + * method invocations in the call chain; it just rearranges them. */ Class *declCls = callPtr->chain[i].filterDeclarer; @@ -935,7 +935,7 @@ IsStillValid( * TclOOGetCallContext -- * * Responsible for constructing the call context, an ordered list of all - * method implementations to be called as part of a method invokation. + * method implementations to be called as part of a method invocation. * This method is central to the whole operation of the OO system. * * ---------------------------------------------------------------------- @@ -1517,7 +1517,7 @@ TclOORenderCallChain( /* * Do the actual construction of the descriptions. They consist of a list * of triples that describe the details of how a method is understood. For - * each triple, the first word is the type of invokation ("method" is + * each triple, the first word is the type of invocation ("method" is * normal, "unknown" is special because it adds the method name as an * extra argument when handled by some method types, and "filter" is * special because it's a filter method). The second word is the name of diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h index 476446d..11ba698 100644 --- a/generic/tclOOInt.h +++ b/generic/tclOOInt.h @@ -149,8 +149,8 @@ typedef struct Object { struct Foundation *fPtr; /* The basis for the object system. Putting * this here allows the avoidance of quite a * lot of hash lookups on the critical path - * for object invokation and creation. */ - Tcl_Namespace *namespacePtr;/* This object's tame namespace. */ + * for object invocation and creation. */ + Tcl_Namespace *namespacePtr;/* This object's namespace. */ Tcl_Command command; /* Reference to this object's public * command. */ Tcl_Command myCommand; /* Reference to this object's internal @@ -162,12 +162,12 @@ typedef struct Object { /* Classes mixed into this object. */ LIST_STATIC(Tcl_Obj *) filters; /* List of filter names. */ - struct Class *classPtr; /* All classes have this non-NULL; it points - * to the class structure. Everything else has - * this NULL. */ + struct Class *classPtr; /* This is non-NULL for all classes, and NULL + * for everything else. It points to the class + * structure. */ int refCount; /* Number of strong references to this object. * Note that there may be many more weak - * references; this mechanism is there to + * references; this mechanism exists to * avoid Tcl_Preserve. */ int flags; int creationEpoch; /* Unique value to make comparisons of objects @@ -323,7 +323,7 @@ typedef struct Foundation { } Foundation; /* - * A call context structure is built when a method is called. They contain the + * A call context structure is built when a method is called. It contains the * chain of method implementations that are to be invoked by a particular * call, and the process of calling walks the chain, with the [next] command * proceeding to the next entry in the chain. @@ -334,7 +334,7 @@ typedef struct Foundation { struct MInvoke { Method *mPtr; /* Reference to the method implementation * record. */ - int isFilter; /* Whether this is a filter invokation. */ + int isFilter; /* Whether this is a filter invocation. */ Class *filterDeclarer; /* What class decided to add the filter; if * NULL, it was added by the object. */ }; diff --git a/tests/oo.test b/tests/oo.test index 2a6eb80..6268dc6 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -1482,6 +1482,18 @@ test oo-11.4 {OO: cleanup} { lappend result [bar0 destroy] [oo::object create foo] [foo destroy] \ [oo::object create bar2] [bar2 destroy] } {1 {can't create object "foo": command already exists with that name} destroyed {} ::foo {} ::bar2 {}} +test oo-11.5 {OO: cleanup} { + oo::class create obj1 + + trace add command obj1 delete {apply {{name1 name2 action} { + set namespace [info object namespace $name1] + namespace delete $namespace + }}} + + rename obj1 {} + # No segmentation fault + return done +} done test oo-12.1 {OO: filters} { oo::class create Aclass -- cgit v0.12 From 8bb421f959a1a5cb8a552a423341b4a7896b042c Mon Sep 17 00:00:00 2001 From: pooryorick Date: Wed, 1 Nov 2017 21:05:32 +0000 Subject: Fix bug 3c32a3f8bd, segmentation fault in TclOO.c/ReleaseClassContents() for a class mixed into one of its instances. --- generic/tclOO.c | 15 +++++++++++++-- 1 file changed, 13 insertions(+), 2 deletions(-) diff --git a/generic/tclOO.c b/generic/tclOO.c index e9ef2ce..51731d3 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -1006,8 +1006,18 @@ ReleaseClassContents( } for(j=0 ; jmixins.num ; j++) { Class *mixin = instancePtr->mixins.list[j]; + Class *nextMixin = NULL; if (mixin == clsPtr) { - instancePtr->mixins.list[j] = NULL; + if (j < instancePtr->mixins.num - 1) { + nextMixin = instancePtr->mixins.list[j+1]; + } + if (j == 0) { + instancePtr->mixins.num = 0; + instancePtr->mixins.list = NULL; + } else { + instancePtr->mixins.list[j-1] = nextMixin; + } + instancePtr->mixins.num -= 1; } } if (instancePtr != NULL && !IsRoot(instancePtr)) { @@ -1181,7 +1191,8 @@ ObjectNamespaceDeleted( if ((((Command *)oPtr->command)->flags && CMD_IS_DELETED)) { /* * Namespace deletion must have been triggered by a trace on command - * deletion , meaning that + * deletion , meaning that ObjectRenamedTrace() is eventually going + * to be called . */ deleteAlreadyInProgress = 1; } -- cgit v0.12 From d33ee7bc07e1c461c4292dfe866e2400f2536367 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Wed, 1 Nov 2017 22:21:50 +0000 Subject: Unit test for issue 3c32a3f8bd, Segmentation fault in TclOO.c/ReleaseClassContents() for a class mixed into one of its instances. --- tests/oo.test | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) diff --git a/tests/oo.test b/tests/oo.test index 6413094..b6af1ee 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -1495,6 +1495,24 @@ test oo-11.5 {OO: cleanup} { return done } done +test oo-11.6 { + OO: cleanup ReleaseClassContents() where class is mixed into one of its + instances +} { + oo::class create obj1 + ::oo::define obj1 {self mixin [self]} + + ::oo::copy obj1 obj2 + ::oo::objdefine obj2 {mixin [self]} + + ::oo::copy obj2 obj3 + trace add command obj3 delete [list obj3 dying] + rename obj2 {} + + # No segmentation fault + return done +} done + test oo-12.1 {OO: filters} { oo::class create Aclass Aclass create Aobject -- cgit v0.12 From 274ab123a800239134ffb7e63421a13f55b38b89 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 3 Nov 2017 12:14:01 +0000 Subject: Better versions of TclGetIntFromObj and TclGetIntForIndexM macro's, which give advantage for platforms where longs are not ints (e.g. linux64) --- generic/tclInt.h | 18 +++++++++++++----- 1 file changed, 13 insertions(+), 5 deletions(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index 2f830cc..1908e32 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2422,8 +2422,8 @@ typedef struct List { #define TCL_EACH_COLLECT 1 /* Collect iteration result like [lmap] */ /* - * Macros providing a faster path to integers: Tcl_GetLongFromObj everywhere, - * Tcl_GetIntFromObj and TclGetIntForIndex on platforms where longs are ints. + * Macros providing a faster path to integers: Tcl_GetLongFromObj, + * Tcl_GetIntFromObj and TclGetIntForIndex. * * WARNING: these macros eval their args more than once. */ @@ -2444,9 +2444,17 @@ typedef struct List { : TclGetIntForIndex((interp), (objPtr), (endValue), (idxPtr))) #else #define TclGetIntFromObj(interp, objPtr, intPtr) \ - Tcl_GetIntFromObj((interp), (objPtr), (intPtr)) -#define TclGetIntForIndexM(interp, objPtr, ignore, idxPtr) \ - TclGetIntForIndex(interp, objPtr, ignore, idxPtr) + (((objPtr)->typePtr == &tclIntType \ + && (objPtr)->internalRep.longValue >= -(Tcl_WideInt)(UINT_MAX) \ + && (objPtr)->internalRep.longValue <= (Tcl_WideInt)(UINT_MAX)) \ + ? ((*(intPtr) = (objPtr)->internalRep.longValue), TCL_OK) \ + : Tcl_GetIntFromObj((interp), (objPtr), (intPtr))) +#define TclGetIntForIndexM(interp, objPtr, endValue, idxPtr) \ + (((objPtr)->typePtr == &tclIntType \ + && (objPtr)->internalRep.longValue >= INT_MIN \ + && (objPtr)->internalRep.longValue <= INT_MAX) \ + ? ((*(idxPtr) = (objPtr)->internalRep.longValue), TCL_OK) \ + : TclGetIntForIndex((interp), (objPtr), (endValue), (idxPtr))) #endif /* -- cgit v0.12 From 5528e1c1a25f45988be72e2e16ff577f0dbb1abd Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 3 Nov 2017 12:57:15 +0000 Subject: Fix [6f2f83cc149e9918884faffefebc8dfa695f4ea0|6f2f83cc14]: tclWinload.c robustness. And fix a minor possible memory leak in TclSetupEnv() as well. Thanks to Christian Werner for both suggestions, backported from Androwish. --- generic/tclEnv.c | 1 + win/tclWinLoad.c | 10 +++++++--- 2 files changed, 8 insertions(+), 3 deletions(-) diff --git a/generic/tclEnv.c b/generic/tclEnv.c index 66ddb57..8cc4b74 100644 --- a/generic/tclEnv.c +++ b/generic/tclEnv.c @@ -130,6 +130,7 @@ TclSetupEnv( * '='; ignore the entry. */ + Tcl_DStringFree(&envString); continue; } p2++; diff --git a/win/tclWinLoad.c b/win/tclWinLoad.c index 3ad6328..2946ea2 100644 --- a/win/tclWinLoad.c +++ b/win/tclWinLoad.c @@ -63,7 +63,7 @@ TclpDlopen( * file. */ int flags) { - HINSTANCE hInstance; + HINSTANCE hInstance = NULL; const TCHAR *nativeName; Tcl_LoadHandle handlePtr; DWORD firstError; @@ -75,7 +75,10 @@ TclpDlopen( */ nativeName = Tcl_FSGetNativePath(pathPtr); - hInstance = LoadLibraryEx(nativeName,NULL,LOAD_WITH_ALTERED_SEARCH_PATH); + if (nativeName != NULL) { + hInstance = LoadLibraryEx(nativeName, NULL, + LOAD_WITH_ALTERED_SEARCH_PATH); + } if (hInstance == NULL) { /* * Let the OS loader examine the binary search path for whatever @@ -89,7 +92,8 @@ TclpDlopen( * Remember the first error on load attempt to be used if the * second load attempt below also fails. */ - firstError = GetLastError(); + firstError = (nativeName == NULL) ? + ERROR_MOD_NOT_FOUND : GetLastError(); nativeName = Tcl_WinUtfToTChar(Tcl_GetString(pathPtr), -1, &ds); hInstance = LoadLibraryEx(nativeName, NULL, -- cgit v0.12 From 0480b5d79b11a26b00e355bc15655e9cfabdbeb9 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 3 Nov 2017 17:02:49 +0000 Subject: Revise a few stray packages not yet ready to tolerate a Tcl 9 bump. --- library/opt/optparse.tcl | 4 ++-- library/opt/pkgIndex.tcl | 4 ++-- library/tcltest/pkgIndex.tcl | 4 ++-- library/tcltest/tcltest.tcl | 2 +- unix/Makefile.in | 4 ++-- 5 files changed, 9 insertions(+), 9 deletions(-) diff --git a/library/opt/optparse.tcl b/library/opt/optparse.tcl index 869a2b6..e5ce052 100644 --- a/library/opt/optparse.tcl +++ b/library/opt/optparse.tcl @@ -8,10 +8,10 @@ # on it. If your code does rely on this package you # may directly incorporate this code into your application. -package require Tcl 8.2 +package require Tcl 8.2- # When this version number changes, update the pkgIndex.tcl file # and the install directory in the Makefiles. -package provide opt 0.4.6 +package provide opt 0.4.7 namespace eval ::tcl { diff --git a/library/opt/pkgIndex.tcl b/library/opt/pkgIndex.tcl index 107d4c6..d6ecdd6 100644 --- a/library/opt/pkgIndex.tcl +++ b/library/opt/pkgIndex.tcl @@ -8,5 +8,5 @@ # script is sourced, the variable $dir must contain the # full path name of this file's directory. -if {![package vsatisfies [package provide Tcl] 8.2]} {return} -package ifneeded opt 0.4.6 [list source [file join $dir optparse.tcl]] +if {![package vsatisfies [package provide Tcl] 8.2-]} {return} +package ifneeded opt 0.4.7 [list source [file join $dir optparse.tcl]] diff --git a/library/tcltest/pkgIndex.tcl b/library/tcltest/pkgIndex.tcl index 5ac8823..eadb1bd 100644 --- a/library/tcltest/pkgIndex.tcl +++ b/library/tcltest/pkgIndex.tcl @@ -8,5 +8,5 @@ # script is sourced, the variable $dir must contain the # full path name of this file's directory. -if {![package vsatisfies [package provide Tcl] 8.5]} {return} -package ifneeded tcltest 2.4.0 [list source [file join $dir tcltest.tcl]] +if {![package vsatisfies [package provide Tcl] 8.5-]} {return} +package ifneeded tcltest 2.4.1 [list source [file join $dir tcltest.tcl]] diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl index 75975d2..f1b6082 100644 --- a/library/tcltest/tcltest.tcl +++ b/library/tcltest/tcltest.tcl @@ -22,7 +22,7 @@ namespace eval tcltest { # When the version number changes, be sure to update the pkgIndex.tcl file, # and the install directory in the Makefiles. When the minor version # changes (new feature) be sure to update the man page as well. - variable Version 2.4.0 + variable Version 2.4.1 # Compatibility support for dumb variables defined in tcltest 1 # Do not use these. Call [package provide Tcl] and [info patchlevel] diff --git a/unix/Makefile.in b/unix/Makefile.in index c31d128..032b5ac 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -857,8 +857,8 @@ install-libraries: libraries done; @echo "Installing package msgcat 1.6.1 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/msgcat-1.6.1.tm; - @echo "Installing package tcltest 2.4.0 as a Tcl Module"; - @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/tcltest-2.4.0.tm; + @echo "Installing package tcltest 2.4.1 as a Tcl Module"; + @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/tcltest-2.4.1.tm; @echo "Installing package platform 1.0.14 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/platform/platform.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/platform-1.0.14.tm; -- cgit v0.12 From e4356f7d64ab9d2c871b3015e10ecf3955d7f539 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 4 Nov 2017 00:25:43 +0000 Subject: Detected bug in [string first] with unicode. Pat Thoyts found it. --- tests/string.test | 16 +++++++++++++--- tests/stringObj.test | 5 ++++- 2 files changed, 17 insertions(+), 4 deletions(-) diff --git a/tests/string.test b/tests/string.test index 549944d..cb901b9 100644 --- a/tests/string.test +++ b/tests/string.test @@ -28,6 +28,11 @@ testConstraint testindexobj [expr {[info commands testindexobj] != {}}] # Used for constraining memory leak tests testConstraint memory [llength [info commands memory]] +proc representationpoke s { + set r [::tcl::unsupported::representation $s] + list [lindex $r 3] [string match {*, string representation "*"} $r] +} + test string-1.1 {error conditions} { list [catch {string gorp a b} msg] $msg } {1 {unknown or ambiguous subcommand "gorp": must be bytelength, cat, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} @@ -224,6 +229,13 @@ test string-4.15 {string first, ability to two-byte encoded utf-8 chars} { set uchar \u057e ;# character with two-byte encoding in utf-8 string first % %#$uchar$uchar#$uchar$uchar#% 3 } 8 +test string-4.16 {string first, normal string vs pure unicode string} { + set s hello + regexp ll $s m + # Representation checks are canaries + list [representationpoke $s] [representationpoke $m] \ + [string first $m $s] +} {{string 1} {string 0} 2} test string-5.1 {string index} { list [catch {string index} msg] $msg @@ -2042,9 +2054,7 @@ test string-29.15 {string cat, efficiency} -setup { } -body { tcl::unsupported::representation [string cat $e $f $e $f [list x]] } -match glob -result {*no string representation} - - - + # cleanup rename MemStress {} catch {rename foo {}} diff --git a/tests/stringObj.test b/tests/stringObj.test index 49f268e..a78b5f8 100644 --- a/tests/stringObj.test +++ b/tests/stringObj.test @@ -480,7 +480,6 @@ test stringObj-15.8 {Tcl_Append*ToObj: self appends} testobj { teststringobj set 1 foo teststringobj appendself2 1 3 } foo - if {[testConstraint testobj]} { testobj freeallvars @@ -489,3 +488,7 @@ if {[testConstraint testobj]} { # cleanup ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# End: -- cgit v0.12 From b55d5cc57eba5295979ff84c7256c577f2a24cc8 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 4 Nov 2017 00:34:48 +0000 Subject: Fix for the weird [string first] behaviour. --- generic/tclStringObj.c | 42 +++++++++++++++++++++++------------------- 1 file changed, 23 insertions(+), 19 deletions(-) diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 7c1d42b..3a35bcf 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -3242,40 +3242,44 @@ TclStringFind( return -1; } + /* + * Check if we have two strings of single-byte characters. If we have, we + * can use strstr() to do the search. Note that we can sometimes have + * multibyte characters when the string could be minimally represented + * using single byte characters; we can't assume that a mismatch here + * means no match. + */ + lh = Tcl_GetCharLength(haystack); - if (haystack->bytes && (lh == haystack->length)) { - /* haystack is all single-byte chars */ + if (haystack->bytes && (lh == haystack->length) && needle->bytes + && (ln == needle->length)) { + /* + * Both haystack and needle are all single-byte chars. + */ - if (needle->bytes && (ln == needle->length)) { - /* needle is also all single-byte chars */ - char *found = strstr(haystack->bytes + start, needle->bytes); + char *found = strstr(haystack->bytes + start, needle->bytes); - if (found) { - return (found - haystack->bytes); - } else { - return -1; - } + if (found) { + return (found - haystack->bytes); } else { - /* - * Cannot find substring with a multi-byte char inside - * a string with no multi-byte chars. - */ return -1; } } else { + /* + * Do the search on the unicode representation for simplicity. + */ + Tcl_UniChar *try, *end, *uh; Tcl_UniChar *un = Tcl_GetUnicodeFromObj(needle, &ln); uh = Tcl_GetUnicodeFromObj(haystack, &lh); end = uh + lh; - try = uh + start; - while (try + ln <= end) { - if ((*try == *un) - && (0 == memcmp(try+1, un+1, (ln-1)*sizeof(Tcl_UniChar)))) { + for (try = uh + start; try + ln <= end; try++) { + if ((*try == *un) && (0 == + memcmp(try + 1, un + 1, (ln-1) * sizeof(Tcl_UniChar)))) { return (try - uh); } - try++; } return -1; } -- cgit v0.12 From ded2a799663066ed98c0a0b07d5fc5a661f988d8 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 5 Nov 2017 14:14:23 +0000 Subject: update .project file with branch name. Make clear that optparse doesnt work with 8.4 any more --- .project | 2 +- library/opt/optparse.tcl | 2 +- library/opt/pkgIndex.tcl | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/.project b/.project index a9d6ecf..eddd834 100644 --- a/.project +++ b/.project @@ -1,6 +1,6 @@ - tcl8.7 + tcl8 diff --git a/library/opt/optparse.tcl b/library/opt/optparse.tcl index e5ce052..c8946fd 100644 --- a/library/opt/optparse.tcl +++ b/library/opt/optparse.tcl @@ -8,7 +8,7 @@ # on it. If your code does rely on this package you # may directly incorporate this code into your application. -package require Tcl 8.2- +package require Tcl 8.5- # When this version number changes, update the pkgIndex.tcl file # and the install directory in the Makefiles. package provide opt 0.4.7 diff --git a/library/opt/pkgIndex.tcl b/library/opt/pkgIndex.tcl index d6ecdd6..daf9aa9 100644 --- a/library/opt/pkgIndex.tcl +++ b/library/opt/pkgIndex.tcl @@ -8,5 +8,5 @@ # script is sourced, the variable $dir must contain the # full path name of this file's directory. -if {![package vsatisfies [package provide Tcl] 8.2-]} {return} +if {![package vsatisfies [package provide Tcl] 8.5-]} {return} package ifneeded opt 0.4.7 [list source [file join $dir optparse.tcl]] -- cgit v0.12 From 22719c659625a4a57aa00294b5b02c96c51762d4 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 6 Nov 2017 00:10:21 +0000 Subject: Test case for Bug 5d65e65036. --- tests/pkg.test | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/tests/pkg.test b/tests/pkg.test index b935a3f..10b4732 100644 --- a/tests/pkg.test +++ b/tests/pkg.test @@ -518,6 +518,16 @@ test pkg-2.52 {Tcl_PkgRequire procedure, picking best stable version} { set x } {1.3} +test pkg-2.53 {Tcl_PkgRequire procedure, picking best stable version} { + package forget t + foreach i {1.2b1 1.1} { + package ifneeded t $i "set x $i; package provide t $i" + } + set x xxx + package require t + set x +} {1.1} + test pkg-3.1 {Tcl_PackageCmd procedure} { -- cgit v0.12 From c06751fdf8ec42ead80c501c199817370fbef853 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 6 Nov 2017 14:46:49 +0000 Subject: Fix version number of Windows Help file (not sure if it's actually used, but better safe than sorry) --- win/tcl.hpj.in | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/win/tcl.hpj.in b/win/tcl.hpj.in index a94cea6..08d411d 100644 --- a/win/tcl.hpj.in +++ b/win/tcl.hpj.in @@ -5,9 +5,9 @@ HCW=0 LCID=0x409 0x0 0x0 ;English (United States) REPORT=Yes TITLE=Tcl/Tk Reference Manual -CNT=tcl86.cnt +CNT=tcl87.cnt COPYRIGHT=Copyright © 2000 Ajuba Solutions -HLP=tcl86.hlp +HLP=tcl87.hlp [FILES] tcl.rtf -- cgit v0.12 From 45808db8dcbdfbee40971863bf92da08d2217966 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 7 Nov 2017 09:08:48 +0000 Subject: TIP #422 implementation, Tcl 8.7 part. --- generic/tcl.decls | 10 +++++----- generic/tclDecls.h | 25 +++++++++++++++---------- generic/tclStubInit.c | 5 +++++ 3 files changed, 25 insertions(+), 15 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index b2b91a9..0bdffec 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -945,10 +945,10 @@ declare 265 { declare 266 { void Tcl_ValidateAllMemory(const char *file, int line) } -declare 267 { +declare 267 {deprecated {see TIP #422}} { void Tcl_AppendResultVA(Tcl_Interp *interp, va_list argList) } -declare 268 { +declare 268 {deprecated {see TIP #422}} { void Tcl_AppendStringsToObjVA(Tcl_Obj *objPtr, va_list argList) } declare 269 { @@ -976,16 +976,16 @@ declare 274 { CONST84_RETURN char *Tcl_PkgRequire(Tcl_Interp *interp, const char *name, const char *version, int exact) } -declare 275 { +declare 275 {deprecated {see TIP #422}} { void Tcl_SetErrorCodeVA(Tcl_Interp *interp, va_list argList) } -declare 276 { +declare 276 {deprecated {see TIP #422}} { int Tcl_VarEvalVA(Tcl_Interp *interp, va_list argList) } declare 277 { Tcl_Pid Tcl_WaitPid(Tcl_Pid pid, int *statPtr, int options) } -declare 278 { +declare 278 {deprecated {see TIP #422}} { TCL_NORETURN void Tcl_PanicVA(const char *format, va_list argList) } declare 279 { diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 464fc0f..dc48dd5 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -812,10 +812,12 @@ EXTERN int Tcl_DumpActiveMemory(const char *fileName); /* 266 */ EXTERN void Tcl_ValidateAllMemory(const char *file, int line); /* 267 */ -EXTERN void Tcl_AppendResultVA(Tcl_Interp *interp, +TCL_DEPRECATED("see TIP #422") +void Tcl_AppendResultVA(Tcl_Interp *interp, va_list argList); /* 268 */ -EXTERN void Tcl_AppendStringsToObjVA(Tcl_Obj *objPtr, +TCL_DEPRECATED("see TIP #422") +void Tcl_AppendStringsToObjVA(Tcl_Obj *objPtr, va_list argList); /* 269 */ EXTERN char * Tcl_HashStats(Tcl_HashTable *tablePtr); @@ -838,14 +840,17 @@ EXTERN CONST84_RETURN char * Tcl_PkgRequire(Tcl_Interp *interp, const char *name, const char *version, int exact); /* 275 */ -EXTERN void Tcl_SetErrorCodeVA(Tcl_Interp *interp, +TCL_DEPRECATED("see TIP #422") +void Tcl_SetErrorCodeVA(Tcl_Interp *interp, va_list argList); /* 276 */ -EXTERN int Tcl_VarEvalVA(Tcl_Interp *interp, va_list argList); +TCL_DEPRECATED("see TIP #422") +int Tcl_VarEvalVA(Tcl_Interp *interp, va_list argList); /* 277 */ EXTERN Tcl_Pid Tcl_WaitPid(Tcl_Pid pid, int *statPtr, int options); /* 278 */ -EXTERN TCL_NORETURN void Tcl_PanicVA(const char *format, va_list argList); +TCL_DEPRECATED("see TIP #422") +TCL_NORETURN void Tcl_PanicVA(const char *format, va_list argList); /* 279 */ EXTERN void Tcl_GetVersion(int *major, int *minor, int *patchLevel, int *type); @@ -2133,18 +2138,18 @@ typedef struct TclStubs { void (*tcl_WrongNumArgs) (Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], const char *message); /* 264 */ int (*tcl_DumpActiveMemory) (const char *fileName); /* 265 */ void (*tcl_ValidateAllMemory) (const char *file, int line); /* 266 */ - void (*tcl_AppendResultVA) (Tcl_Interp *interp, va_list argList); /* 267 */ - void (*tcl_AppendStringsToObjVA) (Tcl_Obj *objPtr, va_list argList); /* 268 */ + TCL_DEPRECATED_API("see TIP #422") void (*tcl_AppendResultVA) (Tcl_Interp *interp, va_list argList); /* 267 */ + TCL_DEPRECATED_API("see TIP #422") void (*tcl_AppendStringsToObjVA) (Tcl_Obj *objPtr, va_list argList); /* 268 */ char * (*tcl_HashStats) (Tcl_HashTable *tablePtr); /* 269 */ CONST84_RETURN char * (*tcl_ParseVar) (Tcl_Interp *interp, const char *start, CONST84 char **termPtr); /* 270 */ CONST84_RETURN char * (*tcl_PkgPresent) (Tcl_Interp *interp, const char *name, const char *version, int exact); /* 271 */ CONST84_RETURN char * (*tcl_PkgPresentEx) (Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr); /* 272 */ int (*tcl_PkgProvide) (Tcl_Interp *interp, const char *name, const char *version); /* 273 */ CONST84_RETURN char * (*tcl_PkgRequire) (Tcl_Interp *interp, const char *name, const char *version, int exact); /* 274 */ - void (*tcl_SetErrorCodeVA) (Tcl_Interp *interp, va_list argList); /* 275 */ - int (*tcl_VarEvalVA) (Tcl_Interp *interp, va_list argList); /* 276 */ + TCL_DEPRECATED_API("see TIP #422") void (*tcl_SetErrorCodeVA) (Tcl_Interp *interp, va_list argList); /* 275 */ + TCL_DEPRECATED_API("see TIP #422") int (*tcl_VarEvalVA) (Tcl_Interp *interp, va_list argList); /* 276 */ Tcl_Pid (*tcl_WaitPid) (Tcl_Pid pid, int *statPtr, int options); /* 277 */ - TCL_NORETURN1 void (*tcl_PanicVA) (const char *format, va_list argList); /* 278 */ + TCL_DEPRECATED_API("see TIP #422") TCL_NORETURN1 void (*tcl_PanicVA) (const char *format, va_list argList); /* 278 */ void (*tcl_GetVersion) (int *major, int *minor, int *patchLevel, int *type); /* 279 */ void (*tcl_InitMemory) (Tcl_Interp *interp); /* 280 */ Tcl_Channel (*tcl_StackChannel) (Tcl_Interp *interp, const Tcl_ChannelType *typePtr, ClientData instanceData, int mask, Tcl_Channel prevChan); /* 281 */ diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index ebd2086..24b28e5 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -72,6 +72,11 @@ static int TclSockMinimumBuffersOld(int sock, int size) # define TclBNInitBignumFromWideUInt 0 # define TclBNInitBignumFromWideInt 0 # define TclBNInitBignumFromLong 0 +# define Tcl_AppendResultVA 0 +# define Tcl_AppendStringsToObjVA 0 +# define Tcl_SetErrorCodeVA 0 +# define Tcl_PanicVA 0 +# define Tcl_VarEvalVA 0 #else #define TclSetStartupScriptPath setStartupScriptPath static void TclSetStartupScriptPath(Tcl_Obj *path) -- cgit v0.12 From ac4fb39a73fb01e2cbb763a086191aa4fcec175f Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 7 Nov 2017 13:19:37 +0000 Subject: Don't use Unicode character \udead in test-cases, because it is an invalid Unicode code-point (lower surrogate). This will cause test-failures with TIP #389. Just use \ud0ad in stead. Also fix some other test-cases which fail for TCL_UTF_MAX == 4. --- tests/string.test | 26 +++++++++++++------------- tests/utf.test | 4 ++-- 2 files changed, 15 insertions(+), 15 deletions(-) diff --git a/tests/string.test b/tests/string.test index cc65e67..bbba5eb 100644 --- a/tests/string.test +++ b/tests/string.test @@ -1682,40 +1682,40 @@ test string-24.4 {string reverse command - unshared string} { string reverse $x$y } edcba test string-24.5 {string reverse command - shared unicode string} { - set x abcde\udead + set x abcde\ud0ad string reverse $x -} \udeadedcba +} \ud0adedcba test string-24.6 {string reverse command - unshared string} { set x abc - set y de\udead + set y de\ud0ad string reverse $x$y -} \udeadedcba +} \ud0adedcba test string-24.7 {string reverse command - simple case} { string reverse a } a test string-24.8 {string reverse command - simple case} { - string reverse \udead -} \udead + string reverse \ud0ad +} \ud0ad test string-24.9 {string reverse command - simple case} { string reverse {} } {} test string-24.10 {string reverse command - corner case} { - set x \ubeef\udead + set x \ubeef\ud0ad string reverse $x -} \udead\ubeef +} \ud0ad\ubeef test string-24.11 {string reverse command - corner case} { set x \ubeef - set y \udead + set y \ud0ad string reverse $x$y -} \udead\ubeef +} \ud0ad\ubeef test string-24.12 {string reverse command - corner case} { set x \ubeef - set y \udead + set y \ud0ad string is ascii [string reverse $x$y] } 0 test string-24.13 {string reverse command - pure Unicode string} { - string reverse [string range \ubeef\udead\ubeef\udead\ubeef\udead 1 5] -} \udead\ubeef\udead\ubeef\udead + string reverse [string range \ubeef\ud0ad\ubeef\ud0ad\ubeef\ud0ad 1 5] +} \ud0ad\ubeef\ud0ad\ubeef\ud0ad test string-24.14 {string reverse command - pure bytearray} { binary scan [string reverse [binary format H* 010203]] H* x set x diff --git a/tests/utf.test b/tests/utf.test index 422ab08..45f9c0c 100644 --- a/tests/utf.test +++ b/tests/utf.test @@ -68,10 +68,10 @@ test utf-2.7 {Tcl_UtfToUniChar: lead (3-byte) followed by 2 trail} testbytestrin } {1} test utf-2.8 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} -constraints {fullutf testbytestring} -body { string length [testbytestring "\xF0\x90\x80\x80"] -} -result {1} +} -result {2} test utf-2.9 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} -constraints {fullutf testbytestring} -body { string length [testbytestring "\xF4\x8F\xBF\xBF"] -} -result {1} +} -result {2} test utf-2.10 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail, underflow} testbytestring { string length [testbytestring "\xF0\x8F\xBF\xBF"] } {4} -- cgit v0.12 From fd61a8e89e832f6814d5deb7fe5a0c171e638167 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 7 Nov 2017 21:32:04 +0000 Subject: Attempted bug fix. --- generic/tclHash.c | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/generic/tclHash.c b/generic/tclHash.c index 256b073..b553c68 100644 --- a/generic/tclHash.c +++ b/generic/tclHash.c @@ -1013,12 +1013,18 @@ static void RebuildTable( register Tcl_HashTable *tablePtr) /* Table to enlarge. */ { - int oldSize, count, index; - Tcl_HashEntry **oldBuckets; + int count, index, oldSize = tablePtr->numBuckets; + Tcl_HashEntry **oldBuckets = tablePtr->buckets; register Tcl_HashEntry **oldChainPtr, **newChainPtr; register Tcl_HashEntry *hPtr; const Tcl_HashKeyType *typePtr; + /* Avoid outgrowing capability of the memory allocators */ + if (oldSize > UINT_MAX / (4 * sizeof(Tcl_HashEntry *))) { + tablePtr->rebuildSize = INT_MAX; + return; + } + if (tablePtr->keyType == TCL_STRING_KEYS) { typePtr = &tclStringHashKeyType; } else if (tablePtr->keyType == TCL_ONE_WORD_KEYS) { @@ -1030,9 +1036,6 @@ RebuildTable( typePtr = &tclArrayHashKeyType; } - oldSize = tablePtr->numBuckets; - oldBuckets = tablePtr->buckets; - /* * Allocate and initialize the new bucket array, and set up hashing * constants for new array size. -- cgit v0.12 From 98c6b22c1002fae94f8abf7422758530a9a6fdeb Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 8 Nov 2017 02:21:49 +0000 Subject: TclOO object allocation: Set classPtr to NULL if it wasn't otherwise set. --- generic/tclOO.c | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/generic/tclOO.c b/generic/tclOO.c index ec666ee..f236ac9 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -537,7 +537,8 @@ KillFoundation( * AllocObject -- * * Allocate an object of basic type. Does not splice the object into its - * class's instance list. + * class's instance list. The caller must set the classPtr on the object, + * either to a class or to NULL. * * ---------------------------------------------------------------------- */ @@ -1672,6 +1673,8 @@ Tcl_NewObjectInstance( AllocClass(interp, oPtr); oPtr->selfCls = classPtr; TclOOAddToSubclasses(oPtr->classPtr, fPtr->objectCls); + } else { + oPtr->classPtr = NULL; } /* -- cgit v0.12 From 2ba5fab30eefc4f31112e67aeba2dd49a178ff4c Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 8 Nov 2017 02:25:40 +0000 Subject: Modify TclCreateProc to handle arbitrary argument names, not just ASCII. --- generic/tclExecute.c | 4 +-- generic/tclInt.h | 2 +- generic/tclProc.c | 96 +++++++++++++++++++++++----------------------------- 3 files changed, 45 insertions(+), 57 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index f4c71ec..54c73fd 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -1333,12 +1333,12 @@ TclStackAlloc( int numBytes) { Interp *iPtr = (Interp *) interp; - int numWords = (numBytes + (sizeof(Tcl_Obj *) - 1))/sizeof(Tcl_Obj *); + int numWords; if (iPtr == NULL || iPtr->execEnvPtr == NULL) { return (void *) ckalloc(numBytes); } - + numWords = (numBytes + (sizeof(Tcl_Obj *) - 1))/sizeof(Tcl_Obj *); return (void *) StackAllocWords(interp, numWords); } diff --git a/generic/tclInt.h b/generic/tclInt.h index 0d68e8e..29392b6 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4483,7 +4483,7 @@ MODULE_SCOPE int TclIsPureByteArray(Tcl_Obj *objPtr); /* *---------------------------------------------------------------- - * Macro used by the Tcl core to increment a namespace's export export epoch + * Macro used by the Tcl core to increment a namespace's export epoch * counter. The ANSI C "prototype" for this macro is: * * MODULE_SCOPE void TclInvalidateNsCmdLookup(Namespace *nsPtr); diff --git a/generic/tclProc.c b/generic/tclProc.c index 96bdcf3..8fc6dcb 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -393,13 +393,13 @@ TclCreateProc( Proc **procPtrPtr) /* Returns: pointer to proc data. */ { Interp *iPtr = (Interp *) interp; - const char **argArray = NULL; register Proc *procPtr; - int i, length, result, numArgs; - const char *args, *bytes, *p; + int i, result, numArgs, plen; + const char *bytes, *argname, *argnamei; + char argnamelast; register CompiledLocal *localPtr = NULL; - Tcl_Obj *defPtr; + Tcl_Obj *defPtr, *errorObj, **argArray; int precompiled = 0; if (bodyPtr->typePtr == &tclProcBodyType) { @@ -436,6 +436,7 @@ TclCreateProc( */ if (Tcl_IsShared(bodyPtr)) { + int length; Tcl_Obj *sharedBodyPtr = bodyPtr; bytes = TclGetStringFromObj(bodyPtr, &length); @@ -473,12 +474,9 @@ TclCreateProc( * argument specifier. If the body is precompiled, processing is limited * to checking that the parsed argument is consistent with the one stored * in the Proc. - * - * THIS FAILS IF THE ARG LIST OBJECT'S STRING REP CONTAINS NULS. */ - args = TclGetStringFromObj(argsPtr, &length); - result = Tcl_SplitList(interp, args, &numArgs, &argArray); + result = Tcl_ListObjGetElements(interp , argsPtr ,&numArgs ,&argArray); if (result != TCL_OK) { goto procError; } @@ -502,28 +500,28 @@ TclCreateProc( for (i = 0; i < numArgs; i++) { int fieldCount, nameLength; size_t valueLength; - const char **fieldValues; + Tcl_Obj **fieldValues; /* * Now divide the specifier up into name and default. */ - result = Tcl_SplitList(interp, argArray[i], &fieldCount, + result = Tcl_ListObjGetElements(interp, argArray[i], &fieldCount, &fieldValues); if (result != TCL_OK) { goto procError; } if (fieldCount > 2) { - ckfree(fieldValues); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "too many fields in argument specifier \"%s\"", - argArray[i])); + errorObj = Tcl_NewStringObj( + "too many fields in argument specifier \"", -1); + Tcl_AppendObjToObj(errorObj, argArray[i]); + Tcl_AppendToObj(errorObj, "\"", -1); + Tcl_SetObjResult(interp, errorObj); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "FORMALARGUMENTFORMAT", NULL); goto procError; } - if ((fieldCount == 0) || (*fieldValues[0] == 0)) { - ckfree(fieldValues); + if ((fieldCount == 0) || (fieldValues[0]->length == 0)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "argument with no name", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", @@ -531,9 +529,10 @@ TclCreateProc( goto procError; } - nameLength = strlen(fieldValues[0]); + nameLength = Tcl_NumUtfChars(Tcl_GetString(fieldValues[0]), fieldValues[0]->length); if (fieldCount == 2) { - valueLength = strlen(fieldValues[1]); + valueLength = Tcl_NumUtfChars(Tcl_GetString(fieldValues[1]), + fieldValues[1]->length); } else { valueLength = 0; } @@ -542,33 +541,29 @@ TclCreateProc( * Check that the formal parameter name is a scalar. */ - p = fieldValues[0]; - while (*p != '\0') { - if (*p == '(') { - const char *q = p; - do { - q++; - } while (*q != '\0'); - q--; - if (*q == ')') { /* We have an array element. */ + argname = Tcl_GetStringFromObj(fieldValues[0], &plen); + argnamei = argname; + argnamelast = argname[plen-1]; + while (plen--) { + if (argnamei[0] == '(') { + if (argnamelast == ')') { /* We have an array element. */ Tcl_SetObjResult(interp, Tcl_ObjPrintf( "formal parameter \"%s\" is an array element", - fieldValues[0])); - ckfree(fieldValues); + Tcl_GetString(fieldValues[0]))); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "FORMALARGUMENTFORMAT", NULL); goto procError; } - } else if ((*p == ':') && (*(p+1) == ':')) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "formal parameter \"%s\" is not a simple name", - fieldValues[0])); - ckfree(fieldValues); + } else if ((argnamei[0] == ':') && (argnamei[1] == ':')) { + errorObj = Tcl_NewStringObj("formal parameter \"", -1); + Tcl_AppendObjToObj(errorObj, fieldValues[0]); + Tcl_AppendToObj(errorObj, "\" is not a simple name", -1); + Tcl_SetObjResult(interp, errorObj); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "FORMALARGUMENTFORMAT", NULL); goto procError; } - p++; + argnamei = Tcl_UtfNext(argnamei); } if (precompiled) { @@ -584,7 +579,7 @@ TclCreateProc( */ if ((localPtr->nameLength != nameLength) - || (strcmp(localPtr->name, fieldValues[0])) + || (Tcl_UtfNcmp(localPtr->name, argname, nameLength)) || (localPtr->frameIndex != i) || !(localPtr->flags & VAR_ARGUMENT) || (localPtr->defValuePtr == NULL && fieldCount == 2) @@ -592,7 +587,6 @@ TclCreateProc( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "procedure \"%s\": formal parameter %d is " "inconsistent with precompiled body", procName, i)); - ckfree(fieldValues); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "BYTECODELIES", NULL); goto procError; @@ -607,12 +601,13 @@ TclCreateProc( size_t tmpLength = localPtr->defValuePtr->length; if ((valueLength != tmpLength) || - strncmp(fieldValues[1], tmpPtr, tmpLength)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "procedure \"%s\": formal parameter \"%s\" has " - "default value inconsistent with precompiled body", - procName, fieldValues[0])); - ckfree(fieldValues); + Tcl_UtfNcmp(Tcl_GetString(fieldValues[1]), tmpPtr, tmpLength)) { + errorObj = Tcl_ObjPrintf( + "procedure \"%s\": formal parameter \"" ,procName); + Tcl_AppendObjToObj(errorObj, fieldValues[0]); + Tcl_AppendToObj(errorObj, "\" has " + "default value inconsistent with precompiled body", -1); + Tcl_SetObjResult(interp, errorObj); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "BYTECODELIES", NULL); goto procError; @@ -632,7 +627,7 @@ TclCreateProc( * local variables for the argument. */ - localPtr = ckalloc(TclOffset(CompiledLocal, name) + nameLength+1); + localPtr = ckalloc(TclOffset(CompiledLocal, name) + fieldValues[0]->length +1); if (procPtr->firstLocalPtr == NULL) { procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr; } else { @@ -640,19 +635,18 @@ TclCreateProc( procPtr->lastLocalPtr = localPtr; } localPtr->nextPtr = NULL; - localPtr->nameLength = nameLength; + localPtr->nameLength = Tcl_NumUtfChars(argname, fieldValues[0]->length); localPtr->frameIndex = i; localPtr->flags = VAR_ARGUMENT; localPtr->resolveInfo = NULL; if (fieldCount == 2) { - localPtr->defValuePtr = - Tcl_NewStringObj(fieldValues[1], valueLength); + localPtr->defValuePtr = fieldValues[1]; Tcl_IncrRefCount(localPtr->defValuePtr); } else { localPtr->defValuePtr = NULL; } - memcpy(localPtr->name, fieldValues[0], nameLength + 1); + memcpy(localPtr->name, argname, fieldValues[0]->length + 1); if ((i == numArgs - 1) && (localPtr->nameLength == 4) && (localPtr->name[0] == 'a') @@ -660,12 +654,9 @@ TclCreateProc( localPtr->flags |= VAR_IS_ARGS; } } - - ckfree(fieldValues); } *procPtrPtr = procPtr; - ckfree(argArray); return TCL_OK; procError: @@ -686,9 +677,6 @@ TclCreateProc( } ckfree(procPtr); } - if (argArray != NULL) { - ckfree(argArray); - } return TCL_ERROR; } -- cgit v0.12 From f31af075d052f3285352b8c4c10174baef2eee4a Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 8 Nov 2017 02:50:28 +0000 Subject: compiler warning --- generic/tclHash.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclHash.c b/generic/tclHash.c index b553c68..5d6ea86 100644 --- a/generic/tclHash.c +++ b/generic/tclHash.c @@ -1020,7 +1020,7 @@ RebuildTable( const Tcl_HashKeyType *typePtr; /* Avoid outgrowing capability of the memory allocators */ - if (oldSize > UINT_MAX / (4 * sizeof(Tcl_HashEntry *))) { + if (oldSize > (int)(UINT_MAX / (4 * sizeof(Tcl_HashEntry *)))) { tablePtr->rebuildSize = INT_MAX; return; } -- cgit v0.12 From 12d3a7d307b177672437966afd5673f994b757f8 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 8 Nov 2017 09:37:31 +0000 Subject: Change "epoch" field for dicts from "int" to "unsigned int". This doubles the number of available epoch's before overflow. Also make 0 the special value in stead of -1, meaning "dict search done". That also means that epoch counting starts with 1. --- generic/tcl.h | 4 ++-- generic/tclDictObj.c | 18 +++++++++--------- 2 files changed, 11 insertions(+), 11 deletions(-) diff --git a/generic/tcl.h b/generic/tcl.h index 07d841d..80c8dcb 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -1344,8 +1344,8 @@ typedef struct Tcl_HashSearch { typedef struct { void *next; /* Search position for underlying hash * table. */ - int epoch; /* Epoch marker for dictionary being searched, - * or -1 if search has terminated. */ + unsigned int epoch; /* Epoch marker for dictionary being searched, + * or 0 if search has terminated. */ Tcl_Dict dictionaryPtr; /* Reference to dictionary being searched. */ } Tcl_DictSearch; diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index 1c74c5f..b1962e6 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -141,7 +141,7 @@ typedef struct Dict { * the dictionary. Used for doing traversal of * the entries in the order that they are * created. */ - int epoch; /* Epoch counter */ + unsigned int epoch; /* Epoch counter */ size_t refCount; /* Reference counter (see above) */ Tcl_Obj *chain; /* Linked list used for invalidating the * string representations of updated nested @@ -390,7 +390,7 @@ DupDictInternalRep( * Initialise other fields. */ - newDict->epoch = 0; + newDict->epoch = 1; newDict->chain = NULL; newDict->refCount = 1; @@ -710,7 +710,7 @@ SetDictFromAny( */ TclFreeIntRep(objPtr); - dict->epoch = 0; + dict->epoch = 1; dict->chain = NULL; dict->refCount = 1; DICT(objPtr) = dict; @@ -1109,7 +1109,7 @@ Tcl_DictObjFirst( dict = DICT(dictPtr); cPtr = dict->entryChainHead; if (cPtr == NULL) { - searchPtr->epoch = -1; + searchPtr->epoch = 0; *donePtr = 1; } else { *donePtr = 0; @@ -1170,7 +1170,7 @@ Tcl_DictObjNext( * If the searh is done; we do no work. */ - if (searchPtr->epoch == -1) { + if (!searchPtr->epoch) { *donePtr = 1; return; } @@ -1227,8 +1227,8 @@ Tcl_DictObjDone( { Dict *dict; - if (searchPtr->epoch != -1) { - searchPtr->epoch = -1; + if (searchPtr->epoch) { + searchPtr->epoch = 0; dict = (Dict *) searchPtr->dictionaryPtr; if (dict->refCount-- <= 1) { DeleteDict(dict); @@ -1380,7 +1380,7 @@ Tcl_NewDictObj(void) TclInvalidateStringRep(dictPtr); dict = ckalloc(sizeof(Dict)); InitChainTable(dict); - dict->epoch = 0; + dict->epoch = 1; dict->chain = NULL; dict->refCount = 1; DICT(dictPtr) = dict; @@ -1430,7 +1430,7 @@ Tcl_DbNewDictObj( TclInvalidateStringRep(dictPtr); dict = ckalloc(sizeof(Dict)); InitChainTable(dict); - dict->epoch = 0; + dict->epoch = 1; dict->chain = NULL; dict->refCount = 1; DICT(dictPtr) = dict; -- cgit v0.12 From c59b3f3bc10dd286aed6474e627a9613dc69bb44 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 9 Nov 2017 12:37:20 +0000 Subject: For alpha/beta versions of Tcl, stub-enabled extensions are only allowed to run on the EXACT the same Tcl versions as compiled: The stubs might still be in flux, they are not guaranteed to work on future Tcl versions anyway. Backported from "novem" (which already had this special protection). For final releases (8.7.0) everything works as before. --- generic/tcl.h | 23 ++++++++++++++++++----- 1 file changed, 18 insertions(+), 5 deletions(-) diff --git a/generic/tcl.h b/generic/tcl.h index 80c8dcb..a6a8c94 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -2409,14 +2409,27 @@ const char * TclTomMathInitializeStubs(Tcl_Interp *interp, const char *version, int epoch, int revision); #ifdef USE_TCL_STUBS -#define Tcl_InitStubs(interp, version, exact) \ - (Tcl_InitStubs)(interp, version, \ +#if TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE +# define Tcl_InitStubs(interp, version, exact) \ + (Tcl_InitStubs)(interp, version, \ (exact)|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16), \ TCL_STUB_MAGIC) #else -#define Tcl_InitStubs(interp, version, exact) \ - Tcl_PkgInitStubsCheck(interp, version, \ - (exact)|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16)) +# define Tcl_InitStubs(interp, version, exact) \ + (Tcl_InitStubs)(interp, TCL_PATCH_LEVEL, \ + 1|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16), \ + TCL_STUB_MAGIC) +#endif +#else +#if TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE +# define Tcl_InitStubs(interp, version, exact) \ + Tcl_PkgInitStubsCheck(interp, version, \ + (exact)|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16)) +#else +# define Tcl_InitStubs(interp, version, exact) \ + Tcl_PkgInitStubsCheck(interp, TCL_PATCH_LEVEL, \ + 1|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16)) +#endif #endif /* -- cgit v0.12 From 729fcd5f0987531367d7572998e8be23743febd1 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 9 Nov 2017 12:48:54 +0000 Subject: Make "scan %c" and the internal function ExtendUnicodeRepWithString() work as expected for TCL_UTF_MAX == 4 when handling characters > U+ffff. No effect when TCL_UTF_MAX == 3 or TCL_UTF_MAX == 6 --- generic/tclScan.c | 12 ++++++++++-- generic/tclStringObj.c | 6 +++--- 2 files changed, 13 insertions(+), 5 deletions(-) diff --git a/generic/tclScan.c b/generic/tclScan.c index e1fcad4..7f71262 100644 --- a/generic/tclScan.c +++ b/generic/tclScan.c @@ -885,9 +885,17 @@ Tcl_ScanObjCmd( * Scan a single Unicode character. */ - string += TclUtfToUniChar(string, &sch); + offset = TclUtfToUniChar(string, &sch); + i = (int)sch; +#if TCL_UTF_MAX == 4 + if (!offset) { + offset = Tcl_UtfToUniChar(string, &sch); + i = (((i<<10) & 0x0FFC00) + 0x10000) + (sch & 0x3FF); + } +#endif + string += offset; if (!(flags & SCAN_SUPPRESS)) { - objPtr = Tcl_NewIntObj((int)sch); + objPtr = Tcl_NewIntObj(i); Tcl_IncrRefCount(objPtr); CLANG_ASSERT(objs); objs[objIndex++] = objPtr; diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 01b044e..d43cc45 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -2720,7 +2720,6 @@ TclStringObjReverse( * Tcl_SetObjLength into growing the unicode rep buffer. */ - ch = 0; objPtr = Tcl_NewUnicodeObj(&ch, 1); Tcl_SetObjLength(objPtr, stringPtr->numChars); to = Tcl_GetUnicode(objPtr); @@ -2823,7 +2822,7 @@ ExtendUnicodeRepWithString( { String *stringPtr = GET_STRING(objPtr); int needed, numOrigChars = 0; - Tcl_UniChar *dst; + Tcl_UniChar *dst, unichar = 0; if (stringPtr->hasUnicode) { numOrigChars = stringPtr->numChars; @@ -2846,7 +2845,8 @@ ExtendUnicodeRepWithString( numAppendChars = 0; } for (dst=stringPtr->unicode + numOrigChars; numAppendChars-- > 0; dst++) { - bytes += TclUtfToUniChar(bytes, dst); + bytes += TclUtfToUniChar(bytes, &unichar); + *dst = unichar; } *dst = 0; } -- cgit v0.12 From 1ffeaf24efc557cfbfd2120f1871cf015e466cf2 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 10 Nov 2017 08:40:45 +0000 Subject: Make "string split" and "string is (alpha|graph|...)" work as expected with Unicode chars > U+ffff, when Tcl is compiled with TCL_UTF_MAX == 4. No effect when TCL_UTF_MAX == 3 or TCL_UTF_MAX == 6. Test-case added for "string split". --- generic/tclCmdMZ.c | 23 ++++++++++++++++++++--- tests/split.test | 3 +++ 2 files changed, 23 insertions(+), 3 deletions(-) diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 7010495..d63a985 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -309,7 +309,7 @@ Tcl_RegexpObjCmd( eflags = 0; } else if (offset > stringLength) { eflags = TCL_REG_NOTBOL; - } else if (Tcl_GetUniChar(objPtr, offset-1) == (Tcl_UniChar)'\n') { + } else if (Tcl_GetUniChar(objPtr, offset-1) == '\n') { eflags = 0; } else { eflags = TCL_REG_NOTBOL; @@ -1080,13 +1080,22 @@ Tcl_SplitObjCmd( Tcl_InitHashTable(&charReuseTable, TCL_ONE_WORD_KEYS); for ( ; stringPtr < end; stringPtr += len) { + int fullchar; len = TclUtfToUniChar(stringPtr, &ch); + fullchar = ch; + +#if TCL_UTF_MAX == 4 + if (!len) { + len += TclUtfToUniChar(stringPtr, &ch); + fullchar = (((fullchar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000; + } +#endif /* * Assume Tcl_UniChar is an integral type... */ - hPtr = Tcl_CreateHashEntry(&charReuseTable, INT2PTR((int) ch), + hPtr = Tcl_CreateHashEntry(&charReuseTable, INT2PTR(fullchar), &isNew); if (isNew) { TclNewStringObj(objPtr, stringPtr, len); @@ -1783,8 +1792,16 @@ StringIsCmd( } end = string1 + length1; for (; string1 < end; string1 += length2, failat++) { + int fullchar; length2 = TclUtfToUniChar(string1, &ch); - if (!chcomp(ch)) { + fullchar = ch; +#if TCL_UTF_MAX == 4 + if (!length2) { + length2 = TclUtfToUniChar(string1, &ch); + fullchar = (((fullchar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000; + } +#endif + if (!chcomp(fullchar)) { result = 0; break; } diff --git a/tests/split.test b/tests/split.test index 778131f..18055b3 100644 --- a/tests/split.test +++ b/tests/split.test @@ -70,6 +70,9 @@ test split-1.13 {basic split commands} { test split-1.14 {basic split commands} { split ",12,,,34,56," {,} } {{} 12 {} {} 34 56 {}} +test split-1.15 {basic split commands} -body { + split "a\U01f4a9b" {} +} -result "a \U01f4a9 b" test split-2.1 {split errors} { list [catch split msg] $msg $errorCode -- cgit v0.12 From 01fd6594cf127d8b79a5747c73469af626bdccd8 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 13 Nov 2017 08:37:55 +0000 Subject: Add a lot of "deprecation" marks to internal API which will be removed in Tcl 9.0 (see also tcl-9-cleanup branch). Extensions still using this API will get a compiler warning, but everything will continue to work fine for all future 8.x releases. --- generic/tcl.decls | 6 ++---- generic/tclDecls.h | 10 +++++---- generic/tclInt.decls | 56 +++++++++++++++++++------------------------------- generic/tclIntDecls.h | 57 ++++++++++++++++++++++++++++++--------------------- 4 files changed, 63 insertions(+), 66 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index b2b91a9..7c9935a 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -780,8 +780,7 @@ declare 218 { declare 219 { int Tcl_ScanCountedElement(const char *src, int length, int *flagPtr) } -# Obsolete -declare 220 { +declare 220 {deprecated {}} { int Tcl_SeekOld(Tcl_Channel chan, int offset, int mode) } declare 221 { @@ -868,8 +867,7 @@ declare 244 { declare 245 { int Tcl_StringMatch(const char *str, const char *pattern) } -# Obsolete -declare 246 { +declare 246 {deprecated {}} { int Tcl_TellOld(Tcl_Channel chan) } declare 247 { diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 464fc0f..864cad8 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -669,7 +669,8 @@ EXTERN int Tcl_ScanElement(const char *src, int *flagPtr); EXTERN int Tcl_ScanCountedElement(const char *src, int length, int *flagPtr); /* 220 */ -EXTERN int Tcl_SeekOld(Tcl_Channel chan, int offset, int mode); +TCL_DEPRECATED("") +int Tcl_SeekOld(Tcl_Channel chan, int offset, int mode); /* 221 */ EXTERN int Tcl_ServiceAll(void); /* 222 */ @@ -741,7 +742,8 @@ EXTERN void Tcl_StaticPackage(Tcl_Interp *interp, /* 245 */ EXTERN int Tcl_StringMatch(const char *str, const char *pattern); /* 246 */ -EXTERN int Tcl_TellOld(Tcl_Channel chan); +TCL_DEPRECATED("") +int Tcl_TellOld(Tcl_Channel chan); /* 247 */ EXTERN int Tcl_TraceVar(Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *proc, @@ -2086,7 +2088,7 @@ typedef struct TclStubs { void (*tcl_ResetResult) (Tcl_Interp *interp); /* 217 */ int (*tcl_ScanElement) (const char *src, int *flagPtr); /* 218 */ int (*tcl_ScanCountedElement) (const char *src, int length, int *flagPtr); /* 219 */ - int (*tcl_SeekOld) (Tcl_Channel chan, int offset, int mode); /* 220 */ + TCL_DEPRECATED_API("") int (*tcl_SeekOld) (Tcl_Channel chan, int offset, int mode); /* 220 */ int (*tcl_ServiceAll) (void); /* 221 */ int (*tcl_ServiceEvent) (int flags); /* 222 */ void (*tcl_SetAssocData) (Tcl_Interp *interp, const char *name, Tcl_InterpDeleteProc *proc, ClientData clientData); /* 223 */ @@ -2112,7 +2114,7 @@ typedef struct TclStubs { void (*tcl_SplitPath) (const char *path, int *argcPtr, CONST84 char ***argvPtr); /* 243 */ void (*tcl_StaticPackage) (Tcl_Interp *interp, const char *pkgName, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc); /* 244 */ int (*tcl_StringMatch) (const char *str, const char *pattern); /* 245 */ - int (*tcl_TellOld) (Tcl_Channel chan); /* 246 */ + TCL_DEPRECATED_API("") int (*tcl_TellOld) (Tcl_Channel chan); /* 246 */ int (*tcl_TraceVar) (Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 247 */ int (*tcl_TraceVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 248 */ char * (*tcl_TranslateFileName) (Tcl_Interp *interp, const char *name, Tcl_DString *bufferPtr); /* 249 */ diff --git a/generic/tclInt.decls b/generic/tclInt.decls index dea698c..b683a29 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -50,7 +50,7 @@ declare 6 { declare 7 { int TclCopyAndCollapse(int count, const char *src, char *dst) } -declare 8 { +declare 8 {deprecated {}} { int TclCopyChannelOld(Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, int toRead, Tcl_Obj *cmdPtr) } @@ -73,7 +73,7 @@ declare 11 { declare 12 { void TclDeleteVars(Interp *iPtr, TclVarHashTable *tablePtr) } -# Removed in 8.5 +# Removed in 8.5: #declare 13 { # int TclDoGlob(Tcl_Interp *interp, char *separators, # Tcl_DString *headPtr, char *tail, Tcl_GlobTypeData *types) @@ -88,7 +88,7 @@ declare 14 { declare 16 { void TclExprFloatError(Tcl_Interp *interp, double value) } -# Removed in 8.4 +# Removed in 8.4: #declare 17 { # int TclFileAttrsCmd(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) #} @@ -123,7 +123,7 @@ declare 25 { # declare 26 { # char *TclGetCwd(Tcl_Interp *interp) # } -# Removed in 8.5 +# Removed in 8.5: #declare 27 { # int TclGetDate(char *p, unsigned long now, long zone, # unsigned long *timePtr) @@ -147,7 +147,7 @@ declare 32 { int TclGetFrame(Tcl_Interp *interp, const char *str, CallFrame **framePtrPtr) } -# Removed in Tcl 8.5 +# Removed in 8.5: #declare 33 { # TclCmdProcType TclGetInterpProc(void) #} @@ -160,7 +160,7 @@ declare 34 { # Tcl_Obj *TclGetIndexedScalar(Tcl_Interp *interp, int localIndex, # int flags) #} -# Removed in 8.6a2 +# Removed in 8.6a2: #declare 36 { # int TclGetLong(Tcl_Interp *interp, const char *str, long *longPtr) #} @@ -185,7 +185,7 @@ declare 41 { declare 42 { CONST86 char *TclpGetUserHome(const char *name, Tcl_DString *bufferPtr) } -# Removed in Tcl 8.5a2 +# Removed in 8.5a2: #declare 43 { # int TclGlobalInvoke(Tcl_Interp *interp, int argc, CONST84 char **argv, # int flags) @@ -220,7 +220,7 @@ declare 50 { declare 51 { int TclInterpInit(Tcl_Interp *interp) } -# Removed in Tcl 8.5a2 +# Removed in 8.5a2: #declare 52 { # int TclInvoke(Tcl_Interp *interp, int argc, CONST84 char **argv, # int flags) @@ -273,7 +273,7 @@ declare 64 { int TclObjInvoke(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int flags) } -# Removed in Tcl 8.5a2 +# Removed in 8.5a2: #declare 65 { # int TclObjInvokeGlobal(Tcl_Interp *interp, int objc, # Tcl_Obj *const objv[], int flags) @@ -313,9 +313,7 @@ declare 75 { declare 76 { unsigned long TclpGetSeconds(void) } - -# deprecated -declare 77 { +declare 77 {deprecated {}} { void TclpGetTime(Tcl_Time *time) } # Removed in 8.6: @@ -380,7 +378,7 @@ declare 92 { declare 93 { void TclProcDeleteProc(ClientData clientData) } -# Removed in Tcl 8.5: +# Removed in 8.5: #declare 94 { # int TclProcInterpProc(ClientData clientData, Tcl_Interp *interp, # int argc, const char **argv) @@ -419,7 +417,7 @@ declare 103 { int TclSockGetPort(Tcl_Interp *interp, const char *str, const char *proto, int *portPtr) } -declare 104 { +declare 104 {deprecated {}} { int TclSockMinimumBuffersOld(int sock, int size) } # Replaced by Tcl_FSStat in 8.4: @@ -532,7 +530,7 @@ declare 131 { declare 132 { int TclpHasSockets(Tcl_Interp *interp) } -declare 133 { +declare 133 {deprecated {}} { struct tm *TclpGetDate(const time_t *time, int useGMT) } # Removed in 8.5 @@ -625,12 +623,10 @@ declare 156 { declare 157 { Var *TclVarTraceExists(Tcl_Interp *interp, const char *varName) } -# REMOVED (except from stub table) - use public Tcl_SetStartupScript() -declare 158 { +declare 158 {deprecated {use public Tcl_SetStartupScript()}} { void TclSetStartupScriptFileName(const char *filename) } -# REMOVED (except from stub table) - use public Tcl_GetStartupScript() -declare 159 { +declare 159 {deprecated {use public Tcl_GetStartupScript()}} { const char *TclGetStartupScriptFileName(void) } #declare 160 { @@ -676,13 +672,10 @@ declare 166 { int index, Tcl_Obj *valuePtr) } -# VFS-aware versions of Tcl*StartupScriptFileName (158 and 159 above) -# REMOVED (except from stub table) - use public Tcl_SetStartupScript() -declare 167 { +declare 167 {deprecated {use public Tcl_SetStartupScript()}} { void TclSetStartupScriptPath(Tcl_Obj *pathPtr) } -# REMOVED (except from stub table) - use public Tcl_GetStartupScript() -declare 168 { +declare 168 {deprecated {use public Tcl_GetStartupScript()}} { Tcl_Obj *TclGetStartupScriptPath(void) } # variant of Tcl_UtfNCmp that takes n as bytes, not chars @@ -730,7 +723,6 @@ declare 177 { void TclVarErrMsg(Tcl_Interp *interp, const char *part1, const char *part2, const char *operation, const char *reason) } -# TIP 338 made these public - now declared in tcl.h too declare 178 { void Tcl_SetStartupScript(Tcl_Obj *pathPtr, const char *encodingName) } @@ -748,12 +740,10 @@ declare 179 { # const char *file, int line) #} -# TclpGmtime and TclpLocaltime promoted to the generic interface from unix - -declare 182 { +declare 182 {deprecated {}} { struct tm *TclpLocaltime(const time_t *clock) } -declare 183 { +declare 183 {deprecated {}} { struct tm *TclpGmtime(const time_t *clock) } @@ -937,10 +927,7 @@ declare 234 { declare 235 { void TclInitVarHashTable(TclVarHashTable *tablePtr, Namespace *nsPtr) } - - -# TIP 337 made this one public -declare 236 { +declare 236 {deprecated {use Tcl_BackgroundException}} { void TclBackgroundException(Tcl_Interp *interp, int code) } @@ -1090,7 +1077,7 @@ declare 9 win { declare 10 win { Tcl_DirEntry *TclpReaddir(DIR *dir) } -# Removed in 8.3.1 (for Win32s only) +# Removed in 8.3.1 (for Win32s only): #declare 10 win { # int TclWinSynchSpawn(void *args, int type, void **trans, Tcl_Pid *pidPtr) #} @@ -1140,7 +1127,6 @@ declare 19 win { declare 20 win { void TclWinAddProcess(HANDLE hProcess, DWORD id) } -# new for 8.4.20+/8.5.12+ declare 21 win { char *TclpInetNtoa(struct in_addr addr) } diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index 5bccfe5..4244362 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -75,7 +75,8 @@ EXTERN void TclCleanupCommand(Command *cmdPtr); EXTERN int TclCopyAndCollapse(int count, const char *src, char *dst); /* 8 */ -EXTERN int TclCopyChannelOld(Tcl_Interp *interp, +TCL_DEPRECATED("") +int TclCopyChannelOld(Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, int toRead, Tcl_Obj *cmdPtr); /* 9 */ @@ -218,7 +219,8 @@ EXTERN unsigned long TclpGetClicks(void); /* 76 */ EXTERN unsigned long TclpGetSeconds(void); /* 77 */ -EXTERN void TclpGetTime(Tcl_Time *time); +TCL_DEPRECATED("") +void TclpGetTime(Tcl_Time *time); /* Slot 78 is reserved */ /* Slot 79 is reserved */ /* Slot 80 is reserved */ @@ -267,7 +269,8 @@ EXTERN void TclSetupEnv(Tcl_Interp *interp); EXTERN int TclSockGetPort(Tcl_Interp *interp, const char *str, const char *proto, int *portPtr); /* 104 */ -EXTERN int TclSockMinimumBuffersOld(int sock, int size); +TCL_DEPRECATED("") +int TclSockMinimumBuffersOld(int sock, int size); /* Slot 105 is reserved */ /* Slot 106 is reserved */ /* Slot 107 is reserved */ @@ -350,7 +353,8 @@ EXTERN void Tcl_SetNamespaceResolvers( /* 132 */ EXTERN int TclpHasSockets(Tcl_Interp *interp); /* 133 */ -EXTERN struct tm * TclpGetDate(const time_t *time, int useGMT); +TCL_DEPRECATED("") +struct tm * TclpGetDate(const time_t *time, int useGMT); /* Slot 134 is reserved */ /* Slot 135 is reserved */ /* Slot 136 is reserved */ @@ -401,9 +405,11 @@ EXTERN void TclRegError(Tcl_Interp *interp, const char *msg, EXTERN Var * TclVarTraceExists(Tcl_Interp *interp, const char *varName); /* 158 */ -EXTERN void TclSetStartupScriptFileName(const char *filename); +TCL_DEPRECATED("use public Tcl_SetStartupScript()") +void TclSetStartupScriptFileName(const char *filename); /* 159 */ -EXTERN const char * TclGetStartupScriptFileName(void); +TCL_DEPRECATED("use public Tcl_GetStartupScript()") +const char * TclGetStartupScriptFileName(void); /* Slot 160 is reserved */ /* 161 */ EXTERN int TclChannelTransform(Tcl_Interp *interp, @@ -422,9 +428,11 @@ EXTERN int TclListObjSetElement(Tcl_Interp *interp, Tcl_Obj *listPtr, int index, Tcl_Obj *valuePtr); /* 167 */ -EXTERN void TclSetStartupScriptPath(Tcl_Obj *pathPtr); +TCL_DEPRECATED("use public Tcl_SetStartupScript()") +void TclSetStartupScriptPath(Tcl_Obj *pathPtr); /* 168 */ -EXTERN Tcl_Obj * TclGetStartupScriptPath(void); +TCL_DEPRECATED("use public Tcl_GetStartupScript()") +Tcl_Obj * TclGetStartupScriptPath(void); /* 169 */ EXTERN int TclpUtfNcmp2(const char *s1, const char *s2, unsigned long n); @@ -464,9 +472,11 @@ EXTERN Tcl_Obj * Tcl_GetStartupScript(const char **encodingNamePtr); /* Slot 180 is reserved */ /* Slot 181 is reserved */ /* 182 */ -EXTERN struct tm * TclpLocaltime(const time_t *clock); +TCL_DEPRECATED("") +struct tm * TclpLocaltime(const time_t *clock); /* 183 */ -EXTERN struct tm * TclpGmtime(const time_t *clock); +TCL_DEPRECATED("") +struct tm * TclpGmtime(const time_t *clock); /* Slot 184 is reserved */ /* Slot 185 is reserved */ /* Slot 186 is reserved */ @@ -570,7 +580,8 @@ EXTERN Var * TclVarHashCreateVar(TclVarHashTable *tablePtr, EXTERN void TclInitVarHashTable(TclVarHashTable *tablePtr, Namespace *nsPtr); /* 236 */ -EXTERN void TclBackgroundException(Tcl_Interp *interp, int code); +TCL_DEPRECATED("use Tcl_BackgroundException") +void TclBackgroundException(Tcl_Interp *interp, int code); /* 237 */ EXTERN int TclResetCancellation(Tcl_Interp *interp, int force); /* 238 */ @@ -652,7 +663,7 @@ typedef struct TclIntStubs { int (*tclCleanupChildren) (Tcl_Interp *interp, int numPids, Tcl_Pid *pidPtr, Tcl_Channel errorChan); /* 5 */ void (*tclCleanupCommand) (Command *cmdPtr); /* 6 */ int (*tclCopyAndCollapse) (int count, const char *src, char *dst); /* 7 */ - int (*tclCopyChannelOld) (Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, int toRead, Tcl_Obj *cmdPtr); /* 8 */ + TCL_DEPRECATED_API("") int (*tclCopyChannelOld) (Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, int toRead, Tcl_Obj *cmdPtr); /* 8 */ int (*tclCreatePipeline) (Tcl_Interp *interp, int argc, const char **argv, Tcl_Pid **pidArrayPtr, TclFile *inPipePtr, TclFile *outPipePtr, TclFile *errFilePtr); /* 9 */ int (*tclCreateProc) (Tcl_Interp *interp, Namespace *nsPtr, const char *procName, Tcl_Obj *argsPtr, Tcl_Obj *bodyPtr, Proc **procPtrPtr); /* 10 */ void (*tclDeleteCompiledLocalVars) (Interp *iPtr, CallFrame *framePtr); /* 11 */ @@ -721,7 +732,7 @@ typedef struct TclIntStubs { void (*tclpFree) (char *ptr); /* 74 */ unsigned long (*tclpGetClicks) (void); /* 75 */ unsigned long (*tclpGetSeconds) (void); /* 76 */ - void (*tclpGetTime) (Tcl_Time *time); /* 77 */ + TCL_DEPRECATED_API("") void (*tclpGetTime) (Tcl_Time *time); /* 77 */ void (*reserved78)(void); void (*reserved79)(void); void (*reserved80)(void); @@ -748,7 +759,7 @@ typedef struct TclIntStubs { CONST86 char * (*tclSetPreInitScript) (const char *string); /* 101 */ void (*tclSetupEnv) (Tcl_Interp *interp); /* 102 */ int (*tclSockGetPort) (Tcl_Interp *interp, const char *str, const char *proto, int *portPtr); /* 103 */ - int (*tclSockMinimumBuffersOld) (int sock, int size); /* 104 */ + TCL_DEPRECATED_API("") int (*tclSockMinimumBuffersOld) (int sock, int size); /* 104 */ void (*reserved105)(void); void (*reserved106)(void); void (*reserved107)(void); @@ -777,7 +788,7 @@ typedef struct TclIntStubs { int (*tcl_RemoveInterpResolvers) (Tcl_Interp *interp, const char *name); /* 130 */ void (*tcl_SetNamespaceResolvers) (Tcl_Namespace *namespacePtr, Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc); /* 131 */ int (*tclpHasSockets) (Tcl_Interp *interp); /* 132 */ - struct tm * (*tclpGetDate) (const time_t *time, int useGMT); /* 133 */ + TCL_DEPRECATED_API("") struct tm * (*tclpGetDate) (const time_t *time, int useGMT); /* 133 */ void (*reserved134)(void); void (*reserved135)(void); void (*reserved136)(void); @@ -802,8 +813,8 @@ typedef struct TclIntStubs { void (*reserved155)(void); void (*tclRegError) (Tcl_Interp *interp, const char *msg, int status); /* 156 */ Var * (*tclVarTraceExists) (Tcl_Interp *interp, const char *varName); /* 157 */ - void (*tclSetStartupScriptFileName) (const char *filename); /* 158 */ - const char * (*tclGetStartupScriptFileName) (void); /* 159 */ + TCL_DEPRECATED_API("use public Tcl_SetStartupScript()") void (*tclSetStartupScriptFileName) (const char *filename); /* 158 */ + TCL_DEPRECATED_API("use public Tcl_GetStartupScript()") const char * (*tclGetStartupScriptFileName) (void); /* 159 */ void (*reserved160)(void); int (*tclChannelTransform) (Tcl_Interp *interp, Tcl_Channel chan, Tcl_Obj *cmdObjPtr); /* 161 */ void (*tclChannelEventScriptInvoker) (ClientData clientData, int flags); /* 162 */ @@ -811,8 +822,8 @@ typedef struct TclIntStubs { void (*tclExpandCodeArray) (void *envPtr); /* 164 */ void (*tclpSetInitialEncodings) (void); /* 165 */ int (*tclListObjSetElement) (Tcl_Interp *interp, Tcl_Obj *listPtr, int index, Tcl_Obj *valuePtr); /* 166 */ - void (*tclSetStartupScriptPath) (Tcl_Obj *pathPtr); /* 167 */ - Tcl_Obj * (*tclGetStartupScriptPath) (void); /* 168 */ + TCL_DEPRECATED_API("use public Tcl_SetStartupScript()") void (*tclSetStartupScriptPath) (Tcl_Obj *pathPtr); /* 167 */ + TCL_DEPRECATED_API("use public Tcl_GetStartupScript()") Tcl_Obj * (*tclGetStartupScriptPath) (void); /* 168 */ int (*tclpUtfNcmp2) (const char *s1, const char *s2, unsigned long n); /* 169 */ int (*tclCheckInterpTraces) (Tcl_Interp *interp, const char *command, int numChars, Command *cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *const objv[]); /* 170 */ int (*tclCheckExecutionTraces) (Tcl_Interp *interp, const char *command, int numChars, Command *cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *const objv[]); /* 171 */ @@ -826,8 +837,8 @@ typedef struct TclIntStubs { Tcl_Obj * (*tcl_GetStartupScript) (const char **encodingNamePtr); /* 179 */ void (*reserved180)(void); void (*reserved181)(void); - struct tm * (*tclpLocaltime) (const time_t *clock); /* 182 */ - struct tm * (*tclpGmtime) (const time_t *clock); /* 183 */ + TCL_DEPRECATED_API("") struct tm * (*tclpLocaltime) (const time_t *clock); /* 182 */ + TCL_DEPRECATED_API("") struct tm * (*tclpGmtime) (const time_t *clock); /* 183 */ void (*reserved184)(void); void (*reserved185)(void); void (*reserved186)(void); @@ -880,7 +891,7 @@ typedef struct TclIntStubs { void (*tclGetSrcInfoForPc) (CmdFrame *contextPtr); /* 233 */ Var * (*tclVarHashCreateVar) (TclVarHashTable *tablePtr, const char *key, int *newPtr); /* 234 */ void (*tclInitVarHashTable) (TclVarHashTable *tablePtr, Namespace *nsPtr); /* 235 */ - void (*tclBackgroundException) (Tcl_Interp *interp, int code); /* 236 */ + TCL_DEPRECATED_API("use Tcl_BackgroundException") void (*tclBackgroundException) (Tcl_Interp *interp, int code); /* 236 */ int (*tclResetCancellation) (Tcl_Interp *interp, int force); /* 237 */ int (*tclNRInterpProc) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 238 */ int (*tclNRInterpProcCore) (Tcl_Interp *interp, Tcl_Obj *procNameObj, int skip, ProcErrorProc *errorProc); /* 239 */ @@ -1356,7 +1367,7 @@ extern const TclIntStubs *tclIntStubsPtr; #undef TclSetStartupScriptPath #undef TclBackgroundException -#if defined(USE_TCL_STUBS) && defined(TCL_NO_DEPRECATED) +#if defined(USE_TCL_STUBS) # undef Tcl_SetStartupScript # define Tcl_SetStartupScript \ (tclStubsPtr->tcl_SetStartupScript) /* 622 */ -- cgit v0.12 From 0fc6533fcba4c33f7364f789fa22ea0793783995 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 13 Nov 2017 10:49:25 +0000 Subject: No longer mark Tcl_EvalFile() as obsolete, since it will continue to be supported in Tcl 9.0 --- generic/tcl.decls | 1 - generic/tclIOUtil.c | 1 - 2 files changed, 2 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index 92ccdcf..6fbf45f 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -468,7 +468,6 @@ declare 128 { declare 129 { int Tcl_Eval(Tcl_Interp *interp, const char *script) } -# This is obsolete, use Tcl_FSEvalFile declare 130 { int Tcl_EvalFile(Tcl_Interp *interp, const char *fileName) } diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index 6465931..a124406 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -254,7 +254,6 @@ Tcl_GetCwd( } } -/* Obsolete */ int Tcl_EvalFile( Tcl_Interp *interp, /* Interpreter in which to process file. */ -- cgit v0.12 From a7b6d6094829c332ba8c551876a64b0226148c93 Mon Sep 17 00:00:00 2001 From: aku Date: Mon, 13 Nov 2017 18:58:16 +0000 Subject: Ticket [5d65e65036]. My fix. Do not skip the second check for stable versions even when the main check fails. Avoided radical changes to the structure (kept single search loop, with selection after). --- generic/tclPkg.c | 91 ++++++++++++++++++++++++++++++++++++-------------------- 1 file changed, 58 insertions(+), 33 deletions(-) diff --git a/generic/tclPkg.c b/generic/tclPkg.c index 52f33c3..d3dd584 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -349,7 +349,7 @@ PkgRequireCore( Interp *iPtr = (Interp *) interp; Package *pkgPtr; PkgAvail *availPtr, *bestPtr, *bestStablePtr; - char *availVersion, *bestVersion; + char *availVersion, *bestVersion, *bestStableVersion; /* Internal rep. of versions */ int availStable, code, satisfies, pass; char *script, *pkgVersionI; @@ -395,6 +395,7 @@ PkgRequireCore( bestPtr = NULL; bestStablePtr = NULL; bestVersion = NULL; + bestStableVersion = NULL; for (availPtr = pkgPtr->availPtr; availPtr != NULL; availPtr = availPtr->nextPtr) { @@ -408,58 +409,82 @@ PkgRequireCore( continue; } - + + /* Check satisfaction of requirements before considering the current version further. */ + if (reqc > 0) { + satisfies = SomeRequirementSatisfied(availVersion, reqc, reqv); + if (!satisfies) { + ckfree(availVersion); + availVersion = NULL; + continue; + } + } + if (bestPtr != NULL) { int res = CompareVersions(availVersion, bestVersion, NULL); /* - * Note: Use internal reps! + * Note: Used internal reps in the comparison! */ - if (res <= 0) { + if (res > 0) { /* - * The version of the package sought is not as good as the - * currently selected version. Ignore it. + * The version of the package sought is better than the + * currently selected version. */ - - ckfree(availVersion); - availVersion = NULL; - continue; + goto newbest; } - } - - /* We have found a version which is better than our max. */ - - if (reqc > 0) { - /* Check satisfaction of requirements. */ + } else { + newbest: + /* We have found a version which is better than our max. */ - satisfies = SomeRequirementSatisfied(availVersion, reqc, reqv); - if (!satisfies) { - ckfree(availVersion); - availVersion = NULL; - continue; - } + bestPtr = availPtr; + CheckVersionAndConvert(interp, bestPtr->version, &bestVersion, NULL); } - bestPtr = availPtr; - - if (bestVersion != NULL) { - ckfree(bestVersion); + if (!availStable) { + ckfree(availVersion); + availVersion = NULL; + continue; } - bestVersion = availVersion; - /* - * If this new best version is stable then it also has to be - * better than the max stable version found so far. - */ + if (bestStablePtr != NULL) { + int res = CompareVersions(availVersion, bestStableVersion, NULL); + + /* + * Note: Used internal reps in the comparison! + */ - if (availStable) { + if (res > 0) { + /* + * This stable version of the package sought is better + * than the currently selected stable version. + */ + goto newstable; + } + } else { + newstable: + /* We have found a stable version which is better than our max stable. */ bestStablePtr = availPtr; + CheckVersionAndConvert(interp, bestStablePtr->version, &bestStableVersion, NULL); } - } + ckfree(availVersion); + availVersion = NULL; + } /* end for */ + + /* + * Clean up memorized internal reps, if any. + */ + if (bestVersion != NULL) { ckfree(bestVersion); + bestVersion = NULL; + } + + if (bestStableVersion != NULL) { + ckfree(bestStableVersion); + bestStableVersion = NULL; } /* -- cgit v0.12 From 9f6573581348d2a8ceb4647ad9781d35644aee8b Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 14 Nov 2017 17:09:49 +0000 Subject: Repair lost of broken [package prefer] testing. --- tests/package.test | 125 ++++++++++++++++++++++++++++++++++++++++++----------- 1 file changed, 100 insertions(+), 25 deletions(-) diff --git a/tests/package.test b/tests/package.test index faa15ec..bb938b8 100644 --- a/tests/package.test +++ b/tests/package.test @@ -20,18 +20,19 @@ if {"::tcltest" ni [namespace children]} { ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] -testConstraint testpreferstable [llength [info commands testpreferstable]] - # Do all this in a slave interp to avoid garbaging the package list set i [interp create] tcltest::loadIntoSlaveInterpreter $i {*}$argv +load {} Tcltest $i interp eval $i { namespace import -force ::tcltest::* -package forget {*}[package names] +#package forget {*}[package names] set oldPkgUnknown [package unknown] package unknown {} set oldPath $auto_path set auto_path "" + +testConstraint testpreferstable [llength [info commands testpreferstable]] test package-1.1 {pkg::create gives error on insufficient args} -body { ::pkg::create @@ -575,15 +576,23 @@ test package-3.44 {Tcl_PkgRequire: exact version matching (1578344)} -setup { package forget demo } -result {version conflict for package "demo": have 1.2.3, need exactly 1.2} test package-3.50 {Tcl_PkgRequire procedure, picking best stable version} -constraints testpreferstable -setup { + interp create child + load {} Tcltest child + child eval { testpreferstable package forget t set x xxx + } } -body { + child eval { foreach i {1.4 3.4 4.0a1 2.3 2.4 2.2} { package ifneeded t $i "set x $i; package provide t $i" } package require t set x + } +} -cleanup { + interp delete child } -result {3.4} test package-3.51 {Tcl_PkgRequire procedure, picking best stable version} -setup { package forget t @@ -621,28 +630,51 @@ test pkg-3.53 {Tcl_PkgRequire procedure, picking best stable version} -constrain test package-4.1 {Tcl_PackageCmd procedure} -returnCodes error -body { package } -result {wrong # args: should be "package option ?arg ...?"} -test package-4.2 {Tcl_PackageCmd procedure, "forget" option} { +test package-4.2 {Tcl_PackageCmd procedure, "forget" option} -setup { + interp create child +} -body { + child eval { package forget {*}[package names] package names -} {} -test package-4.3 {Tcl_PackageCmd procedure, "forget" option} { + } +} -cleanup { + interp delete child +} -result {} +test package-4.3 {Tcl_PackageCmd procedure, "forget" option} -setup { + interp create child +} -body { + child eval { package forget {*}[package names] package forget foo -} {} + } +} -cleanup { + interp delete child +} -result {} test package-4.4 {Tcl_PackageCmd procedure, "forget" option} -setup { + interp create child + child eval { package forget {*}[package names] set result {} + } } -body { + child eval { package ifneeded t 1.1 {first script} package ifneeded t 2.3 {second script} package ifneeded x 1.4 {x's script} lappend result [lsort [package names]] [package versions t] package forget t lappend result [lsort [package names]] [package versions t] + } +} -cleanup { + interp delete child } -result {{t x} {1.1 2.3} x {}} test package-4.5 {Tcl_PackageCmd procedure, "forget" option} -setup { + interp create child + child eval { package forget {*}[package names] + } } -body { + child eval { package ifneeded a 1.1 {first script} package ifneeded b 2.3 {second script} package ifneeded c 1.4 {third script} @@ -650,6 +682,9 @@ test package-4.5 {Tcl_PackageCmd procedure, "forget" option} -setup { set result [list [lsort [package names]]] package forget a c lappend result [lsort [package names]] + } +} -cleanup { + interp delete child } -result {{a b c} b} test package-4.5.1 {Tcl_PackageCmd procedure, "forget" option} -body { # Test for Bug 415273 @@ -668,28 +703,55 @@ test package-4.7 {Tcl_PackageCmd procedure, "ifneeded" option} -body { test package-4.8 {Tcl_PackageCmd procedure, "ifneeded" option} -body { package ifneeded t xyz } -returnCodes error -result {expected version number but got "xyz"} -test package-4.9 {Tcl_PackageCmd procedure, "ifneeded" option} { +test package-4.9 {Tcl_PackageCmd procedure, "ifneeded" option} -setup { + interp create child +} -body { + child eval { package forget {*}[package names] list [package ifneeded foo 1.1] [package names] -} {{} {}} + } +} -cleanup { + interp delete child +} -result {{} {}} test package-4.10 {Tcl_PackageCmd procedure, "ifneeded" option} -setup { - package forget t + interp create child + child eval { + package forget {*}[package names] + } } -body { + child eval { package ifneeded t 1.4 "script for t 1.4" list [package names] [package ifneeded t 1.4] [package versions t] + } +} -cleanup { + interp delete child } -result {t {script for t 1.4} 1.4} test package-4.11 {Tcl_PackageCmd procedure, "ifneeded" option} -setup { - package forget t + interp create child + child eval { + package forget {*}[package names] + } } -body { + child eval { package ifneeded t 1.4 "script for t 1.4" list [package ifneeded t 1.5] [package names] [package versions t] + } +} -cleanup { + interp delete child } -result {{} t 1.4} test package-4.12 {Tcl_PackageCmd procedure, "ifneeded" option} -setup { - package forget t + interp create child + child eval { + package forget {*}[package names] + } } -body { + child eval { package ifneeded t 1.4 "script for t 1.4" package ifneeded t 1.4 "second script for t 1.4" list [package ifneeded t 1.4] [package names] [package versions t] + } +} -cleanup { + interp delete child } -result {{second script for t 1.4} t 1.4} test package-4.13 {Tcl_PackageCmd procedure, "ifneeded" option} -setup { package forget t @@ -702,18 +764,31 @@ test package-4.13 {Tcl_PackageCmd procedure, "ifneeded" option} -setup { test package-4.14 {Tcl_PackageCmd procedure, "names" option} -body { package names a } -returnCodes error -result {wrong # args: should be "package names"} -test package-4.15 {Tcl_PackageCmd procedure, "names" option} { +test package-4.15 {Tcl_PackageCmd procedure, "names" option} -setup { + interp create child +} -body { + child eval { package forget {*}[package names] package names -} {} + } +} -cleanup { + interp delete child +} -result {} test package-4.16 {Tcl_PackageCmd procedure, "names" option} -setup { + interp create child + child eval { package forget {*}[package names] + } } -body { + child eval { package ifneeded x 1.2 {dummy} package provide x 1.3 package provide y 2.4 catch {package require z 47.16} lsort [package names] + } +} -cleanup { + interp delete child } -result {x y} test package-4.17 {Tcl_PackageCmd procedure, "provide" option} -body { package provide @@ -1251,11 +1326,9 @@ proc prefer {args} { } } -test package-13.0 {package prefer defaults} -constraints testpreferstable -setup { - testpreferstable -} -body { +test package-13.0 {package prefer defaults} -body { prefer -} -result 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 @@ -1272,23 +1345,25 @@ test package-14.1 {bogus argument} -returnCodes error -body { test package-15.0 {set, keep} -constraints testpreferstable -setup { testpreferstable -} -body {package prefer stable} -result stable +} -body {package prefer} -result stable test package-15.1 {set stable, keep} -constraints testpreferstable -setup { testpreferstable -} -body {prefer stable} -result {stable stable} +} -body {package prefer stable} -result stable test package-15.2 {set latest, change} -constraints testpreferstable -setup { testpreferstable -} -body {prefer latest} -result {stable latest} +} -body {package prefer latest} -result latest test package-15.3 {set latest, keep} -constraints testpreferstable -setup { testpreferstable } -body { - prefer latest latest -} -result {stable latest latest} + package prefer latest + package prefer latest +} -result latest test package-15.4 {set stable, rejected} -constraints testpreferstable -setup { testpreferstable } -body { - prefer latest stable -} -result {stable latest latest} + package prefer latest + package prefer stable +} -result latest rename prefer {} -- cgit v0.12 From 59ebc49f0f9163be7bcbd33b23e6eae865540ab4 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 15 Nov 2017 08:54:13 +0000 Subject: Change signature of (internal) TclScanElement() function. This saves memory allocation and the possibility for panic's in dict and list handling, requiring 1/4 of memory for internal allocation of temporary storage. No change to external API. --- generic/tclDictObj.c | 9 +++------ generic/tclIndexObj.c | 3 ++- generic/tclInt.h | 2 +- generic/tclListObj.c | 6 +++--- generic/tclUtil.c | 27 ++++++--------------------- 5 files changed, 15 insertions(+), 32 deletions(-) diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index d15255f..2eff1ff 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -487,15 +487,14 @@ static void UpdateStringOfDict( Tcl_Obj *dictPtr) { -#define LOCAL_SIZE 20 - int localFlags[LOCAL_SIZE], *flagPtr = NULL; +#define LOCAL_SIZE 64 + char localFlags[LOCAL_SIZE], *flagPtr = NULL; Dict *dict = DICT(dictPtr); ChainEntry *cPtr; Tcl_Obj *keyPtr, *valuePtr; int i, length, bytesNeeded = 0; const char *elem; char *dst; - const int maxFlags = UINT_MAX / sizeof(int); /* * This field is the most useful one in the whole hash structure, and it @@ -517,10 +516,8 @@ UpdateStringOfDict( if (numElems <= LOCAL_SIZE) { flagPtr = localFlags; - } else if (numElems > maxFlags) { - Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } else { - flagPtr = ckalloc(numElems * sizeof(int)); + flagPtr = ckalloc(numElems); } for (i=0,cPtr=dict->entryChainHead; inextPtr) { /* diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index 0e0ddc9..30c33f1 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -878,7 +878,8 @@ Tcl_WrongNumArgs( * NULL. */ { Tcl_Obj *objPtr; - int i, len, elemLen, flags; + int i, len, elemLen; + char flags; Interp *iPtr = (Interp *) interp; const char *elementStr; diff --git a/generic/tclInt.h b/generic/tclInt.h index 1908e32..91c8b96 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3106,7 +3106,7 @@ MODULE_SCOPE int TclReToGlob(Tcl_Interp *interp, const char *reStr, int reStrLen, Tcl_DString *dsPtr, int *flagsPtr, int *quantifiersFoundPtr); MODULE_SCOPE int TclScanElement(const char *string, int length, - int *flagPtr); + char *flagPtr); MODULE_SCOPE void TclSetBgErrorHandler(Tcl_Interp *interp, Tcl_Obj *cmdPrefix); MODULE_SCOPE void TclSetBignumIntRep(Tcl_Obj *objPtr, diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 344d0fd..3a1555d 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -1957,8 +1957,8 @@ static void UpdateStringOfList( Tcl_Obj *listPtr) /* List object with string rep to update. */ { -# define LOCAL_SIZE 20 - int localFlags[LOCAL_SIZE], *flagPtr = NULL; +# define LOCAL_SIZE 64 + char localFlags[LOCAL_SIZE], *flagPtr = NULL; List *listRepPtr = ListRepPtr(listPtr); int numElems = listRepPtr->elemCount; int i, length, bytesNeeded = 0; @@ -1995,7 +1995,7 @@ UpdateStringOfList( * We know numElems <= LIST_MAX, so this is safe. */ - flagPtr = ckalloc(numElems * sizeof(int)); + flagPtr = ckalloc(numElems); } elemPtrs = &listRepPtr->elements; for (i = 0; i < numElems; i++) { diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 0eddb00..feee9c5 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -974,7 +974,7 @@ Tcl_ScanCountedElement( int *flagPtr) /* Where to store information to guide * Tcl_ConvertElement. */ { - int flags = CONVERT_ANY; + char flags = CONVERT_ANY; int numBytes = TclScanElement(src, length, &flags); *flagPtr = flags; @@ -1015,7 +1015,7 @@ int TclScanElement( const char *src, /* String to convert to Tcl list element. */ int length, /* Number of bytes in src, or -1. */ - int *flagPtr) /* Where to store information to guide + char *flagPtr) /* Where to store information to guide * Tcl_ConvertElement. */ { const char *p = src; @@ -1547,11 +1547,10 @@ Tcl_Merge( int argc, /* How many strings to merge. */ const char *const *argv) /* Array of string values. */ { -#define LOCAL_SIZE 20 - int localFlags[LOCAL_SIZE], *flagPtr = NULL; +#define LOCAL_SIZE 64 + char localFlags[LOCAL_SIZE], *flagPtr = NULL; int i, bytesNeeded = 0; char *result, *dst; - const int maxFlags = UINT_MAX / sizeof(int); /* * Handle empty list case first, so logic of the general case can be @@ -1570,22 +1569,8 @@ Tcl_Merge( if (argc <= LOCAL_SIZE) { flagPtr = localFlags; - } else if (argc > maxFlags) { - /* - * We cannot allocate a large enough flag array to format this list in - * one pass. We could imagine converting this routine to a multi-pass - * implementation, but for sizeof(int) == 4, the limit is a max of - * 2^30 list elements and since each element is at least one byte - * formatted, and requires one byte space between it and the next one, - * that a minimum space requirement of 2^31 bytes, which is already - * INT_MAX. If we tried to format a list of > maxFlags elements, we're - * just going to overflow the size limits on the formatted string - * anyway, so just issue that same panic early. - */ - - Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } else { - flagPtr = ckalloc(argc * sizeof(int)); + flagPtr = ckalloc(argc); } for (i = 0; i < argc; i++) { flagPtr[i] = ( i ? TCL_DONT_QUOTE_HASH : 0 ); @@ -2717,7 +2702,7 @@ Tcl_DStringAppendElement( { char *dst = dsPtr->string + dsPtr->length; int needSpace = TclNeedSpace(dsPtr->string, dst); - int flags = needSpace ? TCL_DONT_QUOTE_HASH : 0; + char flags = needSpace ? TCL_DONT_QUOTE_HASH : 0; int newSize = dsPtr->length + needSpace + TclScanElement(element, -1, &flags); -- cgit v0.12 From 346cce57455de92d12fcef5ea4115a9657458b84 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 15 Nov 2017 09:42:07 +0000 Subject: Remove compat/float.h and related machinery. The last system known where this was needed was SunOS-4, which is not supported by Tcl any more for a long ... long time .... Also, fix a typo in generic/tclInt.h and remove some end-of-line spacing. --- compat/float.h | 14 -------------- generic/tclBasic.c | 2 +- generic/tclInt.h | 2 +- generic/tclPkg.c | 6 +++--- unix/configure | 10 ---------- unix/tcl.m4 | 1 - unix/tclConfig.h.in | 3 --- unix/tclUnixPort.h | 5 +---- win/tcl.dsp | 4 ---- win/tclWinThrd.c | 2 -- 10 files changed, 6 insertions(+), 43 deletions(-) delete mode 100644 compat/float.h diff --git a/compat/float.h b/compat/float.h deleted file mode 100644 index 411edbf..0000000 --- a/compat/float.h +++ /dev/null @@ -1,14 +0,0 @@ -/* - * float.h -- - * - * This is a dummy header file to #include in Tcl when there - * is no float.h in /usr/include. Right now this file is empty: - * Tcl contains #ifdefs to deal with the lack of definitions; - * all it needs is for the #include statement to work. - * - * Copyright (c) 1993 The Regents of the University of California. - * Copyright (c) 1994 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/generic/tclBasic.c b/generic/tclBasic.c index e6022ac..fe29db0 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -7722,7 +7722,7 @@ ExprRandFunc( iPtr->flags |= RAND_SEED_INITIALIZED; /* - * To ensure different seeds in different threads (bug #416643), + * To ensure different seeds in different threads (bug #416643), * take into consideration the thread this interp is running in. */ diff --git a/generic/tclInt.h b/generic/tclInt.h index 6426c21..23a20e6 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2922,7 +2922,7 @@ MODULE_SCOPE int TclFindDictElement(Tcl_Interp *interp, const char *dict, int dictLength, const char **elementPtr, const char **nextPtr, int *sizePtr, int *literalPtr); -/* TIP #280 - Modified token based evulation, with line information. */ +/* TIP #280 - Modified token based evaluation, with line information. */ MODULE_SCOPE int TclEvalEx(Tcl_Interp *interp, const char *script, int numBytes, int flags, int line, int *clNextOuter, const char *outerScript); diff --git a/generic/tclPkg.c b/generic/tclPkg.c index ea95320..fb721a0 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -480,7 +480,7 @@ PkgRequireCore( continue; } - + /* Check satisfaction of requirements before considering the current version further. */ if (reqc > 0) { satisfies = SomeRequirementSatisfied(availVersion, reqc, reqv); @@ -490,7 +490,7 @@ PkgRequireCore( continue; } } - + if (bestPtr != NULL) { int res = CompareVersions(availVersion, bestVersion, NULL); @@ -547,7 +547,7 @@ PkgRequireCore( /* * Clean up memorized internal reps, if any. */ - + if (bestVersion != NULL) { ckfree(bestVersion); bestVersion = NULL; diff --git a/unix/configure b/unix/configure index 129c283..51d694f 100755 --- a/unix/configure +++ b/unix/configure @@ -3733,16 +3733,6 @@ $as_echo "#define NO_DIRENT_H 1" >>confdefs.h fi - ac_fn_c_check_header_mongrel "$LINENO" "float.h" "ac_cv_header_float_h" "$ac_includes_default" -if test "x$ac_cv_header_float_h" = xyes; then : - -else - -$as_echo "#define NO_FLOAT_H 1" >>confdefs.h - -fi - - ac_fn_c_check_header_mongrel "$LINENO" "values.h" "ac_cv_header_values_h" "$ac_includes_default" if test "x$ac_cv_header_values_h" = xyes; then : diff --git a/unix/tcl.m4 b/unix/tcl.m4 index 45922e0..9aa3eb2 100644 --- a/unix/tcl.m4 +++ b/unix/tcl.m4 @@ -2078,7 +2078,6 @@ closedir(d); AC_DEFINE(NO_DIRENT_H, 1, [Do we have ?]) fi - AC_CHECK_HEADER(float.h, , [AC_DEFINE(NO_FLOAT_H, 1, [Do we have ?])]) AC_CHECK_HEADER(values.h, , [AC_DEFINE(NO_VALUES_H, 1, [Do we have ?])]) AC_CHECK_HEADER(stdlib.h, tcl_ok=1, tcl_ok=0) AC_EGREP_HEADER(strtol, stdlib.h, , tcl_ok=0) diff --git a/unix/tclConfig.h.in b/unix/tclConfig.h.in index adbc80d..28ce012 100644 --- a/unix/tclConfig.h.in +++ b/unix/tclConfig.h.in @@ -295,9 +295,6 @@ /* Do we have fd_set? */ #undef NO_FD_SET -/* Do we have ? */ -#undef NO_FLOAT_H - /* Do we have fstatfs()? */ #undef NO_FSTATFS diff --git a/unix/tclUnixPort.h b/unix/tclUnixPort.h index ba56089..8b766d6 100644 --- a/unix/tclUnixPort.h +++ b/unix/tclUnixPort.h @@ -181,13 +181,10 @@ extern int TclUnixSetBlockingMode(int fd, int mode); *--------------------------------------------------------------------------- */ -#ifndef NO_FLOAT_H -# include -#else +#include #ifndef NO_VALUES_H # include #endif -#endif #ifndef FLT_MAX # ifdef MAXFLOAT diff --git a/win/tcl.dsp b/win/tcl.dsp index 48eae9d..ad9c764 100644 --- a/win/tcl.dsp +++ b/win/tcl.dsp @@ -152,10 +152,6 @@ SOURCE=..\compat\fixstrtod.c # End Source File # Begin Source File -SOURCE=..\compat\float.h -# End Source File -# Begin Source File - SOURCE=..\compat\gettod.c # End Source File # Begin Source File diff --git a/win/tclWinThrd.c b/win/tclWinThrd.c index b9cde72..8c130a7 100644 --- a/win/tclWinThrd.c +++ b/win/tclWinThrd.c @@ -13,8 +13,6 @@ #include "tclWinInt.h" -#include - /* Workaround for mingw versions which don't provide this in float.h */ #ifndef _MCW_EM # define _MCW_EM 0x0008001F /* Error masks */ -- cgit v0.12 From 65007a4d02a35e26d92288bc5a20aa1bfde3696e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 16 Nov 2017 08:39:41 +0000 Subject: No longer document (even though it's only in an example) that Tcl_SavedResult is a struct, and that the internal representation of an int is stored in the object's internalRep.longValue member. That might no longer be true in the future. --- doc/Object.3 | 6 +++--- doc/SaveResult.3 | 11 +++++------ 2 files changed, 8 insertions(+), 9 deletions(-) diff --git a/doc/Object.3 b/doc/Object.3 index 4df6c1a..a7e06c8 100644 --- a/doc/Object.3 +++ b/doc/Object.3 @@ -3,7 +3,7 @@ '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" +'\" .TH Tcl_Obj 3 8.5 Tcl "Tcl Library Procedures" .so man.macros .BS @@ -94,7 +94,7 @@ Also, most Tcl values are only read and never modified. This is especially true for procedure arguments, which can be shared between the caller and the called procedure. Assignment and argument binding is done by -simply assigning a pointer to the value. +simply assigning a pointer to the value. Reference counting is used to determine when it is safe to reclaim an object's storage. .PP @@ -249,7 +249,7 @@ The \fBincr\fR command first gets an integer from \fIx\fR's object by calling \fBTcl_GetIntFromObj\fR. This procedure checks whether the object is already an integer object. Since it is not, it converts the object -by setting the object's \fIinternalRep.longValue\fR member +by setting the object's internal representation to the integer \fB123\fR and setting the object's \fItypePtr\fR to point to the integer Tcl_ObjType structure. diff --git a/doc/SaveResult.3 b/doc/SaveResult.3 index 74da9f4..0a2ee51 100644 --- a/doc/SaveResult.3 +++ b/doc/SaveResult.3 @@ -4,7 +4,7 @@ '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" +'\" .TH Tcl_SaveResult 3 8.1 Tcl "Tcl Library Procedures" .so man.macros .BS @@ -56,9 +56,9 @@ is called, Tcl will take care of memory management. .PP The second triplet stores the snapshot of only the interpreter result (not its complete state) in memory allocated by the caller. -These routines are passed a pointer to a \fBTcl_SavedResult\fR structure +These routines are passed a pointer to \fBTcl_SavedResult\fR that is used to store enough information to restore the interpreter result. -This structure can be allocated on the stack of the calling +\fBTcl_SavedResult\fR can be allocated on the stack of the calling procedure. These routines do not save the state of any error information in the interpreter (e.g. the \fB\-errorcode\fR or \fB\-errorinfo\fR return options, when an error is in progress). @@ -69,7 +69,7 @@ a superset of the functions provided by the other routines, any new code should only make use of the more powerful routines. The older, weaker routines \fBTcl_SaveResult\fR, \fBTcl_RestoreResult\fR, and \fBTcl_DiscardResult\fR continue to exist only for the sake -of existing programs that may already be using them. +of existing programs that may already be using them. .PP \fBTcl_SaveInterpState\fR takes a snapshot of those portions of interpreter state that make up the full result of script evaluation. @@ -118,7 +118,6 @@ uninitialized state and cannot be used until another call to Once \fBTcl_SaveResult\fR is called to save the interpreter result, either \fBTcl_RestoreResult\fR or \fBTcl_DiscardResult\fR must be called to properly clean up the -memory associated with the saved state. - +memory associated with the saved state. .SH KEYWORDS result, state, interp -- cgit v0.12 From ac3259b669c253852e4108c8da44a959fb1465a9 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 17 Nov 2017 08:32:16 +0000 Subject: Suggested patch for [4f51e1c5dc]: patch to correct linker flag sequence. Same change done for a few other platforms where it might matter. --- unix/configure | 8 ++++---- unix/tcl.m4 | 8 ++++---- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/unix/configure b/unix/configure index 39076a4..888fe0c 100755 --- a/unix/configure +++ b/unix/configure @@ -6954,7 +6954,7 @@ echo "$as_me: error: CYGWIN compile is only supported with --enable-threads" >&2 LDFLAGS="$LDFLAGS -Wl,--export-dynamic" SHLIB_CFLAGS="-fPIC" SHLIB_SUFFIX=".so" - SHLIB_LD='${CC} -shared ${CFLAGS} ${LDFLAGS}' + SHLIB_LD='${CC} ${CFLAGS} ${LDFLAGS} -shared' DL_OBJS="tclLoadDl.o" DL_LIBS="-lroot" echo "$as_me:$LINENO: checking for inet_ntoa in -lnetwork" >&5 @@ -7383,7 +7383,7 @@ fi # get rid of the warnings. #CFLAGS_OPTIMIZE="${CFLAGS_OPTIMIZE} -D__NO_STRING_INLINES -D__NO_MATH_INLINES" - SHLIB_LD='${CC} -shared ${CFLAGS} ${LDFLAGS}' + SHLIB_LD='${CC} ${CFLAGS} ${LDFLAGS} -shared' DL_OBJS="tclLoadDl.o" DL_LIBS="-ldl" LDFLAGS="$LDFLAGS -Wl,--export-dynamic" @@ -7525,7 +7525,7 @@ fi SHLIB_CFLAGS="-fpic" ;; esac - SHLIB_LD='${CC} -shared ${SHLIB_CFLAGS}' + SHLIB_LD='${CC} ${SHLIB_CFLAGS} -shared' SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" @@ -7554,7 +7554,7 @@ fi NetBSD-*) # NetBSD has ELF and can use 'cc -shared' to build shared libs SHLIB_CFLAGS="-fPIC" - SHLIB_LD='${CC} -shared ${SHLIB_CFLAGS}' + SHLIB_LD='${CC} ${SHLIB_CFLAGS} -shared' SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" diff --git a/unix/tcl.m4 b/unix/tcl.m4 index 8a802fb..6ca2047 100644 --- a/unix/tcl.m4 +++ b/unix/tcl.m4 @@ -1258,7 +1258,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ LDFLAGS="$LDFLAGS -Wl,--export-dynamic" SHLIB_CFLAGS="-fPIC" SHLIB_SUFFIX=".so" - SHLIB_LD='${CC} -shared ${CFLAGS} ${LDFLAGS}' + SHLIB_LD='${CC} ${CFLAGS} ${LDFLAGS} -shared' DL_OBJS="tclLoadDl.o" DL_LIBS="-lroot" AC_CHECK_LIB(network, inet_ntoa, [LIBS="$LIBS -lnetwork"]) @@ -1402,7 +1402,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ # get rid of the warnings. #CFLAGS_OPTIMIZE="${CFLAGS_OPTIMIZE} -D__NO_STRING_INLINES -D__NO_MATH_INLINES" - SHLIB_LD='${CC} -shared ${CFLAGS} ${LDFLAGS}' + SHLIB_LD='${CC} ${CFLAGS} ${LDFLAGS} -shared' DL_OBJS="tclLoadDl.o" DL_LIBS="-ldl" LDFLAGS="$LDFLAGS -Wl,--export-dynamic" @@ -1473,7 +1473,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ SHLIB_CFLAGS="-fpic" ;; esac - SHLIB_LD='${CC} -shared ${SHLIB_CFLAGS}' + SHLIB_LD='${CC} ${SHLIB_CFLAGS} -shared' SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" @@ -1496,7 +1496,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ NetBSD-*) # NetBSD has ELF and can use 'cc -shared' to build shared libs SHLIB_CFLAGS="-fPIC" - SHLIB_LD='${CC} -shared ${SHLIB_CFLAGS}' + SHLIB_LD='${CC} ${SHLIB_CFLAGS} -shared' SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" -- cgit v0.12 From ff436137df3cce5d4e96e59c54a3f1211a3e8a33 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 17 Nov 2017 15:28:09 +0000 Subject: Fix [fab92486a1b05ba6f7cfe8677da95b9efb3beff0|fab92486a1]: Windows error 14 "Out of memory" mapping to Posix EFAULT "Bad address in system call argument" feels wrong --- win/tclWinError.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/win/tclWinError.c b/win/tclWinError.c index a74d2e2..c569d61 100644 --- a/win/tclWinError.c +++ b/win/tclWinError.c @@ -32,7 +32,7 @@ static CONST unsigned char errorTable[] = { ENOEXEC, /* ERROR_BAD_FORMAT 11 */ EACCES, /* ERROR_INVALID_ACCESS 12 */ EINVAL, /* ERROR_INVALID_DATA 13 */ - EFAULT, /* ERROR_OUT_OF_MEMORY 14 */ + ENOMEM, /* ERROR_OUT_OF_MEMORY 14 */ ENOENT, /* ERROR_INVALID_DRIVE 15 */ EACCES, /* ERROR_CURRENT_DIRECTORY 16 */ EXDEV, /* ERROR_NOT_SAME_DEVICE 17 */ -- cgit v0.12 From 3c942c50d91bc8ea58c64065922babf397943e8f Mon Sep 17 00:00:00 2001 From: pooryorick Date: Fri, 17 Nov 2017 22:30:06 +0000 Subject: Fix [16fe1b5807]: namespace ensemble command named ":" is mistakenly given the empty string as its name. --- generic/tclBasic.c | 105 +++++++++++++++++++++++++------------ generic/tclEnsemble.c | 140 +++++++++++++++++++++++++++++++------------------- generic/tclInt.h | 26 ++++++++++ generic/tclNamesp.c | 31 ++++++++++- generic/tclProc.c | 20 +------- tests/namespace.test | 18 +++++-- 6 files changed, 231 insertions(+), 109 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index fe29db0..334febc 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -2098,13 +2098,13 @@ Tcl_CreateCommand( hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &isNew); - if (isNew || deleted) { + if (isNew || deleted) { /* * isNew - No conflict with existing command. * deleted - We've already deleted a conflicting command */ break; - } + } /* An existing command conflicts. Try to delete it.. */ cmdPtr = Tcl_GetHashValue(hPtr); @@ -2245,64 +2245,81 @@ Tcl_CreateObjCommand( * name. */ ClientData clientData, /* Arbitrary value to pass to object * function. */ - Tcl_CmdDeleteProc *deleteProc) + Tcl_CmdDeleteProc *deleteProc /* If not NULL, gives a function to call when * this command is deleted. */ +) { Interp *iPtr = (Interp *) interp; - ImportRef *oldRefPtr = NULL; Namespace *nsPtr; - Command *cmdPtr; - Tcl_HashEntry *hPtr; const char *tail; - int isNew = 0, deleted = 0; - ImportedCmdData *dataPtr; if (iPtr->flags & DELETED) { /* * The interpreter is being deleted. Don't create any new commands; * it's not safe to muck with the interpreter anymore. */ - return (Tcl_Command) NULL; } /* + * Determine where the command should reside. If its name contains + * namespace qualifiers, we put it in the specified namespace; + * otherwise, we always put it in the global namespace. + */ + + if (strstr(cmdName, "::") != NULL) { + Namespace *dummy1, *dummy2; + + TclGetNamespaceForQualName(interp, cmdName, NULL, + TCL_CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail); + if ((nsPtr == NULL) || (tail == NULL)) { + return (Tcl_Command) NULL; + } + } else { + nsPtr = iPtr->globalNsPtr; + tail = cmdName; + } + + return tclCreateObjCommandInNs(interp, tail, (Tcl_Namespace *) nsPtr, + proc, clientData, deleteProc); +} + +Tcl_Command tclCreateObjCommandInNs ( + Tcl_Interp *interp, + const char *cmdName, /* Name of command, without any namespace components */ + Tcl_Namespace *namespace, /* The namespace to create the command in */ + Tcl_ObjCmdProc *proc, /* Object-based function to associate with + * name. */ + ClientData clientData, /* Arbitrary value to pass to object + * function. */ + Tcl_CmdDeleteProc *deleteProc + /* If not NULL, gives a function to call when + * this command is deleted. */ +) { + int deleted = 0, isNew = 0; + Command *cmdPtr; + ImportRef *oldRefPtr = NULL; + ImportedCmdData *dataPtr; + Tcl_HashEntry *hPtr; + Namespace *nsPtr = (Namespace *) namespace; + /* * If the command name we seek to create already exists, we need to * delete that first. That can be tricky in the presence of traces. * Loop until we no longer find an existing command in the way, or * until we've deleted one command and that didn't finish the job. */ - while (1) { - /* - * Determine where the command should reside. If its name contains - * namespace qualifiers, we put it in the specified namespace; - * otherwise, we always put it in the global namespace. - */ - - if (strstr(cmdName, "::") != NULL) { - Namespace *dummy1, *dummy2; - - TclGetNamespaceForQualName(interp, cmdName, NULL, - TCL_CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail); - if ((nsPtr == NULL) || (tail == NULL)) { - return (Tcl_Command) NULL; - } - } else { - nsPtr = iPtr->globalNsPtr; - tail = cmdName; - } + hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, cmdName, &isNew); - hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &isNew); - - if (isNew || deleted) { + if (isNew || deleted) { /* * isNew - No conflict with existing command. * deleted - We've already deleted a conflicting command */ break; - } + } + /* An existing command conflicts. Try to delete it.. */ cmdPtr = Tcl_GetHashValue(hPtr); @@ -2336,7 +2353,13 @@ Tcl_CreateObjCommand( cmdPtr->flags |= CMD_REDEF_IN_PROGRESS; } + /* Make sure namespace doesn't get deallocated. */ + cmdPtr->nsPtr->refCount++; + Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr); + nsPtr = (Namespace *) TclEnsureNamespace(interp, + (Tcl_Namespace *)cmdPtr->nsPtr); + TclNsDecrRefCount(cmdPtr->nsPtr); if (cmdPtr->flags & CMD_REDEF_IN_PROGRESS) { oldRefPtr = cmdPtr->importRefPtr; @@ -2345,7 +2368,6 @@ Tcl_CreateObjCommand( TclCleanupCommandMacro(cmdPtr); deleted = 1; } - if (!isNew) { /* * If the deletion callback recreated the command, just throw away @@ -2367,7 +2389,7 @@ Tcl_CreateObjCommand( * commands. */ - TclInvalidateCmdLiteral(interp, tail, nsPtr); + TclInvalidateCmdLiteral(interp, cmdName, nsPtr); /* * The list of command exported from the namespace might have changed. @@ -8187,6 +8209,21 @@ Tcl_NRCreateCommand( cmdPtr->nreProc = nreProc; return (Tcl_Command) cmdPtr; } + +Tcl_Command tclNRCreateCommandInNs ( + Tcl_Interp *interp, + const char *cmdName, + Tcl_Namespace *nsPtr, + Tcl_ObjCmdProc *proc, + Tcl_ObjCmdProc *nreProc, + ClientData clientData, + Tcl_CmdDeleteProc *deleteProc) { + Command *cmdPtr = (Command *) + tclCreateObjCommandInNs(interp,cmdName,nsPtr,proc,clientData,deleteProc); + + cmdPtr->nreProc = nreProc; + return (Tcl_Command) cmdPtr; +} /**************************************************************************** * Stuff for the public api diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index f3e8187..28802b0 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -146,10 +146,12 @@ TclNamespaceEnsembleCmd( Tcl_Obj *const objv[]) { Tcl_Namespace *namespacePtr; - Namespace *nsPtr = (Namespace *) TclGetCurrentNamespace(interp); + Namespace *nsPtr = (Namespace *) TclGetCurrentNamespace(interp), *cxtPtr, + *foundNsPtr, *altFoundNsPtr, *actualCxtPtr; Tcl_Command token; Tcl_DictSearch search; Tcl_Obj *listObj; + const char *simpleName; int index, done; if (nsPtr == NULL || nsPtr->flags & NS_DYING) { @@ -195,13 +197,8 @@ TclNamespaceEnsembleCmd( objv += 2; objc -= 2; - /* - * Work out what name to use for the command to create. If supplied, - * it is either fully specified or relative to the current namespace. - * If not supplied, it is exactly the name of the current namespace. - */ - - name = nsPtr->fullName; + name = nsPtr->name; + cxtPtr = (Namespace *) nsPtr->parentPtr; /* * Parse the option list, applying type checks as we go. Note that we @@ -221,6 +218,7 @@ TclNamespaceEnsembleCmd( switch ((enum EnsCreateOpts) index) { case CRT_CMD: name = TclGetString(objv[1]); + cxtPtr = nsPtr; continue; case CRT_SUBCMDS: if (TclListObjLength(interp, objv[1], &len) != TCL_OK) { @@ -337,6 +335,10 @@ TclNamespaceEnsembleCmd( } } + TclGetNamespaceForQualName(interp, name, cxtPtr, + TCL_CREATE_NS_IF_UNKNOWN, &foundNsPtr, &altFoundNsPtr, &actualCxtPtr, + &simpleName); + /* * Create the ensemble. Note that this might delete another ensemble * linked to the same namespace, so we must be careful. However, we @@ -344,8 +346,9 @@ TclNamespaceEnsembleCmd( * we've created it (and after any deletions have occurred.) */ - token = Tcl_CreateEnsemble(interp, name, NULL, - (permitPrefix ? TCL_ENSEMBLE_PREFIX : 0)); + token = TclCreateEnsembleInNs(interp, simpleName, + (Tcl_Namespace *) foundNsPtr, (Tcl_Namespace *) nsPtr, + (permitPrefix ? TCL_ENSEMBLE_PREFIX : 0)); Tcl_SetEnsembleSubcommandList(interp, token, subcmdObj); Tcl_SetEnsembleMappingDict(interp, token, mapObj); Tcl_SetEnsembleUnknownHandler(interp, token, unknownObj); @@ -636,48 +639,38 @@ TclNamespaceEnsembleCmd( /* *---------------------------------------------------------------------- * - * Tcl_CreateEnsemble -- + * TclCreateEnsembleInNs -- * - * Create a simple ensemble attached to the given namespace. - * - * Results: - * The token for the command created. - * - * Side effects: - * The ensemble is created and marked for compilation. + * Like Tcl_CreateEnsemble, but additionally accepts as an argument the + * name of the namespace to create the command in. * *---------------------------------------------------------------------- */ Tcl_Command -Tcl_CreateEnsemble( - Tcl_Interp *interp, - const char *name, - Tcl_Namespace *namespacePtr, - int flags) +TclCreateEnsembleInNs( + Tcl_Interp *interp, + + const char *name, /* Simple name of command to create (no */ + /* namespace components). */ + Tcl_Namespace /* Name of namespace to create the command in. */ + *nameNsPtr, + Tcl_Namespace + *ensembleNsPtr, /* Name of the namespace for the ensemble. */ + int flags + ) { - Namespace *nsPtr = (Namespace *) namespacePtr; - EnsembleConfig *ensemblePtr = ckalloc(sizeof(EnsembleConfig)); - Tcl_Obj *nameObj = NULL; - - if (nsPtr == NULL) { - nsPtr = (Namespace *) TclGetCurrentNamespace(interp); - } - - /* - * Make the name of the ensemble into a fully qualified name. This might - * allocate a temporary object. - */ + Namespace *nsPtr = (Namespace *) ensembleNsPtr; + EnsembleConfig *ensemblePtr; + Tcl_Command token; - if (!(name[0] == ':' && name[1] == ':')) { - nameObj = NewNsObj((Tcl_Namespace *) nsPtr); - if (nsPtr->parentPtr == NULL) { - Tcl_AppendStringsToObj(nameObj, name, NULL); - } else { - Tcl_AppendStringsToObj(nameObj, "::", name, NULL); - } - Tcl_IncrRefCount(nameObj); - name = TclGetString(nameObj); + ensemblePtr = ckalloc(sizeof(EnsembleConfig)); + token = tclNRCreateCommandInNs(interp, name, + (Tcl_Namespace *) nameNsPtr, NsEnsembleImplementationCmd, + NsEnsembleImplementationCmdNR, ensemblePtr, DeleteEnsembleConfig); + if (token == NULL) { + ckfree(ensemblePtr); + return NULL; } ensemblePtr->nsPtr = nsPtr; @@ -690,9 +683,7 @@ Tcl_CreateEnsemble( ensemblePtr->numParameters = 0; ensemblePtr->parameterList = NULL; ensemblePtr->unknownHandler = NULL; - ensemblePtr->token = Tcl_NRCreateCommand(interp, name, - NsEnsembleImplementationCmd, NsEnsembleImplementationCmdNR, - ensemblePtr, DeleteEnsembleConfig); + ensemblePtr->token = token; ensemblePtr->next = (EnsembleConfig *) nsPtr->ensembles; nsPtr->ensembles = (Tcl_Ensemble *) ensemblePtr; @@ -709,11 +700,56 @@ Tcl_CreateEnsemble( ((Command *) ensemblePtr->token)->compileProc = TclCompileEnsemble; } + return ensemblePtr->token; + +} + + +/* + *---------------------------------------------------------------------- + * + * Tcl_CreateEnsemble + * + * Create a simple ensemble attached to the given namespace. + * + * Deprecated by TclCreateEnsembleInNs. + * + * Value + * + * The token for the command created. + * + * Effect + * The ensemble is created and marked for compilation. + * + * + *---------------------------------------------------------------------- + */ + +Tcl_Command +Tcl_CreateEnsemble( + Tcl_Interp *interp, + const char *name, + Tcl_Namespace *namespacePtr, + int flags) +{ + Tcl_Obj *nameObj = NULL; + Namespace *nsPtr = (Namespace *)namespacePtr, *foundNsPtr, *altNsPtr, + *actualNsPtr; + const char * simpleName; + + if (nsPtr == NULL) { + nsPtr = (Namespace *) TclGetCurrentNamespace(interp); + } + + TclGetNamespaceForQualName(interp, name, nsPtr, 0, + &foundNsPtr, &altNsPtr, &actualNsPtr, &simpleName); if (nameObj != NULL) { - TclDecrRefCount(nameObj); + TclDecrRefCount(nameObj); } - return ensemblePtr->token; + return TclCreateEnsembleInNs(interp, simpleName, + (Tcl_Namespace *) foundNsPtr, (Tcl_Namespace *) nsPtr, flags); } + /* *---------------------------------------------------------------------- @@ -1885,6 +1921,7 @@ NsEnsembleImplementationCmdNR( TclSkipTailcall(interp); Tcl_ListObjGetElements(NULL, copyPtr, ©Objc, ©Objv); + ((Interp *)interp)->lookupNsPtr = ensemblePtr->nsPtr; return TclNREvalObjv(interp, copyObjc, copyObjv, TCL_EVAL_INVOKE, NULL); } @@ -2635,10 +2672,7 @@ BuildEnsembleConfig( Tcl_Obj *cmdObj, *cmdPrefixObj; TclNewObj(cmdObj); - Tcl_AppendStringsToObj(cmdObj, - ensemblePtr->nsPtr->fullName, - (ensemblePtr->nsPtr->parentPtr ? "::" : ""), - nsCmdName, NULL); + Tcl_AppendStringsToObj(cmdObj, nsCmdName, NULL); cmdPrefixObj = Tcl_NewListObj(1, &cmdObj); Tcl_SetHashValue(hPtr, cmdPrefixObj); Tcl_IncrRefCount(cmdPrefixObj); diff --git a/generic/tclInt.h b/generic/tclInt.h index 23a20e6..480ae5a 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2917,6 +2917,19 @@ MODULE_SCOPE void TclContinuationsCopy(Tcl_Obj *objPtr, Tcl_Obj *originObjPtr); MODULE_SCOPE int TclConvertElement(const char *src, int length, char *dst, int flags); +MODULE_SCOPE Tcl_Command tclCreateObjCommandInNs ( + Tcl_Interp *interp, + const char *cmdName, + Tcl_Namespace *nsPtr, + Tcl_ObjCmdProc *proc, + ClientData clientData, + Tcl_CmdDeleteProc *deleteProc); +MODULE_SCOPE Tcl_Command TclCreateEnsembleInNs( + Tcl_Interp *interp, + const char *name, + Tcl_Namespace *nameNamespacePtr, + Tcl_Namespace *ensembleNamespacePtr, + int flags); MODULE_SCOPE void TclDeleteNamespaceVars(Namespace *nsPtr); MODULE_SCOPE int TclFindDictElement(Tcl_Interp *interp, const char *dict, int dictLength, @@ -2945,6 +2958,10 @@ 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); +Tcl_Namespace * TclEnsureNamespace( + Tcl_Interp *interp, + Tcl_Namespace *namespacePtr); + MODULE_SCOPE void TclFinalizeAllocSubsystem(void); MODULE_SCOPE void TclFinalizeAsync(void); MODULE_SCOPE void TclFinalizeDoubleConversion(void); @@ -2971,6 +2988,15 @@ MODULE_SCOPE double TclFloor(const mp_int *a); MODULE_SCOPE void TclFormatNaN(double value, char *buffer); MODULE_SCOPE int TclFSFileAttrIndex(Tcl_Obj *pathPtr, const char *attributeName, int *indexPtr); +MODULE_SCOPE Tcl_Command tclNRCreateCommandInNs ( + Tcl_Interp *interp, + const char *cmdName, + Tcl_Namespace *nsPtr, + Tcl_ObjCmdProc *proc, + Tcl_ObjCmdProc *nreProc, + ClientData clientData, + Tcl_CmdDeleteProc *deleteProc); + MODULE_SCOPE int TclNREvalFile(Tcl_Interp *interp, Tcl_Obj *pathPtr, const char *encodingName); MODULE_SCOPE void TclFSUnloadTempFile(Tcl_LoadHandle loadHandle); diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index e1bad0e..e7914ad 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -2424,6 +2424,35 @@ TclGetNamespaceForQualName( /* *---------------------------------------------------------------------- * + * TclEnsureNamespace -- + * + * Provide a namespace that is not deleted. + * + * Value + * + * namespacePtr, if it is not scheduled for deletion, or a pointer to a + * new namespace with the same name otherwise. + * + * Effect + * None. + * + *---------------------------------------------------------------------- + */ +Tcl_Namespace * +TclEnsureNamespace( + Tcl_Interp *interp, + Tcl_Namespace *namespacePtr) +{ + Namespace *nsPtr = (Namespace *) namespacePtr; + if (!nsPtr->flags & NS_DYING) { + return namespacePtr; + } + return Tcl_CreateNamespace(interp, nsPtr->fullName, NULL, NULL); +} + +/* + *---------------------------------------------------------------------- + * * Tcl_FindNamespace -- * * Searches for a namespace. @@ -2638,7 +2667,7 @@ Tcl_FindCommand( Namespace *nsPtr[2]; register int search; - TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr, + TclGetNamespaceForQualName(interp, name, cxtNsPtr, flags, &nsPtr[0], &nsPtr[1], &cxtNsPtr, &simpleName); /* diff --git a/generic/tclProc.c b/generic/tclProc.c index 8fc6dcb..f5f2b03 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -128,7 +128,6 @@ Tcl_ProcObjCmd( const char *procName, *procArgs, *procBody; Namespace *nsPtr, *altNsPtr, *cxtNsPtr; Tcl_Command cmd; - Tcl_DString ds; if (objc != 4) { Tcl_WrongNumArgs(interp, 1, objv, "name args body"); @@ -180,23 +179,8 @@ Tcl_ProcObjCmd( return TCL_ERROR; } - /* - * Now create a command for the procedure. This will initially be in the - * current namespace unless the procedure's name included namespace - * qualifiers. To create the new command in the right namespace, we - * generate a fully qualified name for it. - */ - - Tcl_DStringInit(&ds); - if (nsPtr != iPtr->globalNsPtr) { - Tcl_DStringAppend(&ds, nsPtr->fullName, -1); - TclDStringAppendLiteral(&ds, "::"); - } - Tcl_DStringAppend(&ds, procName, -1); - - cmd = Tcl_NRCreateCommand(interp, Tcl_DStringValue(&ds), TclObjInterpProc, - TclNRInterpProc, procPtr, TclProcDeleteProc); - Tcl_DStringFree(&ds); + cmd = tclNRCreateCommandInNs(interp, procName, (Tcl_Namespace *) nsPtr, + TclObjInterpProc, TclNRInterpProc, procPtr, TclProcDeleteProc); /* * Now initialize the new procedure's cmdPtr field. This will be used diff --git a/tests/namespace.test b/tests/namespace.test index f6f817b..220fa53 100644 --- a/tests/namespace.test +++ b/tests/namespace.test @@ -1784,7 +1784,7 @@ test namespace-42.7 {ensembles: nested} -body { list [ns x0 z] [ns x1] [ns x2] [ns x3] } -cleanup { namespace delete ns -} -result {{1 ::ns::x0::z} 1 2 3} +} -result {{1 z} 1 2 3} test namespace-42.8 {ensembles: [Bug 1670091]} -setup { proc demo args {} variable target [list [namespace which demo] x] @@ -2084,7 +2084,7 @@ test namespace-47.1 {ensemble: unknown handler} { lappend result [catch {ns c d e} msg] $msg lappend result [catch {ns Magic foo bar spong wibble} msg] $msg list $result [lsort [info commands ::ns::*]] $log [namespace delete ns] -} {{0 2 0 2 0 2 0 2 1 {unknown or protected subcommand "Magic"}} {::ns::Magic ::ns::a ::ns::b ::ns::c} {{making a} {running ::ns::a b c} {running ::ns::a b c} {making b} {running ::ns::b c d} {making c} {running ::ns::c d e} {unknown Magic - args = foo bar spong wibble}} {}} +} {{0 2 0 2 0 2 0 2 1 {unknown or protected subcommand "Magic"}} {::ns::Magic ::ns::a ::ns::b ::ns::c} {{making a} {running a b c} {running a b c} {making b} {running b c d} {making c} {running c d e} {unknown Magic - args = foo bar spong wibble}} {}} test namespace-47.2 {ensemble: unknown handler} { namespace eval ns { namespace export {[a-z]*} @@ -3183,7 +3183,7 @@ test namespace-53.10 {ensembles: nested rewrite} -setup { 1 {wrong # args: should be "ns z1 x a1"}\ 1 {wrong # args: should be "ns z2 x a1 a2"}\ 1 {wrong # args: should be "ns z2 x a1 a2"}\ - 1 {wrong # args: should be "::ns::x::z0"}\ + 1 {wrong # args: should be "z0"}\ 0 {1 v}\ 1 {wrong # args: should be "ns v x z2 a2"}\ 0 {2 v v2}} @@ -3267,6 +3267,18 @@ test namespace-56.3 {bug f97d4ee020: mutually-entangled deletion} { } } } {::testing::abc::def ::testing::abc::ghi} + +test namespace-56.4 {bug 16fe1b5807: names starting with ":"} { +namespace eval : { + namespace ensemble create + namespace export * + proc p1 {} { + return 16fe1b5807 + } +} + +: p1 +} 16fe1b5807 # cleanup catch {rename cmd1 {}} -- cgit v0.12 From 42c80667fd7da57b65d92fee77d2b954fba95970 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Fri, 17 Nov 2017 23:42:16 +0000 Subject: Lift the restriction on command names names that begin with ":". --- generic/tclBasic.c | 8 -------- generic/tclProc.c | 8 -------- 2 files changed, 16 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 334febc..a51578c 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -9042,14 +9042,6 @@ TclNRCoroutineObjCmd( Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", fullName, NULL); return TCL_ERROR; } - if ((nsPtr != iPtr->globalNsPtr) - && (procName != NULL) && (procName[0] == ':')) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't create procedure \"%s\" in non-global namespace with" - " name starting with \":\"", procName)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", procName, NULL); - return TCL_ERROR; - } /* * We ARE creating the coroutine command: allocate the corresponding diff --git a/generic/tclProc.c b/generic/tclProc.c index f5f2b03..3c30623 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -158,14 +158,6 @@ Tcl_ProcObjCmd( Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL); return TCL_ERROR; } - if ((nsPtr != iPtr->globalNsPtr) - && (procName != NULL) && (procName[0] == ':')) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't create procedure \"%s\" in non-global namespace with" - " name starting with \":\"", procName)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL); - return TCL_ERROR; - } /* * Create the data structure to represent the procedure. -- cgit v0.12 From 75924256c128fb94dc0cfbddf6d56fc89aeb10e7 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Sun, 19 Nov 2017 00:06:51 +0000 Subject: Fix segmentation fault in TclOO that was noted in [16fe1b5807]. Update coroutine and TclOO object creation routines to use TclCreateObjCommandInNs. --- generic/tclBasic.c | 46 +++++++++++++++++----------------------------- generic/tclEnsemble.c | 12 +++--------- generic/tclInt.h | 4 ++-- generic/tclOO.c | 37 +++++++++++++++++++++---------------- generic/tclProc.c | 22 +++++++++++----------- tests/namespace.test | 2 +- 6 files changed, 55 insertions(+), 68 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index a51578c..2acd2e7 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -2281,11 +2281,11 @@ Tcl_CreateObjCommand( tail = cmdName; } - return tclCreateObjCommandInNs(interp, tail, (Tcl_Namespace *) nsPtr, + return TclCreateObjCommandInNs(interp, tail, (Tcl_Namespace *) nsPtr, proc, clientData, deleteProc); } -Tcl_Command tclCreateObjCommandInNs ( +Tcl_Command TclCreateObjCommandInNs ( Tcl_Interp *interp, const char *cmdName, /* Name of command, without any namespace components */ Tcl_Namespace *namespace, /* The namespace to create the command in */ @@ -8210,7 +8210,7 @@ Tcl_NRCreateCommand( return (Tcl_Command) cmdPtr; } -Tcl_Command tclNRCreateCommandInNs ( +Tcl_Command TclNRCreateCommandInNs ( Tcl_Interp *interp, const char *cmdName, Tcl_Namespace *nsPtr, @@ -8219,7 +8219,7 @@ Tcl_Command tclNRCreateCommandInNs ( ClientData clientData, Tcl_CmdDeleteProc *deleteProc) { Command *cmdPtr = (Command *) - tclCreateObjCommandInNs(interp,cmdName,nsPtr,proc,clientData,deleteProc); + TclCreateObjCommandInNs(interp,cmdName,nsPtr,proc,clientData,deleteProc); cmdPtr->nreProc = nreProc; return (Tcl_Command) cmdPtr; @@ -9009,9 +9009,9 @@ TclNRCoroutineObjCmd( { Command *cmdPtr; CoroutineData *corPtr; - const char *fullName, *procName; - Namespace *nsPtr, *altNsPtr, *cxtNsPtr; - Tcl_DString ds; + const char *procName, *simpleName; + Namespace *nsPtr, *altNsPtr, *cxtNsPtr, + *inNsPtr = (Namespace *)TclGetCurrentNamespace(interp); Namespace *lookupNsPtr = iPtr->varFramePtr->nsPtr; if (objc < 3) { @@ -9019,27 +9019,22 @@ TclNRCoroutineObjCmd( return TCL_ERROR; } - /* - * FIXME: this is copy/pasted from Tcl_ProcObjCommand. Should have - * something in tclUtil.c to find the FQ name. - */ - - fullName = TclGetString(objv[1]); - TclGetNamespaceForQualName(interp, fullName, NULL, 0, - &nsPtr, &altNsPtr, &cxtNsPtr, &procName); + procName = TclGetString(objv[1]); + TclGetNamespaceForQualName(interp, procName, inNsPtr, 0, + &nsPtr, &altNsPtr, &cxtNsPtr, &simpleName); if (nsPtr == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't create procedure \"%s\": unknown namespace", - fullName)); + procName)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", NULL); return TCL_ERROR; } - if (procName == NULL) { + if (simpleName == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't create procedure \"%s\": bad procedure name", - fullName)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", fullName, NULL); + procName)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", procName, NULL); return TCL_ERROR; } @@ -9050,16 +9045,9 @@ TclNRCoroutineObjCmd( corPtr = ckalloc(sizeof(CoroutineData)); - Tcl_DStringInit(&ds); - if (nsPtr != iPtr->globalNsPtr) { - Tcl_DStringAppend(&ds, nsPtr->fullName, -1); - TclDStringAppendLiteral(&ds, "::"); - } - Tcl_DStringAppend(&ds, procName, -1); - - cmdPtr = (Command *) Tcl_NRCreateCommand(interp, Tcl_DStringValue(&ds), - /*objProc*/ NULL, TclNRInterpCoroutine, corPtr, DeleteCoroutine); - Tcl_DStringFree(&ds); + cmdPtr = (Command *) TclNRCreateCommandInNs(interp, simpleName, + (Tcl_Namespace *)nsPtr, /*objProc*/ NULL, TclNRInterpCoroutine, + corPtr, DeleteCoroutine); corPtr->cmdPtr = cmdPtr; cmdPtr->refCount++; diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 28802b0..cce7666 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -665,7 +665,7 @@ TclCreateEnsembleInNs( Tcl_Command token; ensemblePtr = ckalloc(sizeof(EnsembleConfig)); - token = tclNRCreateCommandInNs(interp, name, + token = TclNRCreateCommandInNs(interp, name, (Tcl_Namespace *) nameNsPtr, NsEnsembleImplementationCmd, NsEnsembleImplementationCmdNR, ensemblePtr, DeleteEnsembleConfig); if (token == NULL) { @@ -2605,12 +2605,7 @@ BuildEnsembleConfig( * the programmer's responsibility (or [::unknown] of course). */ - cmdObj = NewNsObj((Tcl_Namespace *) ensemblePtr->nsPtr); - if (ensemblePtr->nsPtr->parentPtr != NULL) { - Tcl_AppendStringsToObj(cmdObj, "::", name, NULL); - } else { - Tcl_AppendStringsToObj(cmdObj, name, NULL); - } + cmdObj = Tcl_NewStringObj(name, -1); cmdPrefixObj = Tcl_NewListObj(1, &cmdObj); Tcl_SetHashValue(hPtr, cmdPrefixObj); Tcl_IncrRefCount(cmdPrefixObj); @@ -2671,8 +2666,7 @@ BuildEnsembleConfig( if (isNew) { Tcl_Obj *cmdObj, *cmdPrefixObj; - TclNewObj(cmdObj); - Tcl_AppendStringsToObj(cmdObj, nsCmdName, NULL); + cmdObj = Tcl_NewStringObj(nsCmdName, -1); cmdPrefixObj = Tcl_NewListObj(1, &cmdObj); Tcl_SetHashValue(hPtr, cmdPrefixObj); Tcl_IncrRefCount(cmdPrefixObj); diff --git a/generic/tclInt.h b/generic/tclInt.h index 480ae5a..7078ba0 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2917,7 +2917,7 @@ MODULE_SCOPE void TclContinuationsCopy(Tcl_Obj *objPtr, Tcl_Obj *originObjPtr); MODULE_SCOPE int TclConvertElement(const char *src, int length, char *dst, int flags); -MODULE_SCOPE Tcl_Command tclCreateObjCommandInNs ( +MODULE_SCOPE Tcl_Command TclCreateObjCommandInNs ( Tcl_Interp *interp, const char *cmdName, Tcl_Namespace *nsPtr, @@ -2988,7 +2988,7 @@ MODULE_SCOPE double TclFloor(const mp_int *a); MODULE_SCOPE void TclFormatNaN(double value, char *buffer); MODULE_SCOPE int TclFSFileAttrIndex(Tcl_Obj *pathPtr, const char *attributeName, int *indexPtr); -MODULE_SCOPE Tcl_Command tclNRCreateCommandInNs ( +MODULE_SCOPE Tcl_Command TclNRCreateCommandInNs ( Tcl_Interp *interp, const char *cmdName, Tcl_Namespace *nsPtr, diff --git a/generic/tclOO.c b/generic/tclOO.c index e48158c..7feeb5d 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -562,7 +562,10 @@ AllocObject( Object *oPtr; Command *cmdPtr; CommandTrace *tracePtr; + Namespace *nsPtr, *altNsPtr, *cxtNsPtr; + Tcl_Namespace *inNsPtr; int creationEpoch, ignored; + const char *simpleName; oPtr = ckalloc(sizeof(Object)); memset(oPtr, 0, sizeof(Object)); @@ -652,24 +655,18 @@ AllocObject( * command is deleted). */ - if (!nameStr) { - oPtr->command = Tcl_CreateObjCommand(interp, - oPtr->namespacePtr->fullName, PublicObjectCmd, oPtr, NULL); - } else if (nameStr[0] == ':' && nameStr[1] == ':') { - oPtr->command = Tcl_CreateObjCommand(interp, nameStr, - PublicObjectCmd, oPtr, NULL); + if (nameStr) { + inNsPtr = TclGetCurrentNamespace(interp); } else { - Tcl_DString buffer; - - Tcl_DStringInit(&buffer); - Tcl_DStringAppend(&buffer, - Tcl_GetCurrentNamespace(interp)->fullName, -1); - TclDStringAppendLiteral(&buffer, "::"); - Tcl_DStringAppend(&buffer, nameStr, -1); - oPtr->command = Tcl_CreateObjCommand(interp, - Tcl_DStringValue(&buffer), PublicObjectCmd, oPtr, NULL); - Tcl_DStringFree(&buffer); + nameStr = oPtr->namespacePtr->name; + inNsPtr = oPtr->namespacePtr; } + + TclGetNamespaceForQualName(interp, nameStr, (Namespace *) inNsPtr, 0, + &nsPtr, &altNsPtr, &cxtNsPtr, &simpleName); + + oPtr->command = TclCreateObjCommandInNs(interp, simpleName, + (Tcl_Namespace *)nsPtr, PublicObjectCmd, oPtr, NULL); /* * Add the NRE command and trace directly. While this breaks a number of @@ -1795,6 +1792,11 @@ TclNRNewObjectInstance( Object *oPtr; /* + * Protect classPtr from getting cleaned up when the command is created. + */ + AddRef(classPtr); + + /* * Check if we're going to create an object over an existing command; * that's not allowed. */ @@ -1841,11 +1843,13 @@ TclNRNewObjectInstance( if (objc < 0) { *objectPtr = (Tcl_Object) oPtr; + DelRef(classPtr); return TCL_OK; } contextPtr = TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL); if (contextPtr == NULL) { *objectPtr = (Tcl_Object) oPtr; + DelRef(classPtr); return TCL_OK; } @@ -1869,6 +1873,7 @@ TclNRNewObjectInstance( TclNRAddCallback(interp, FinalizeAlloc, contextPtr, oPtr, state, objectPtr); TclPushTailcallPoint(interp); + DelRef(classPtr); return TclOOInvokeContext(contextPtr, interp, objc, objv); } diff --git a/generic/tclProc.c b/generic/tclProc.c index 3c30623..b89357c 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -124,8 +124,8 @@ Tcl_ProcObjCmd( { register Interp *iPtr = (Interp *) interp; Proc *procPtr; - const char *fullName; - const char *procName, *procArgs, *procBody; + const char *procName; + const char *simpleName, *procArgs, *procBody; Namespace *nsPtr, *altNsPtr, *cxtNsPtr; Tcl_Command cmd; @@ -140,21 +140,21 @@ Tcl_ProcObjCmd( * namespace. */ - fullName = TclGetString(objv[1]); - TclGetNamespaceForQualName(interp, fullName, NULL, 0, - &nsPtr, &altNsPtr, &cxtNsPtr, &procName); + procName = TclGetString(objv[1]); + TclGetNamespaceForQualName(interp, procName, NULL, 0, + &nsPtr, &altNsPtr, &cxtNsPtr, &simpleName); if (nsPtr == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't create procedure \"%s\": unknown namespace", - fullName)); + procName)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL); return TCL_ERROR; } - if (procName == NULL) { + if (simpleName == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't create procedure \"%s\": bad procedure name", - fullName)); + procName)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL); return TCL_ERROR; } @@ -163,15 +163,15 @@ Tcl_ProcObjCmd( * Create the data structure to represent the procedure. */ - if (TclCreateProc(interp, nsPtr, procName, objv[2], objv[3], + if (TclCreateProc(interp, nsPtr, simpleName, objv[2], objv[3], &procPtr) != TCL_OK) { Tcl_AddErrorInfo(interp, "\n (creating proc \""); - Tcl_AddErrorInfo(interp, procName); + Tcl_AddErrorInfo(interp, simpleName); Tcl_AddErrorInfo(interp, "\")"); return TCL_ERROR; } - cmd = tclNRCreateCommandInNs(interp, procName, (Tcl_Namespace *) nsPtr, + cmd = TclNRCreateCommandInNs(interp, simpleName, (Tcl_Namespace *) nsPtr, TclObjInterpProc, TclNRInterpProc, procPtr, TclProcDeleteProc); /* diff --git a/tests/namespace.test b/tests/namespace.test index 220fa53..de96682 100644 --- a/tests/namespace.test +++ b/tests/namespace.test @@ -1920,7 +1920,7 @@ test namespace-44.5 {ensemble: errors} -setup { foobar foobarcon } -cleanup { rename foobar {} -} -returnCodes error -result {invalid command name "::foobarconfigure"} +} -returnCodes error -result {invalid command name "foobarconfigure"} test namespace-44.6 {ensemble: errors} -returnCodes error -body { namespace ensemble create gorp } -result {wrong # args: should be "namespace ensemble create ?option value ...?"} -- cgit v0.12 From c2eeda3f09a8b05e10e5f8f968fc28bb2dcf3750 Mon Sep 17 00:00:00 2001 From: pspjuth Date: Sun, 19 Nov 2017 18:40:13 +0000 Subject: Changed math functions min and max to C implementations. --- generic/tclBasic.c | 69 ++++++++++++++++++++++++++++++++++++++++++++++++++++ generic/tclExecute.c | 2 -- generic/tclInt.h | 2 ++ library/init.tcl | 37 ---------------------------- tests/expr-old.test | 20 ++++++++++++--- 5 files changed, 87 insertions(+), 43 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index acdcf41..eefb102 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -118,6 +118,8 @@ static Tcl_ObjCmdProc ExprEntierFunc; static Tcl_ObjCmdProc ExprFloorFunc; static Tcl_ObjCmdProc ExprIntFunc; static Tcl_ObjCmdProc ExprIsqrtFunc; +static Tcl_ObjCmdProc ExprMaxFunc; +static Tcl_ObjCmdProc ExprMinFunc; static Tcl_ObjCmdProc ExprRandFunc; static Tcl_ObjCmdProc ExprRoundFunc; static Tcl_ObjCmdProc ExprSqrtFunc; @@ -321,6 +323,8 @@ static const BuiltinFuncDef BuiltinFuncTable[] = { { "isqrt", ExprIsqrtFunc, NULL }, { "log", ExprUnaryFunc, (ClientData) log }, { "log10", ExprUnaryFunc, (ClientData) log10 }, + { "max", ExprMaxFunc, NULL }, + { "min", ExprMinFunc, NULL }, { "pow", ExprBinaryFunc, (ClientData) pow }, { "rand", ExprRandFunc, NULL }, { "round", ExprRoundFunc, NULL }, @@ -7677,6 +7681,71 @@ ExprWideFunc( return TCL_OK; } +/* + * Common implmentation of max() and min(). + */ +static int +ExprMaxMinFunc( + ClientData clientData, /* Ignored. */ + Tcl_Interp *interp, /* The interpreter in which to execute the + * function. */ + int objc, /* Actual parameter count. */ + Tcl_Obj *const *objv, /* Actual parameter vector. */ + int op) /* Comparison direction */ +{ + Tcl_Obj *res; + double d; + int type, i; + ClientData ptr; + + if (objc < 2) { + MathFuncWrongNumArgs(interp, 2, objc, objv); + return TCL_ERROR; + } + res = objv[1]; + for (i = 1; i < objc; i++) { + if (TclGetNumberFromObj(interp, objv[i], &ptr, &type) != TCL_OK) { + return TCL_ERROR; + } + if (type == TCL_NUMBER_NAN) { + /* + * Get the error message for NaN. + */ + + Tcl_GetDoubleFromObj(interp, objv[i], &d); + return TCL_ERROR; + } + if (TclCompareTwoNumbers(objv[i], res) == op) { + res = objv[i]; + } + } + + Tcl_SetObjResult(interp, res); + return TCL_OK; +} + +static int +ExprMaxFunc( + ClientData clientData, /* Ignored. */ + Tcl_Interp *interp, /* The interpreter in which to execute the + * function. */ + int objc, /* Actual parameter count. */ + Tcl_Obj *const *objv) /* Actual parameter vector. */ +{ + return ExprMaxMinFunc(clientData, interp, objc, objv, MP_GT); +} + +static int +ExprMinFunc( + ClientData clientData, /* Ignored. */ + Tcl_Interp *interp, /* The interpreter in which to execute the + * function. */ + int objc, /* Actual parameter count. */ + Tcl_Obj *const *objv) /* Actual parameter vector. */ +{ + return ExprMaxMinFunc(clientData, interp, objc, objv, MP_LT); +} + static int ExprRandFunc( ClientData clientData, /* Ignored. */ diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 761a23e..c4aa381 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -744,8 +744,6 @@ static ByteCode * CompileExprObj(Tcl_Interp *interp, Tcl_Obj *objPtr); static void DeleteExecStack(ExecStack *esPtr); static void DupExprCodeInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); -MODULE_SCOPE int TclCompareTwoNumbers(Tcl_Obj *valuePtr, - Tcl_Obj *value2Ptr); static Tcl_Obj * ExecuteExtendedBinaryMathOp(Tcl_Interp *interp, int opcode, Tcl_Obj **constants, Tcl_Obj *valuePtr, Tcl_Obj *value2Ptr); diff --git a/generic/tclInt.h b/generic/tclInt.h index 91c8b96..64c60e4 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2878,6 +2878,8 @@ MODULE_SCOPE int TclChanCaughtErrorBypass(Tcl_Interp *interp, Tcl_Channel chan); MODULE_SCOPE Tcl_ObjCmdProc TclChannelNamesCmd; MODULE_SCOPE Tcl_NRPostProc TclClearRootEnsemble; +MODULE_SCOPE int TclCompareTwoNumbers(Tcl_Obj *valuePtr, + Tcl_Obj *value2Ptr); MODULE_SCOPE ContLineLoc *TclContinuationsEnter(Tcl_Obj *objPtr, int num, int *loc); MODULE_SCOPE void TclContinuationsEnterDerived(Tcl_Obj *objPtr, diff --git a/library/init.tcl b/library/init.tcl index c31eea3..d5beb69 100644 --- a/library/init.tcl +++ b/library/init.tcl @@ -73,43 +73,6 @@ namespace eval tcl { encoding dirs $Path } } - - # TIP #255 min and max functions - namespace eval mathfunc { - proc min {args} { - if {![llength $args]} { - return -code error \ - "too few arguments to math function \"min\"" - } - set val Inf - foreach arg $args { - # This will handle forcing the numeric value without - # ruining the internal type of a numeric object - if {[catch {expr {double($arg)}} err]} { - return -code error $err - } - if {$arg < $val} {set val $arg} - } - return $val - } - proc max {args} { - if {![llength $args]} { - return -code error \ - "too few arguments to math function \"max\"" - } - set val -Inf - foreach arg $args { - # This will handle forcing the numeric value without - # ruining the internal type of a numeric object - if {[catch {expr {double($arg)}} err]} { - return -code error $err - } - if {$arg > $val} {set val $arg} - } - return $val - } - namespace export min max - } } # Windows specific end of initialization diff --git a/tests/expr-old.test b/tests/expr-old.test index 06a00ba..262a71b 100644 --- a/tests/expr-old.test +++ b/tests/expr-old.test @@ -1159,8 +1159,8 @@ test expr-old-40.2 {min math function} -body { expr {min(0.0)} } -result 0.0 test expr-old-40.3 {min math function} -body { - list [catch {expr {min()}} msg] $msg -} -result {1 {too few arguments to math function "min"}} + expr {min()} +} -returnCodes error -result {too few arguments for math function "min"} test expr-old-40.4 {min math function} -body { expr {min(wide(-1) << 30, 4.5, -10)} } -result [expr {wide(-1) << 30}] @@ -1170,6 +1170,12 @@ test expr-old-40.5 {min math function} -body { test expr-old-40.6 {min math function} -body { expr {min(300, "0xFF")} } -result 255 +test expr-old-40.7 {min math function} -body { + expr min(1[string repeat 0 10000], 1e300) +} -result 1e+300 +test expr-old-40.8 {min math function} -body { + expr {min(0, "a")} +} -returnCodes error -match glob -result * test expr-old-41.1 {max math function} -body { expr {max(0)} @@ -1178,8 +1184,8 @@ test expr-old-41.2 {max math function} -body { expr {max(0.0)} } -result 0.0 test expr-old-41.3 {max math function} -body { - list [catch {expr {max()}} msg] $msg -} -result {1 {too few arguments to math function "max"}} + expr {max()} +} -returnCodes error -result {too few arguments for math function "max"} test expr-old-41.4 {max math function} -body { expr {max(wide(1) << 30, 4.5, -10)} } -result [expr {wide(1) << 30}] @@ -1189,6 +1195,12 @@ test expr-old-41.5 {max math function} -body { test expr-old-41.6 {max math function} -body { expr {max(200, "0xFF")} } -result 255 +test expr-old-41.7 {max math function} -body { + expr max(1[string repeat 0 10000], 1e300) +} -result 1[string repeat 0 10000] +test expr-old-41.8 {max math function} -body { + expr {max(0, "a")} +} -returnCodes error -match glob -result * # Special test for Pentium arithmetic bug of 1994: -- cgit v0.12 From b946ce971fbde11b9739fc0b77237ed382e24bd0 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 20 Nov 2017 08:58:39 +0000 Subject: Fix [e058307eef73cf21cf6805ad7c778e1024f9eb7d|e058307eef]: Use of values.h breaks build of Tk trunk on macOS --- unix/configure | 10 ---------- unix/tcl.m4 | 2 -- unix/tclConfig.h.in | 3 --- unix/tclUnixPort.h | 3 --- 4 files changed, 18 deletions(-) diff --git a/unix/configure b/unix/configure index 51d694f..90116c8 100755 --- a/unix/configure +++ b/unix/configure @@ -3733,16 +3733,6 @@ $as_echo "#define NO_DIRENT_H 1" >>confdefs.h fi - ac_fn_c_check_header_mongrel "$LINENO" "values.h" "ac_cv_header_values_h" "$ac_includes_default" -if test "x$ac_cv_header_values_h" = xyes; then : - -else - -$as_echo "#define NO_VALUES_H 1" >>confdefs.h - -fi - - ac_fn_c_check_header_mongrel "$LINENO" "stdlib.h" "ac_cv_header_stdlib_h" "$ac_includes_default" if test "x$ac_cv_header_stdlib_h" = xyes; then : tcl_ok=1 diff --git a/unix/tcl.m4 b/unix/tcl.m4 index 9aa3eb2..51459c9 100644 --- a/unix/tcl.m4 +++ b/unix/tcl.m4 @@ -2040,7 +2040,6 @@ dnl # preprocessing tests use only CPPFLAGS. # # Defines some of the following vars: # NO_DIRENT_H -# NO_VALUES_H # NO_STDLIB_H # NO_STRING_H # NO_SYS_WAIT_H @@ -2078,7 +2077,6 @@ closedir(d); AC_DEFINE(NO_DIRENT_H, 1, [Do we have ?]) fi - AC_CHECK_HEADER(values.h, , [AC_DEFINE(NO_VALUES_H, 1, [Do we have ?])]) AC_CHECK_HEADER(stdlib.h, tcl_ok=1, tcl_ok=0) AC_EGREP_HEADER(strtol, stdlib.h, , tcl_ok=0) AC_EGREP_HEADER(strtoul, stdlib.h, , tcl_ok=0) diff --git a/unix/tclConfig.h.in b/unix/tclConfig.h.in index 28ce012..4902083 100644 --- a/unix/tclConfig.h.in +++ b/unix/tclConfig.h.in @@ -331,9 +331,6 @@ /* Do we have a usable 'union wait'? */ #undef NO_UNION_WAIT -/* Do we have ? */ -#undef NO_VALUES_H - /* Do we have wait3() */ #undef NO_WAIT3 diff --git a/unix/tclUnixPort.h b/unix/tclUnixPort.h index 8b766d6..d464f05 100644 --- a/unix/tclUnixPort.h +++ b/unix/tclUnixPort.h @@ -182,9 +182,6 @@ extern int TclUnixSetBlockingMode(int fd, int mode); */ #include -#ifndef NO_VALUES_H -# include -#endif #ifndef FLT_MAX # ifdef MAXFLOAT -- cgit v0.12 From bc3e198cba9e40c015a6acfa992c69434274dde6 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 20 Nov 2017 10:15:59 +0000 Subject: Fix error-message for min/math functions: "to" -> "for", for consistancy with the error-messages for other math functions. --- library/init.tcl | 4 ++-- tests/expr-old.test | 20 ++++++++++++++++---- 2 files changed, 18 insertions(+), 6 deletions(-) diff --git a/library/init.tcl b/library/init.tcl index 87d9f14..13a4300 100644 --- a/library/init.tcl +++ b/library/init.tcl @@ -79,7 +79,7 @@ namespace eval tcl { proc min {args} { if {![llength $args]} { return -code error \ - "too few arguments to math function \"min\"" + "too few arguments for math function \"min\"" } set val Inf foreach arg $args { @@ -95,7 +95,7 @@ namespace eval tcl { proc max {args} { if {![llength $args]} { return -code error \ - "too few arguments to math function \"max\"" + "too few arguments for math function \"max\"" } set val -Inf foreach arg $args { diff --git a/tests/expr-old.test b/tests/expr-old.test index 3adfb63..8c159b2 100644 --- a/tests/expr-old.test +++ b/tests/expr-old.test @@ -1159,8 +1159,8 @@ test expr-old-40.2 {min math function} -body { expr {min(0.0)} } -result 0.0 test expr-old-40.3 {min math function} -body { - list [catch {expr {min()}} msg] $msg -} -result {1 {too few arguments to math function "min"}} + expr {min()} +} -returnCodes error -result {too few arguments for math function "min"} test expr-old-40.4 {min math function} -body { expr {min(wide(-1) << 30, 4.5, -10)} } -result [expr {wide(-1) << 30}] @@ -1170,6 +1170,12 @@ test expr-old-40.5 {min math function} -body { test expr-old-40.6 {min math function} -body { expr {min(300, "0xFF")} } -result 255 +test expr-old-40.7 {min math function} -body { + expr min(1[string repeat 0 10000], 1e300) +} -result 1e+300 +test expr-old-40.8 {min math function} -body { + expr {min(0, "a")} +} -returnCodes error -match glob -result * test expr-old-41.1 {max math function} -body { expr {max(0)} @@ -1178,8 +1184,8 @@ test expr-old-41.2 {max math function} -body { expr {max(0.0)} } -result 0.0 test expr-old-41.3 {max math function} -body { - list [catch {expr {max()}} msg] $msg -} -result {1 {too few arguments to math function "max"}} + expr {max()} +} -returnCodes error -result {too few arguments for math function "max"} test expr-old-41.4 {max math function} -body { expr {max(wide(1) << 30, 4.5, -10)} } -result [expr {wide(1) << 30}] @@ -1189,6 +1195,12 @@ test expr-old-41.5 {max math function} -body { test expr-old-41.6 {max math function} -body { expr {max(200, "0xFF")} } -result 255 +test expr-old-41.7 {max math function} -body { + expr max(1[string repeat 0 10000], 1e300) +} -result 1[string repeat 0 10000] +test expr-old-41.8 {max math function} -body { + expr {max(0, "a")} +} -returnCodes error -match glob -result * # Special test for Pentium arithmetic bug of 1994: -- cgit v0.12 From a1bc5b8a2b3fbc46b0207124137c9b2a5a8cced1 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 20 Nov 2017 12:07:08 +0000 Subject: If Tcl is compiled with -DTCL_NO_DEPRECATED, remove a lot of (internal) stub entries which correspond to functions which will be removed in Tcl 9. This commit should have been part of [7849f573c0e7d758|this] earlier commit. No effect when Tcl is not compiled with -DTCL_NO_DEPRECATED. --- generic/tclIO.c | 2 + generic/tclInt.decls | 28 +++---- generic/tclIntDecls.h | 200 +++++++++++++++++++------------------------------- generic/tclStubInit.c | 67 ++++++++++++----- unix/tclUnixThrd.c | 2 + 5 files changed, 143 insertions(+), 156 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index df04794..81fd298 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -9032,6 +9032,7 @@ ZeroTransferTimerProc( *---------------------------------------------------------------------- */ +#if !defined(TCL_NO_DEPRECATED) int TclCopyChannelOld( Tcl_Interp *interp, /* Current interpreter. */ @@ -9043,6 +9044,7 @@ TclCopyChannelOld( return TclCopyChannel(interp, inChan, outChan, (Tcl_WideInt) toRead, cmdPtr); } +#endif int TclCopyChannel( diff --git a/generic/tclInt.decls b/generic/tclInt.decls index b683a29..33bf0b3 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -453,26 +453,26 @@ declare 111 { Tcl_ResolveCompiledVarProc *compiledVarProc) } declare 112 { - int Tcl_AppendExportList(Tcl_Interp *interp, Tcl_Namespace *nsPtr, + int TclAppendExportList(Tcl_Interp *interp, Tcl_Namespace *nsPtr, Tcl_Obj *objPtr) } declare 113 { - Tcl_Namespace *Tcl_CreateNamespace(Tcl_Interp *interp, const char *name, + Tcl_Namespace *TclCreateNamespace(Tcl_Interp *interp, const char *name, ClientData clientData, Tcl_NamespaceDeleteProc *deleteProc) } declare 114 { - void Tcl_DeleteNamespace(Tcl_Namespace *nsPtr) + void TclDeleteNamespace(Tcl_Namespace *nsPtr) } declare 115 { - int Tcl_Export(Tcl_Interp *interp, Tcl_Namespace *nsPtr, + int TclExport(Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int resetListFirst) } declare 116 { - Tcl_Command Tcl_FindCommand(Tcl_Interp *interp, const char *name, + Tcl_Command TclFindCommand(Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags) } declare 117 { - Tcl_Namespace *Tcl_FindNamespace(Tcl_Interp *interp, const char *name, + Tcl_Namespace *TclFindNamespace(Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags) } declare 118 { @@ -488,28 +488,28 @@ declare 120 { Tcl_Namespace *contextNsPtr, int flags) } declare 121 { - int Tcl_ForgetImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr, + int TclForgetImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern) } declare 122 { - Tcl_Command Tcl_GetCommandFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr) + Tcl_Command TclGetCommandFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr) } declare 123 { - void Tcl_GetCommandFullName(Tcl_Interp *interp, Tcl_Command command, + void TclGetCommandFullName(Tcl_Interp *interp, Tcl_Command command, Tcl_Obj *objPtr) } declare 124 { - Tcl_Namespace *Tcl_GetCurrentNamespace(Tcl_Interp *interp) + Tcl_Namespace *TclGetCurrentNamespace_(Tcl_Interp *interp) } declare 125 { - Tcl_Namespace *Tcl_GetGlobalNamespace(Tcl_Interp *interp) + Tcl_Namespace *TclGetGlobalNamespace_(Tcl_Interp *interp) } declare 126 { void Tcl_GetVariableFullName(Tcl_Interp *interp, Tcl_Var variable, Tcl_Obj *objPtr) } declare 127 { - int Tcl_Import(Tcl_Interp *interp, Tcl_Namespace *nsPtr, + int TclImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int allowOverwrite) } declare 128 { @@ -724,10 +724,10 @@ declare 177 { const char *operation, const char *reason) } declare 178 { - void Tcl_SetStartupScript(Tcl_Obj *pathPtr, const char *encodingName) + void TclSetStartupScript(Tcl_Obj *pathPtr, const char *encodingName) } declare 179 { - Tcl_Obj *Tcl_GetStartupScript(const char **encodingNamePtr) + Tcl_Obj *TclGetStartupScript(const char **encodingNamePtr) } # REMOVED diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index 4244362..22b8072 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -28,22 +28,6 @@ # endif #endif -/* [Bug #803489] Tcl_FindNamespace problem in the Stubs table */ -#undef Tcl_CreateNamespace -#undef Tcl_DeleteNamespace -#undef Tcl_AppendExportList -#undef Tcl_Export -#undef Tcl_Import -#undef Tcl_ForgetImport -#undef Tcl_GetCurrentNamespace -#undef Tcl_GetGlobalNamespace -#undef Tcl_FindNamespace -#undef Tcl_FindCommand -#undef Tcl_GetCommandFromObj -#undef Tcl_GetCommandFullName -#undef Tcl_SetStartupScript -#undef Tcl_GetStartupScript - /* * WARNING: This file is automatically generated by the tools/genStubs.tcl * script. Any modifications to the function declarations below should be made @@ -287,22 +271,22 @@ EXTERN void Tcl_AddInterpResolvers(Tcl_Interp *interp, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc); /* 112 */ -EXTERN int Tcl_AppendExportList(Tcl_Interp *interp, +EXTERN int TclAppendExportList(Tcl_Interp *interp, Tcl_Namespace *nsPtr, Tcl_Obj *objPtr); /* 113 */ -EXTERN Tcl_Namespace * Tcl_CreateNamespace(Tcl_Interp *interp, +EXTERN Tcl_Namespace * TclCreateNamespace(Tcl_Interp *interp, const char *name, ClientData clientData, Tcl_NamespaceDeleteProc *deleteProc); /* 114 */ -EXTERN void Tcl_DeleteNamespace(Tcl_Namespace *nsPtr); +EXTERN void TclDeleteNamespace(Tcl_Namespace *nsPtr); /* 115 */ -EXTERN int Tcl_Export(Tcl_Interp *interp, Tcl_Namespace *nsPtr, +EXTERN int TclExport(Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int resetListFirst); /* 116 */ -EXTERN Tcl_Command Tcl_FindCommand(Tcl_Interp *interp, const char *name, +EXTERN Tcl_Command TclFindCommand(Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 117 */ -EXTERN Tcl_Namespace * Tcl_FindNamespace(Tcl_Interp *interp, +EXTERN Tcl_Namespace * TclFindNamespace(Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 118 */ @@ -317,23 +301,23 @@ EXTERN Tcl_Var Tcl_FindNamespaceVar(Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 121 */ -EXTERN int Tcl_ForgetImport(Tcl_Interp *interp, +EXTERN int TclForgetImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern); /* 122 */ -EXTERN Tcl_Command Tcl_GetCommandFromObj(Tcl_Interp *interp, +EXTERN Tcl_Command TclGetCommandFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr); /* 123 */ -EXTERN void Tcl_GetCommandFullName(Tcl_Interp *interp, +EXTERN void TclGetCommandFullName(Tcl_Interp *interp, Tcl_Command command, Tcl_Obj *objPtr); /* 124 */ -EXTERN Tcl_Namespace * Tcl_GetCurrentNamespace(Tcl_Interp *interp); +EXTERN Tcl_Namespace * TclGetCurrentNamespace_(Tcl_Interp *interp); /* 125 */ -EXTERN Tcl_Namespace * Tcl_GetGlobalNamespace(Tcl_Interp *interp); +EXTERN Tcl_Namespace * TclGetGlobalNamespace_(Tcl_Interp *interp); /* 126 */ EXTERN void Tcl_GetVariableFullName(Tcl_Interp *interp, Tcl_Var variable, Tcl_Obj *objPtr); /* 127 */ -EXTERN int Tcl_Import(Tcl_Interp *interp, Tcl_Namespace *nsPtr, +EXTERN int TclImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int allowOverwrite); /* 128 */ EXTERN void Tcl_PopCallFrame(Tcl_Interp *interp); @@ -465,10 +449,10 @@ EXTERN void TclVarErrMsg(Tcl_Interp *interp, const char *part1, const char *part2, const char *operation, const char *reason); /* 178 */ -EXTERN void Tcl_SetStartupScript(Tcl_Obj *pathPtr, +EXTERN void TclSetStartupScript(Tcl_Obj *pathPtr, const char *encodingName); /* 179 */ -EXTERN Tcl_Obj * Tcl_GetStartupScript(const char **encodingNamePtr); +EXTERN Tcl_Obj * TclGetStartupScript(const char **encodingNamePtr); /* Slot 180 is reserved */ /* Slot 181 is reserved */ /* 182 */ @@ -767,22 +751,22 @@ typedef struct TclIntStubs { int (*tclUpdateReturnInfo) (Interp *iPtr); /* 109 */ int (*tclSockMinimumBuffers) (void *sock, int size); /* 110 */ void (*tcl_AddInterpResolvers) (Tcl_Interp *interp, const char *name, Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc); /* 111 */ - int (*tcl_AppendExportList) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, Tcl_Obj *objPtr); /* 112 */ - Tcl_Namespace * (*tcl_CreateNamespace) (Tcl_Interp *interp, const char *name, ClientData clientData, Tcl_NamespaceDeleteProc *deleteProc); /* 113 */ - void (*tcl_DeleteNamespace) (Tcl_Namespace *nsPtr); /* 114 */ - int (*tcl_Export) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int resetListFirst); /* 115 */ - Tcl_Command (*tcl_FindCommand) (Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 116 */ - Tcl_Namespace * (*tcl_FindNamespace) (Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 117 */ + int (*tclAppendExportList) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, Tcl_Obj *objPtr); /* 112 */ + Tcl_Namespace * (*tclCreateNamespace) (Tcl_Interp *interp, const char *name, ClientData clientData, Tcl_NamespaceDeleteProc *deleteProc); /* 113 */ + void (*tclDeleteNamespace) (Tcl_Namespace *nsPtr); /* 114 */ + int (*tclExport) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int resetListFirst); /* 115 */ + Tcl_Command (*tclFindCommand) (Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 116 */ + Tcl_Namespace * (*tclFindNamespace) (Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 117 */ int (*tcl_GetInterpResolvers) (Tcl_Interp *interp, const char *name, Tcl_ResolverInfo *resInfo); /* 118 */ int (*tcl_GetNamespaceResolvers) (Tcl_Namespace *namespacePtr, Tcl_ResolverInfo *resInfo); /* 119 */ Tcl_Var (*tcl_FindNamespaceVar) (Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 120 */ - int (*tcl_ForgetImport) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern); /* 121 */ - Tcl_Command (*tcl_GetCommandFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 122 */ - void (*tcl_GetCommandFullName) (Tcl_Interp *interp, Tcl_Command command, Tcl_Obj *objPtr); /* 123 */ - Tcl_Namespace * (*tcl_GetCurrentNamespace) (Tcl_Interp *interp); /* 124 */ - Tcl_Namespace * (*tcl_GetGlobalNamespace) (Tcl_Interp *interp); /* 125 */ + int (*tclForgetImport) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern); /* 121 */ + Tcl_Command (*tclGetCommandFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 122 */ + void (*tclGetCommandFullName) (Tcl_Interp *interp, Tcl_Command command, Tcl_Obj *objPtr); /* 123 */ + Tcl_Namespace * (*tclGetCurrentNamespace_) (Tcl_Interp *interp); /* 124 */ + Tcl_Namespace * (*tclGetGlobalNamespace_) (Tcl_Interp *interp); /* 125 */ void (*tcl_GetVariableFullName) (Tcl_Interp *interp, Tcl_Var variable, Tcl_Obj *objPtr); /* 126 */ - int (*tcl_Import) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int allowOverwrite); /* 127 */ + int (*tclImport) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int allowOverwrite); /* 127 */ void (*tcl_PopCallFrame) (Tcl_Interp *interp); /* 128 */ int (*tcl_PushCallFrame) (Tcl_Interp *interp, Tcl_CallFrame *framePtr, Tcl_Namespace *nsPtr, int isProcCallFrame); /* 129 */ int (*tcl_RemoveInterpResolvers) (Tcl_Interp *interp, const char *name); /* 130 */ @@ -833,8 +817,8 @@ typedef struct TclIntStubs { int (*tclCallVarTraces) (Interp *iPtr, Var *arrayPtr, Var *varPtr, const char *part1, const char *part2, int flags, int leaveErrMsg); /* 175 */ void (*tclCleanupVar) (Var *varPtr, Var *arrayPtr); /* 176 */ void (*tclVarErrMsg) (Tcl_Interp *interp, const char *part1, const char *part2, const char *operation, const char *reason); /* 177 */ - void (*tcl_SetStartupScript) (Tcl_Obj *pathPtr, const char *encodingName); /* 178 */ - Tcl_Obj * (*tcl_GetStartupScript) (const char **encodingNamePtr); /* 179 */ + void (*tclSetStartupScript) (Tcl_Obj *pathPtr, const char *encodingName); /* 178 */ + Tcl_Obj * (*tclGetStartupScript) (const char **encodingNamePtr); /* 179 */ void (*reserved180)(void); void (*reserved181)(void); TCL_DEPRECATED_API("") struct tm * (*tclpLocaltime) (const time_t *clock); /* 182 */ @@ -1099,38 +1083,38 @@ extern const TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclSockMinimumBuffers) /* 110 */ #define Tcl_AddInterpResolvers \ (tclIntStubsPtr->tcl_AddInterpResolvers) /* 111 */ -#define Tcl_AppendExportList \ - (tclIntStubsPtr->tcl_AppendExportList) /* 112 */ -#define Tcl_CreateNamespace \ - (tclIntStubsPtr->tcl_CreateNamespace) /* 113 */ -#define Tcl_DeleteNamespace \ - (tclIntStubsPtr->tcl_DeleteNamespace) /* 114 */ -#define Tcl_Export \ - (tclIntStubsPtr->tcl_Export) /* 115 */ -#define Tcl_FindCommand \ - (tclIntStubsPtr->tcl_FindCommand) /* 116 */ -#define Tcl_FindNamespace \ - (tclIntStubsPtr->tcl_FindNamespace) /* 117 */ +#define TclAppendExportList \ + (tclIntStubsPtr->tclAppendExportList) /* 112 */ +#define TclCreateNamespace \ + (tclIntStubsPtr->tclCreateNamespace) /* 113 */ +#define TclDeleteNamespace \ + (tclIntStubsPtr->tclDeleteNamespace) /* 114 */ +#define TclExport \ + (tclIntStubsPtr->tclExport) /* 115 */ +#define TclFindCommand \ + (tclIntStubsPtr->tclFindCommand) /* 116 */ +#define TclFindNamespace \ + (tclIntStubsPtr->tclFindNamespace) /* 117 */ #define Tcl_GetInterpResolvers \ (tclIntStubsPtr->tcl_GetInterpResolvers) /* 118 */ #define Tcl_GetNamespaceResolvers \ (tclIntStubsPtr->tcl_GetNamespaceResolvers) /* 119 */ #define Tcl_FindNamespaceVar \ (tclIntStubsPtr->tcl_FindNamespaceVar) /* 120 */ -#define Tcl_ForgetImport \ - (tclIntStubsPtr->tcl_ForgetImport) /* 121 */ -#define Tcl_GetCommandFromObj \ - (tclIntStubsPtr->tcl_GetCommandFromObj) /* 122 */ -#define Tcl_GetCommandFullName \ - (tclIntStubsPtr->tcl_GetCommandFullName) /* 123 */ -#define Tcl_GetCurrentNamespace \ - (tclIntStubsPtr->tcl_GetCurrentNamespace) /* 124 */ -#define Tcl_GetGlobalNamespace \ - (tclIntStubsPtr->tcl_GetGlobalNamespace) /* 125 */ +#define TclForgetImport \ + (tclIntStubsPtr->tclForgetImport) /* 121 */ +#define TclGetCommandFromObj \ + (tclIntStubsPtr->tclGetCommandFromObj) /* 122 */ +#define TclGetCommandFullName \ + (tclIntStubsPtr->tclGetCommandFullName) /* 123 */ +#define TclGetCurrentNamespace_ \ + (tclIntStubsPtr->tclGetCurrentNamespace_) /* 124 */ +#define TclGetGlobalNamespace_ \ + (tclIntStubsPtr->tclGetGlobalNamespace_) /* 125 */ #define Tcl_GetVariableFullName \ (tclIntStubsPtr->tcl_GetVariableFullName) /* 126 */ -#define Tcl_Import \ - (tclIntStubsPtr->tcl_Import) /* 127 */ +#define TclImport \ + (tclIntStubsPtr->tclImport) /* 127 */ #define Tcl_PopCallFrame \ (tclIntStubsPtr->tcl_PopCallFrame) /* 128 */ #define Tcl_PushCallFrame \ @@ -1221,10 +1205,10 @@ extern const TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclCleanupVar) /* 176 */ #define TclVarErrMsg \ (tclIntStubsPtr->tclVarErrMsg) /* 177 */ -#define Tcl_SetStartupScript \ - (tclIntStubsPtr->tcl_SetStartupScript) /* 178 */ -#define Tcl_GetStartupScript \ - (tclIntStubsPtr->tcl_GetStartupScript) /* 179 */ +#define TclSetStartupScript \ + (tclIntStubsPtr->tclSetStartupScript) /* 178 */ +#define TclGetStartupScript \ + (tclIntStubsPtr->tclGetStartupScript) /* 179 */ /* Slot 180 is reserved */ /* Slot 181 is reserved */ #define TclpLocaltime \ @@ -1361,58 +1345,28 @@ extern const TclIntStubs *tclIntStubsPtr; #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLIMPORT -#undef TclGetStartupScriptFileName -#undef TclSetStartupScriptFileName -#undef TclGetStartupScriptPath -#undef TclSetStartupScriptPath -#undef TclBackgroundException - #if defined(USE_TCL_STUBS) -# undef Tcl_SetStartupScript -# define Tcl_SetStartupScript \ - (tclStubsPtr->tcl_SetStartupScript) /* 622 */ -# undef Tcl_GetStartupScript -# define Tcl_GetStartupScript \ - (tclStubsPtr->tcl_GetStartupScript) /* 623 */ -# undef Tcl_CreateNamespace -# define Tcl_CreateNamespace \ - (tclStubsPtr->tcl_CreateNamespace) /* 506 */ -# undef Tcl_DeleteNamespace -# define Tcl_DeleteNamespace \ - (tclStubsPtr->tcl_DeleteNamespace) /* 507 */ -# undef Tcl_AppendExportList -# define Tcl_AppendExportList \ - (tclStubsPtr->tcl_AppendExportList) /* 508 */ -# undef Tcl_Export -# define Tcl_Export \ - (tclStubsPtr->tcl_Export) /* 509 */ -# undef Tcl_Import -# define Tcl_Import \ - (tclStubsPtr->tcl_Import) /* 510 */ -# undef Tcl_ForgetImport -# define Tcl_ForgetImport \ - (tclStubsPtr->tcl_ForgetImport) /* 511 */ -# undef Tcl_GetCurrentNamespace -# define Tcl_GetCurrentNamespace \ - (tclStubsPtr->tcl_GetCurrentNamespace) /* 512 */ -# undef Tcl_GetGlobalNamespace -# define Tcl_GetGlobalNamespace \ - (tclStubsPtr->tcl_GetGlobalNamespace) /* 513 */ -# undef Tcl_FindNamespace -# define Tcl_FindNamespace \ - (tclStubsPtr->tcl_FindNamespace) /* 514 */ -# undef Tcl_FindCommand -# define Tcl_FindCommand \ - (tclStubsPtr->tcl_FindCommand) /* 515 */ -# undef Tcl_GetCommandFromObj -# define Tcl_GetCommandFromObj \ - (tclStubsPtr->tcl_GetCommandFromObj) /* 516 */ -# undef Tcl_GetCommandFullName -# define Tcl_GetCommandFullName \ - (tclStubsPtr->tcl_GetCommandFullName) /* 517 */ +# undef TclGetStartupScriptFileName +# undef TclSetStartupScriptFileName +# undef TclGetStartupScriptPath +# undef TclSetStartupScriptPath +# undef TclBackgroundException +# undef TclSetStartupScript +# undef TclGetStartupScript +# undef TclCreateNamespace +# undef TclDeleteNamespace +# undef TclAppendExportList +# undef TclExport +# undef TclImport +# undef TclForgetImport +# undef TclGetCurrentNamespace_ +# undef TclGetGlobalNamespace_ +# undef TclFindNamespace +# undef TclFindCommand +# undef TclGetCommandFromObj +# undef TclGetCommandFullName +# undef TclCopyChannelOld +# undef TclSockMinimumBuffersOld #endif -#undef TclCopyChannelOld -#undef TclSockMinimumBuffersOld - #endif /* _TCLINTDECLS */ diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 24b28e5..d2de021 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -72,11 +72,6 @@ static int TclSockMinimumBuffersOld(int sock, int size) # define TclBNInitBignumFromWideUInt 0 # define TclBNInitBignumFromWideInt 0 # define TclBNInitBignumFromLong 0 -# define Tcl_AppendResultVA 0 -# define Tcl_AppendStringsToObjVA 0 -# define Tcl_SetErrorCodeVA 0 -# define Tcl_PanicVA 0 -# define Tcl_VarEvalVA 0 #else #define TclSetStartupScriptPath setStartupScriptPath static void TclSetStartupScriptPath(Tcl_Obj *path) @@ -371,6 +366,26 @@ static int formatInt(char *buffer, int n){ # define TclBackgroundException 0 # undef TclpReaddir # define TclpReaddir 0 +# define TclSetStartupScript 0 +# define TclGetStartupScript 0 +# define TclCreateNamespace 0 +# define TclDeleteNamespace 0 +# define TclAppendExportList 0 +# define TclExport 0 +# define TclImport 0 +# define TclForgetImport 0 +# define TclGetCurrentNamespace_ 0 +# define TclGetGlobalNamespace_ 0 +# define TclFindNamespace 0 +# define TclFindCommand 0 +# define TclGetCommandFromObj 0 +# define TclGetCommandFullName 0 +# define TclCopyChannelOld 0 +# define Tcl_AppendResultVA 0 +# define Tcl_AppendStringsToObjVA 0 +# define Tcl_SetErrorCodeVA 0 +# define Tcl_PanicVA 0 +# define Tcl_VarEvalVA 0 # undef TclpGetDate # define TclpGetDate 0 # undef TclpLocaltime @@ -383,6 +398,20 @@ static int formatInt(char *buffer, int n){ # define Tcl_SeekOld seekOld # define Tcl_TellOld tellOld # define TclBackgroundException Tcl_BackgroundException +# define TclSetStartupScript Tcl_SetStartupScript +# define TclGetStartupScript Tcl_GetStartupScript +# define TclCreateNamespace Tcl_CreateNamespace +# define TclDeleteNamespace Tcl_DeleteNamespace +# define TclAppendExportList Tcl_AppendExportList +# define TclExport Tcl_Export +# define TclImport Tcl_Import +# define TclForgetImport Tcl_ForgetImport +# define TclGetCurrentNamespace_ Tcl_GetCurrentNamespace +# define TclGetGlobalNamespace_ Tcl_GetGlobalNamespace +# define TclFindNamespace Tcl_FindNamespace +# define TclFindCommand Tcl_FindCommand +# define TclGetCommandFromObj Tcl_GetCommandFromObj +# define TclGetCommandFullName Tcl_GetCommandFullName # define TclpLocaltime_unix TclpLocaltime # define TclpGmtime_unix TclpGmtime @@ -535,22 +564,22 @@ static const TclIntStubs tclIntStubs = { TclUpdateReturnInfo, /* 109 */ TclSockMinimumBuffers, /* 110 */ Tcl_AddInterpResolvers, /* 111 */ - Tcl_AppendExportList, /* 112 */ - Tcl_CreateNamespace, /* 113 */ - Tcl_DeleteNamespace, /* 114 */ - Tcl_Export, /* 115 */ - Tcl_FindCommand, /* 116 */ - Tcl_FindNamespace, /* 117 */ + TclAppendExportList, /* 112 */ + TclCreateNamespace, /* 113 */ + TclDeleteNamespace, /* 114 */ + TclExport, /* 115 */ + TclFindCommand, /* 116 */ + TclFindNamespace, /* 117 */ Tcl_GetInterpResolvers, /* 118 */ Tcl_GetNamespaceResolvers, /* 119 */ Tcl_FindNamespaceVar, /* 120 */ - Tcl_ForgetImport, /* 121 */ - Tcl_GetCommandFromObj, /* 122 */ - Tcl_GetCommandFullName, /* 123 */ - Tcl_GetCurrentNamespace, /* 124 */ - Tcl_GetGlobalNamespace, /* 125 */ + TclForgetImport, /* 121 */ + TclGetCommandFromObj, /* 122 */ + TclGetCommandFullName, /* 123 */ + TclGetCurrentNamespace_, /* 124 */ + TclGetGlobalNamespace_, /* 125 */ Tcl_GetVariableFullName, /* 126 */ - Tcl_Import, /* 127 */ + TclImport, /* 127 */ Tcl_PopCallFrame, /* 128 */ Tcl_PushCallFrame, /* 129 */ Tcl_RemoveInterpResolvers, /* 130 */ @@ -601,8 +630,8 @@ static const TclIntStubs tclIntStubs = { TclCallVarTraces, /* 175 */ TclCleanupVar, /* 176 */ TclVarErrMsg, /* 177 */ - Tcl_SetStartupScript, /* 178 */ - Tcl_GetStartupScript, /* 179 */ + TclSetStartupScript, /* 178 */ + TclGetStartupScript, /* 179 */ 0, /* 180 */ 0, /* 181 */ TclpLocaltime, /* 182 */ diff --git a/unix/tclUnixThrd.c b/unix/tclUnixThrd.c index f475aed..6fa837c 100644 --- a/unix/tclUnixThrd.c +++ b/unix/tclUnixThrd.c @@ -15,11 +15,13 @@ #ifdef TCL_THREADS +#ifndef TCL_NO_DEPRECATED typedef struct { char nabuf[16]; } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; +#endif /* * masterLock is used to serialize creation of mutexes, condition variables, -- cgit v0.12 From 9b1ecce298fc120bc981d5182cc9c45bcfb0971d Mon Sep 17 00:00:00 2001 From: pooryorick Date: Thu, 23 Nov 2017 18:24:09 +0000 Subject: Move return type to its own line. --- generic/tclBasic.c | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 2acd2e7..2f05425 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -2285,7 +2285,8 @@ Tcl_CreateObjCommand( proc, clientData, deleteProc); } -Tcl_Command TclCreateObjCommandInNs ( +Tcl_Command +TclCreateObjCommandInNs ( Tcl_Interp *interp, const char *cmdName, /* Name of command, without any namespace components */ Tcl_Namespace *namespace, /* The namespace to create the command in */ @@ -8210,7 +8211,8 @@ Tcl_NRCreateCommand( return (Tcl_Command) cmdPtr; } -Tcl_Command TclNRCreateCommandInNs ( +Tcl_Command +TclNRCreateCommandInNs ( Tcl_Interp *interp, const char *cmdName, Tcl_Namespace *nsPtr, -- cgit v0.12 From 48fb6e2c88c4b6966e52e0a8d34274e91eef47f3 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Sat, 25 Nov 2017 16:36:22 +0000 Subject: Fix for issue [4f6a1ebd64]: ensemble: segmentation fault when -subcommand and -map values are the same object. --- generic/tclEnsemble.c | 14 +++++++++++++- tests/namespace.test | 18 +++++++++++++++++- 2 files changed, 30 insertions(+), 2 deletions(-) diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index f3e8187..392f430 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -2505,6 +2505,7 @@ BuildEnsembleConfig( int i, j, isNew; Tcl_HashTable *hash = &ensemblePtr->subcommandTable; Tcl_HashEntry *hPtr; + Tcl_Obj *subcmdDictCopy = NULL ; if (hash->numEntries != 0) { /* @@ -2553,7 +2554,15 @@ BuildEnsembleConfig( */ if (ensemblePtr->subcommandDict != NULL) { - Tcl_DictObjGet(NULL, ensemblePtr->subcommandDict, subcmdv[i], + if (subcmdDictCopy == NULL) { + if (ensemblePtr->subcmdList == ensemblePtr->subcommandDict) { + subcmdDictCopy = Tcl_DuplicateObj(ensemblePtr->subcommandDict); + } else { + subcmdDictCopy = ensemblePtr->subcommandDict; + } + Tcl_IncrRefCount(subcmdDictCopy); + } + Tcl_DictObjGet(NULL, subcmdDictCopy, subcmdv[i], &target); if (target != NULL) { Tcl_SetHashValue(hPtr, target); @@ -2578,6 +2587,9 @@ BuildEnsembleConfig( Tcl_SetHashValue(hPtr, cmdPrefixObj); Tcl_IncrRefCount(cmdPrefixObj); } + if (subcmdDictCopy != NULL) { + Tcl_DecrRefCount(subcmdDictCopy); + } } else if (ensemblePtr->subcommandDict != NULL) { /* * No subcmd list, but we do have a mapping dictionary so we should diff --git a/tests/namespace.test b/tests/namespace.test index f6f817b..623f06d 100644 --- a/tests/namespace.test +++ b/tests/namespace.test @@ -1785,7 +1785,10 @@ test namespace-42.7 {ensembles: nested} -body { } -cleanup { namespace delete ns } -result {{1 ::ns::x0::z} 1 2 3} -test namespace-42.8 {ensembles: [Bug 1670091]} -setup { +test namespace-42.8 { + ensembles: [Bug 1670091], panic due to pointer to a deallocated List + struct. +} -setup { proc demo args {} variable target [list [namespace which demo] x] proc trial args {variable target; string length $target} @@ -1800,6 +1803,19 @@ test namespace-42.8 {ensembles: [Bug 1670091]} -setup { rename foo {} } -result {} +test namespace-42.9 { + ensembles: [Bug 4f6a1ebd64], segmentation fault due to pointer to a + deallocated List struct. +} -setup { + namespace eval n {namespace ensemble create} + dict set list one ::two + namespace ensemble configure n -subcommands $list -map $list +} -body { + n one +} -cleanup { + namespace delete n +} -returnCodes error -match glob -result {invalid command name*} + test namespace-43.1 {ensembles: dict-driven} { namespace eval ns { namespace export x* -- cgit v0.12 From 811ec68434e9a83c37f1a0fd3ef0a8cae5baac91 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Sat, 25 Nov 2017 18:24:10 +0000 Subject: Add missing parenthesis to an expression in TclEnsureNamespace. --- generic/tclNamesp.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index e7914ad..d661856 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -2444,7 +2444,7 @@ TclEnsureNamespace( Tcl_Namespace *namespacePtr) { Namespace *nsPtr = (Namespace *) namespacePtr; - if (!nsPtr->flags & NS_DYING) { + if (!(nsPtr->flags & NS_DYING)) { return namespacePtr; } return Tcl_CreateNamespace(interp, nsPtr->fullName, NULL, NULL); -- cgit v0.12 From 20dedcd841ef5caf05a104ccd36929080f8a5645 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 27 Nov 2017 13:52:18 +0000 Subject: Fix test-cases in safe.test, failing due to changes in min/max math functions. --- generic/tclInterp.c | 4 ---- tests/safe.test | 2 +- 2 files changed, 1 insertion(+), 5 deletions(-) diff --git a/generic/tclInterp.c b/generic/tclInterp.c index d9dfd37..d4bf465 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -3208,10 +3208,6 @@ Tcl_MakeSafe( (void) Tcl_EvalEx(interp, "namespace eval ::tcl {namespace eval mathfunc {}}", -1, 0); - (void) Tcl_CreateAlias(interp, "::tcl::mathfunc::min", master, - "::tcl::mathfunc::min", 0, NULL); - (void) Tcl_CreateAlias(interp, "::tcl::mathfunc::max", master, - "::tcl::mathfunc::max", 0, NULL); } iPtr->flags |= SAFE_INTERP; diff --git a/tests/safe.test b/tests/safe.test index e43ce12..33ee166 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -74,7 +74,7 @@ test safe-2.3 {creating safe interpreters, should have no unexpected aliases} -s lsort [a aliases] } -cleanup { interp delete a -} -result {::tcl::mathfunc::max ::tcl::mathfunc::min clock} +} -result {clock} test safe-3.1 {calling safe::interpInit is safe} -setup { catch {safe::interpDelete a} -- cgit v0.12 From d95ab0247a35a1a40f5e39186127a9f6ba4540a9 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 27 Nov 2017 14:11:16 +0000 Subject: missed some more failing test-cases --- tests/interp.test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/interp.test b/tests/interp.test index 1389304..4ea04e3 100644 --- a/tests/interp.test +++ b/tests/interp.test @@ -1847,7 +1847,7 @@ test interp-23.2 {testing hiding vs aliases: safe interp} -setup { lappend l [lsort [interp aliases a]] [lsort [interp hidden a]] } -cleanup { interp delete a -} -result [list $hidden_cmds {::tcl::mathfunc::max ::tcl::mathfunc::min bar clock} $hidden_cmds {::tcl::mathfunc::max ::tcl::mathfunc::min bar clock} [lsort [concat $hidden_cmds bar]] {::tcl::mathfunc::max ::tcl::mathfunc::min clock} $hidden_cmds] +} -result [list $hidden_cmds {bar clock} $hidden_cmds {bar clock} [lsort [concat $hidden_cmds bar]] {clock} $hidden_cmds] test interp-24.1 {result resetting on error} -setup { catch {interp delete a} -- cgit v0.12 From 293016951704770ca48af42b926e4fada4e2054a Mon Sep 17 00:00:00 2001 From: pooryorick Date: Mon, 27 Nov 2017 19:45:40 +0000 Subject: Streamline TclOO object cleanup routines. --- generic/tclOO.c | 484 ++++++++++++++++++++++------------------------------- generic/tclOOInt.h | 4 + 2 files changed, 208 insertions(+), 280 deletions(-) diff --git a/generic/tclOO.c b/generic/tclOO.c index 7feeb5d..3fece42 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -4,6 +4,7 @@ * This file contains the object-system core (NB: not Tcl_Obj, but ::oo) * * Copyright (c) 2005-2012 by Donal K. Fellows + * Copyright (c) 2017 by Nathan Coulter * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -82,7 +83,6 @@ static void ObjectRenamedTrace(ClientData clientData, const char *newName, int flags); static void ReleaseClassContents(Tcl_Interp *interp,Object *oPtr); static inline void SquelchCachedName(Object *oPtr); -static void SquelchedNsFirst(ClientData clientData); static int PublicObjectCmd(ClientData clientData, Tcl_Interp *interp, int objc, @@ -583,8 +583,7 @@ AllocObject( */ if (nsNameStr != NULL) { - oPtr->namespacePtr = Tcl_CreateNamespace(interp, nsNameStr, oPtr, - ObjectNamespaceDeleted); + oPtr->namespacePtr = Tcl_CreateNamespace(interp, nsNameStr, oPtr, NULL); if (oPtr->namespacePtr != NULL) { creationEpoch = ++fPtr->tsdPtr->nsCount; goto configNamespace; @@ -596,8 +595,7 @@ AllocObject( char objName[10 + TCL_INTEGER_SPACE]; sprintf(objName, "::oo::Obj%d", ++fPtr->tsdPtr->nsCount); - oPtr->namespacePtr = Tcl_CreateNamespace(interp, objName, oPtr, - ObjectNamespaceDeleted); + oPtr->namespacePtr = Tcl_CreateNamespace(interp, objName, oPtr, NULL); if (oPtr->namespacePtr != NULL) { creationEpoch = fPtr->tsdPtr->nsCount; break; @@ -637,7 +635,7 @@ AllocObject( * access variables in it. [Bug 2950259] */ - ((Namespace *) oPtr->namespacePtr)->earlyDeleteProc = SquelchedNsFirst; + ((Namespace *) oPtr->namespacePtr)->earlyDeleteProc = ObjectNamespaceDeleted; /* * Fill in the rest of the non-zero/NULL parts of the structure. @@ -752,30 +750,6 @@ MyDeleted( /* * ---------------------------------------------------------------------- * - * SquelchedNsFirst -- - * - * This callback is triggered when the object's namespace is deleted by - * any mechanism. It deletes the object's public command if it has not - * already been deleted, so ensuring that destructors get run at an - * appropriate time. [Bug 2950259] - * - * ---------------------------------------------------------------------- - */ - -static void -SquelchedNsFirst( - ClientData clientData) -{ - Object *oPtr = clientData; - - if (oPtr->command) { - Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->command); - } -} - -/* - * ---------------------------------------------------------------------- - * * ObjectRenamedTrace -- * * This callback is triggered when the object is deleted by any @@ -795,8 +769,6 @@ ObjectRenamedTrace( int flags) /* Why was the object deleted? */ { Object *oPtr = clientData; - Foundation *fPtr = oPtr->fPtr; - /* * If this is a rename and not a delete of the object, we just flush the * cache of the object name. @@ -808,87 +780,35 @@ ObjectRenamedTrace( } /* - * Oh dear, the object really is being deleted. Handle this by running the - * destructors and deleting the object's namespace, which in turn causes - * the real object structures to be deleted. - * - * Note that it is possible for the namespace to be deleted before the - * command. Because of that case, we must take care here to mark the - * command as being deleted so that if we return here we don't run into - * reentrancy problems. - * - * We also do not run destructors on the core class objects when the - * interpreter is being deleted; their incestuous nature causes problems - * in that case when the destructor is partially deleted before the uses - * of it have gone. [Bug 2949397] - */ - - AddRef(oPtr); - AddRef(fPtr->classCls); - AddRef(fPtr->objectCls); - AddRef(fPtr->classCls->thisPtr); - AddRef(fPtr->objectCls->thisPtr); - oPtr->command = NULL; - - if (!(oPtr->flags & DESTRUCTOR_CALLED) && !Tcl_InterpDeleted(interp)) { - CallContext *contextPtr = - TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL); - int result; - Tcl_InterpState state; - - oPtr->flags |= DESTRUCTOR_CALLED; - if (contextPtr != NULL) { - contextPtr->callPtr->flags |= DESTRUCTOR; - contextPtr->skip = 0; - state = Tcl_SaveInterpState(interp, TCL_OK); - result = Tcl_NRCallObjProc(interp, TclOOInvokeContext, - contextPtr, 0, NULL); - if (result != TCL_OK) { - Tcl_BackgroundException(interp, result); - } - Tcl_RestoreInterpState(interp, state); - TclOODeleteContext(contextPtr); - } - } - - /* - * OK, the destructor's been run. Time to splat the class data (if any) - * and nuke the namespace (which triggers the final crushing of the object - * structure itself). - * - * The class of objects needs some special care; if it is deleted (and - * we're not killing the whole interpreter) we force the delete of the - * class of classes now as well. Due to the incestuous nature of those two - * classes, if one goes the other must too and yet the tangle can - * sometimes not go away automatically; we force it here. [Bug 2962664] - */ - - if (!Tcl_InterpDeleted(interp) && IsRootObject(oPtr) - && !Deleted(fPtr->classCls->thisPtr)) { - Tcl_DeleteCommandFromToken(interp, fPtr->classCls->thisPtr->command); - } - - if (oPtr->classPtr != NULL) { - AddRef(oPtr->classPtr); - ReleaseClassContents(interp, oPtr); - } - - /* * The namespace is only deleted if it hasn't already been deleted. [Bug - * 2950259] + * 2950259]. If the namespace has already been deleted, then + * ObjectNamespaceDeleted() has already cleaned up this command. */ - if (oPtr->namespacePtr && ((Namespace *) oPtr->namespacePtr)->earlyDeleteProc != NULL) { - Tcl_DeleteNamespace(oPtr->namespacePtr); - } - if (oPtr->classPtr) { - DelRef(oPtr->classPtr); + if (oPtr->namespacePtr == NULL) { + /* + * ObjectNamespaceDeleted() has already done all the cleanup, but + * detected that the command was in the process of being deleted, and + * left the pointer allocated for us. + */ + DelRef(oPtr); + } else { + if (((Namespace *) oPtr->namespacePtr)->earlyDeleteProc == NULL) { + /* + * ObjectNamespaceDeleted() called us, and still has some work to + * do, so we leave the pointer allocated for it to finish, and then + * it will deallocate the pointer. + */ + } else { + Tcl_DeleteNamespace(oPtr->namespacePtr); + /* + * ObjectNamespaceDeleted() doesn't know it was us that just + * called, so it left the pointer allocated. + */ + DelRef(oPtr); + } } - DelRef(fPtr->classCls->thisPtr); - DelRef(fPtr->objectCls->thisPtr); - DelRef(fPtr->classCls); - DelRef(fPtr->objectCls); - DelRef(oPtr); + return; } /* @@ -960,7 +880,9 @@ ReleaseClassContents( int i; Class *clsPtr = oPtr->classPtr, *mixinSubclassPtr, *subclassPtr; Object *instancePtr; + Method *mPtr; Foundation *fPtr = oPtr->fPtr; + Tcl_Obj *variableObj; /* * Sanity check! @@ -1151,6 +1073,26 @@ ReleaseClassContents( ckfree(clsPtr->metadataPtr); clsPtr->metadataPtr = NULL; } + + ClearMixins(clsPtr); + ClearSuperclasses(clsPtr); + + FOREACH_HASH_VALUE(mPtr, &clsPtr->classMethods) { + TclOODelMethodRef(mPtr); + } + Tcl_DeleteHashTable(&clsPtr->classMethods); + TclOODelMethodRef(clsPtr->constructorPtr); + TclOODelMethodRef(clsPtr->destructorPtr); + + FOREACH(variableObj, clsPtr->variables) { + TclDecrRefCount(variableObj); + } + if (i) { + ckfree(clsPtr->variables.list); + } + + DelRef(clsPtr); + } /* @@ -1172,36 +1114,92 @@ ObjectNamespaceDeleted( * being deleted. */ { Object *oPtr = clientData; + Foundation *fPtr = oPtr->fPtr; FOREACH_HASH_DECLS; - Class *clsPtr = oPtr->classPtr, *mixinPtr; + Class *mixinPtr; Method *mPtr; Tcl_Obj *filterObj, *variableObj; - int deleteAlreadyInProgress = 0, i; + Tcl_Interp *interp = oPtr->fPtr->interp; + int finished = 0, i; + + + AddRef(fPtr->classCls); + AddRef(fPtr->objectCls); + AddRef(fPtr->classCls->thisPtr); + AddRef(fPtr->objectCls->thisPtr); /* - * Instruct everyone to no longer use any allocated fields of the object. - * Also delete the commands that refer to the object at this point (if - * they still exist) because otherwise their references to the object - * point into freed memory, allowing crashes. + * We do not run destructors on the core class objects when the + * interpreter is being deleted; their incestuous nature causes problems + * in that case when the destructor is partially deleted before the uses + * of it have gone. [Bug 2949397] */ - if (oPtr->command) { - if ((((Command *)oPtr->command)->flags && CMD_IS_DELETED)) { - /* - * Namespace deletion must have been triggered by a trace on command - * deletion , meaning that ObjectRenamedTrace() is eventually going - * to be called . - */ - deleteAlreadyInProgress = 1; + if (!(oPtr->flags & DESTRUCTOR_CALLED) && !Tcl_InterpDeleted(interp)) { + CallContext *contextPtr = + TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL); + int result; + + Tcl_InterpState state; + + oPtr->flags |= DESTRUCTOR_CALLED; + if (contextPtr != NULL) { + contextPtr->callPtr->flags |= DESTRUCTOR; + contextPtr->skip = 0; + state = Tcl_SaveInterpState(interp, TCL_OK); + result = Tcl_NRCallObjProc(interp, TclOOInvokeContext, + contextPtr, 0, NULL); + if (result != TCL_OK) { + Tcl_BackgroundException(interp, result); + } + Tcl_RestoreInterpState(interp, state); + TclOODeleteContext(contextPtr); } + } + /* + * Instruct everyone to no longer use any allocated fields of the object. + * Also delete the command that refers to the object at this point (if + * it still exists) because otherwise its pointer to the object + * points into freed memory. + */ + + if ((((Command *)oPtr->command)->flags && CMD_IS_DELETED)) { + /* + * Something has already started the command deletion process. We can + * go ahead and clean up the the namespace, + */ + } else { + /* + * The namespace must have been deleted directly. Delete the command + * as well. + */ Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->command); + finished = 1; } + oPtr->command = NULL; + if (oPtr->myCommand) { Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->myCommand); } /* + * The class of objects needs some special care; if it is deleted (and + * we're not killing the whole interpreter) we force the delete of the + * class of classes now as well. Due to the incestuous nature of those two + * classes, if one goes the other must too and yet the tangle can + * sometimes not go away automatically; we force it here. [Bug 2962664] + */ + if (!Tcl_InterpDeleted(interp) && IsRootObject(oPtr) + && !Deleted(fPtr->classCls->thisPtr)) { + Tcl_DeleteCommandFromToken(interp, fPtr->classCls->thisPtr->command); + } + + if (oPtr->classPtr != NULL) { + ReleaseClassContents(interp, oPtr); + } + + /* * Splice the object out of its context. After this, we must *not* call * methods on the object. */ @@ -1260,77 +1258,27 @@ ObjectNamespaceDeleted( } /* - * If this was a class, there's additional deletion work to do. - */ - - if (clsPtr != NULL) { - Tcl_ObjectMetadataType *metadataTypePtr; - ClientData value; - - if (clsPtr->metadataPtr != NULL) { - FOREACH_HASH(metadataTypePtr, value, clsPtr->metadataPtr) { - metadataTypePtr->deleteProc(value); - } - Tcl_DeleteHashTable(clsPtr->metadataPtr); - ckfree(clsPtr->metadataPtr); - clsPtr->metadataPtr = NULL; - } - - FOREACH(filterObj, clsPtr->filters) { - TclDecrRefCount(filterObj); - } - if (i) { - ckfree(clsPtr->filters.list); - clsPtr->filters.num = 0; - } - - ClearMixins(clsPtr); - - ClearSuperclasses(clsPtr); - - if (clsPtr->subclasses.list) { - ckfree(clsPtr->subclasses.list); - clsPtr->subclasses.list = NULL; - clsPtr->subclasses.num = 0; - } - if (clsPtr->instances.list) { - ckfree(clsPtr->instances.list); - clsPtr->instances.list = NULL; - clsPtr->instances.num = 0; - } - if (clsPtr->mixinSubs.list) { - ckfree(clsPtr->mixinSubs.list); - clsPtr->mixinSubs.list = NULL; - clsPtr->mixinSubs.num = 0; - } - - FOREACH_HASH_VALUE(mPtr, &clsPtr->classMethods) { - TclOODelMethodRef(mPtr); - } - Tcl_DeleteHashTable(&clsPtr->classMethods); - TclOODelMethodRef(clsPtr->constructorPtr); - TclOODelMethodRef(clsPtr->destructorPtr); - - FOREACH(variableObj, clsPtr->variables) { - TclDecrRefCount(variableObj); - } - if (i) { - ckfree(clsPtr->variables.list); - } - - DelRef(clsPtr); - } - - /* * Delete the object structure itself. */ - if (deleteAlreadyInProgress) { - oPtr->classPtr = NULL; - oPtr->namespacePtr = NULL; - } else { + oPtr->classPtr = NULL; + oPtr->namespacePtr = NULL; + + DelRef(fPtr->classCls->thisPtr); + DelRef(fPtr->objectCls->thisPtr); + DelRef(fPtr->classCls); + DelRef(fPtr->objectCls); + if (finished) { + /* + * ObjectRenamedTrace called us, and not the other way around. + */ DelRef(oPtr); + } else { + /* + * ObjectRenamedTrace will call DelRef(oPtr). + */ } + return; } @@ -1424,7 +1372,7 @@ TclOOAddToInstances( void TclOORemoveFromSubclasses( Class *subPtr, /* The subclass to remove. */ - Class *superPtr) /* The superclass to (possibly) remove the + Class *superPtr) /* The superclass to possibly remove the * subclass reference from. */ { int i; @@ -1495,7 +1443,7 @@ TclOOAddToSubclasses( void TclOORemoveFromMixinSubs( Class *subPtr, /* The subclass to remove. */ - Class *superPtr) /* The superclass to (possibly) remove the + Class *superPtr) /* The superclass to possibly remove the * subclass reference from. */ { int i; @@ -1569,7 +1517,7 @@ AllocClass( * class. */ Object *useThisObj) /* Object that is to act as the class * representation, or NULL if a new object - * (with automatic name) is to be used. */ + * with automatic name is to be used. */ { Foundation *fPtr = GetFoundation(interp); Class *clsPtr = ckalloc(sizeof(Class)); @@ -1641,7 +1589,6 @@ AllocClass( * * ---------------------------------------------------------------------- */ - Tcl_Object Tcl_NewObjectInstance( Tcl_Interp *interp, /* Interpreter context. */ @@ -1658,54 +1605,14 @@ Tcl_NewObjectInstance( * constructor. */ { register Class *classPtr = (Class *) cls; - Foundation *fPtr = GetFoundation(interp); Object *oPtr; - /* - * Check if we're going to create an object over an existing command; - * that's not allowed. - */ - - if (nameStr && Tcl_FindCommand(interp, nameStr, NULL, - TCL_NAMESPACE_ONLY)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't create object \"%s\": command already exists with" - " that name", nameStr)); - Tcl_SetErrorCode(interp, "TCL", "OO", "OVERWRITE_OBJECT", NULL); - return NULL; - } - - /* - * Create the object. - */ - - oPtr = AllocObject(interp, nameStr, nsNameStr); - oPtr->selfCls = classPtr; - TclOOAddToInstances(oPtr, classPtr); - - /* - * Check to see if we're really creating a class. If so, allocate the - * class structure as well. - */ - - if (TclOOIsReachable(fPtr->classCls, classPtr)) { - /* - * Is a class, so attach a class structure. Note that the AllocClass - * function splices the structure into the object, so we don't have - * to. Once that's done, we need to repatch the object to have the - * right class since AllocClass interferes with that. - */ - - AllocClass(interp, oPtr); - oPtr->selfCls = classPtr; - TclOOAddToSubclasses(oPtr->classPtr, fPtr->objectCls); - } else { - oPtr->classPtr = NULL; - } + oPtr = TclNewObjectInstanceCommon(interp, classPtr, nameStr, nsNameStr); + if (oPtr == NULL) {return NULL;} /* - * Run constructors, except when objc < 0 (a special flag case used for - * object cloning only). + * Run constructors, except when objc < 0, which is a special flag case + * used for object cloning only. */ if (objc >= 0) { @@ -1733,9 +1640,8 @@ Tcl_NewObjectInstance( } /* - * It's an error if the object was whacked in the constructor. - * Force this if it isn't already an error (don't want to lose - * errors by accident...) [Bug 2903011] + * Ensure an error if the object was deleted in the constructor. + * Don't want to lose errors by accident. [Bug 2903011] */ if (result != TCL_ERROR && Deleted(oPtr)) { @@ -1786,7 +1692,6 @@ TclNRNewObjectInstance( * successful allocation. */ { register Class *classPtr = (Class *) cls; - Foundation *fPtr = GetFoundation(interp); CallContext *contextPtr; Tcl_InterpState state; Object *oPtr; @@ -1796,45 +1701,8 @@ TclNRNewObjectInstance( */ AddRef(classPtr); - /* - * Check if we're going to create an object over an existing command; - * that's not allowed. - */ - - if (nameStr && Tcl_FindCommand(interp, nameStr, NULL, - TCL_NAMESPACE_ONLY)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't create object \"%s\": command already exists with" - " that name", nameStr)); - Tcl_SetErrorCode(interp, "TCL", "OO", "OVERWRITE_OBJECT", NULL); - return TCL_ERROR; - } - - /* - * Create the object. - */ - - oPtr = AllocObject(interp, nameStr, nsNameStr); - oPtr->selfCls = classPtr; - TclOOAddToInstances(oPtr, classPtr); - - /* - * Check to see if we're really creating a class. If so, allocate the - * class structure as well. - */ - - if (TclOOIsReachable(fPtr->classCls, classPtr)) { - /* - * Is a class, so attach a class structure. Note that the AllocClass - * function splices the structure into the object, so we don't have - * to. Once that's done, we need to repatch the object to have the - * right class since AllocClass interferes with that. - */ - - AllocClass(interp, oPtr); - oPtr->selfCls = classPtr; - TclOOAddToSubclasses(oPtr->classPtr, fPtr->objectCls); - } + oPtr = TclNewObjectInstanceCommon(interp, classPtr, nameStr, nsNameStr); + if (oPtr == NULL) {return TCL_ERROR;} /* * Run constructors, except when objc < 0 (a special flag case used for @@ -1877,6 +1745,62 @@ TclNRNewObjectInstance( return TclOOInvokeContext(contextPtr, interp, objc, objv); } + +Object * +TclNewObjectInstanceCommon( + Tcl_Interp *interp, + Class *classPtr, + const char *nameStr, + const char *nsNameStr) +{ + Foundation *fPtr = GetFoundation(interp); + Object *oPtr; + + /* + * Disallow creation of an object over an existing command. + */ + + if (nameStr && Tcl_FindCommand(interp, nameStr, NULL, + TCL_NAMESPACE_ONLY)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't create object \"%s\": command already exists with" + " that name", nameStr)); + Tcl_SetErrorCode(interp, "TCL", "OO", "OVERWRITE_OBJECT", NULL); + return NULL; + } + + /* + * Create the object. + */ + + oPtr = AllocObject(interp, nameStr, nsNameStr); + oPtr->selfCls = classPtr; + TclOOAddToInstances(oPtr, classPtr); + + /* + * Check to see if we're really creating a class. If so, allocate the + * class structure as well. + */ + + if (TclOOIsReachable(fPtr->classCls, classPtr)) { + /* + * Is a class, so attach a class structure. Note that the AllocClass + * function splices the structure into the object, so we don't have + * to. Once that's done, we need to repatch the object to have the + * right class since AllocClass interferes with that. + */ + + AllocClass(interp, oPtr); + oPtr->selfCls = classPtr; + TclOOAddToSubclasses(oPtr->classPtr, fPtr->objectCls); + } else { + oPtr->classPtr = NULL; + } + return oPtr; +} + + + static int FinalizeAlloc( ClientData data[], diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h index 11ba698..83b4d58 100644 --- a/generic/tclOOInt.h +++ b/generic/tclOOInt.h @@ -495,6 +495,10 @@ MODULE_SCOPE int TclNRNewObjectInstance(Tcl_Interp *interp, const char *nsNameStr, int objc, Tcl_Obj *const *objv, int skip, Tcl_Object *objectPtr); +MODULE_SCOPE Object * TclNewObjectInstanceCommon(Tcl_Interp *interp, + Class *classPtr, + const char *nameStr, + const char *nsNameStr); MODULE_SCOPE int TclOODefineSlots(Foundation *fPtr); MODULE_SCOPE void TclOODeleteChain(CallChain *callPtr); MODULE_SCOPE void TclOODeleteChainCache(Tcl_HashTable *tablePtr); -- cgit v0.12 From a8a602d3ffaf67e797df3e1a1e9a57124c43e267 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Mon, 27 Nov 2017 23:30:57 +0000 Subject: Eliminate some duplicate code in tclOO.c/Tcl_NewObjectInstance(). --- generic/tclOO.c | 39 ++++++++++----------------------------- 1 file changed, 10 insertions(+), 29 deletions(-) diff --git a/generic/tclOO.c b/generic/tclOO.c index 3fece42..07a96a7 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -1606,6 +1606,7 @@ Tcl_NewObjectInstance( { register Class *classPtr = (Class *) cls; Object *oPtr; + ClientData clientData[4]; oPtr = TclNewObjectInstanceCommon(interp, classPtr, nameStr, nsNameStr); if (oPtr == NULL) {return NULL;} @@ -1639,35 +1640,16 @@ Tcl_NewObjectInstance( TclResetRewriteEnsemble(interp, 1); } - /* - * Ensure an error if the object was deleted in the constructor. - * Don't want to lose errors by accident. [Bug 2903011] - */ + clientData[0] = contextPtr; + clientData[1] = oPtr; + clientData[2] = state; + clientData[3] = &oPtr; - if (result != TCL_ERROR && Deleted(oPtr)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "object deleted in constructor", -1)); - Tcl_SetErrorCode(interp, "TCL", "OO", "STILLBORN", NULL); - result = TCL_ERROR; - } - TclOODeleteContext(contextPtr); + AddRef(oPtr); + result = FinalizeAlloc(clientData, interp, result); if (result != TCL_OK) { - Tcl_DiscardInterpState(state); - - /* - * Take care to not delete a deleted object; that would be - * bad. [Bug 2903011] Also take care to make sure that we have - * the name of the command before we delete it. [Bug - * 9dd1bd7a74] - */ - - if (!Deleted(oPtr)) { - (void) TclOOObjectName(interp, oPtr); - Tcl_DeleteCommandFromToken(interp, oPtr->command); - } return NULL; } - Tcl_RestoreInterpState(interp, state); } } @@ -1726,7 +1708,7 @@ TclNRNewObjectInstance( contextPtr->skip = skip; /* - * Adjust the ensmble tracking record if necessary. [Bug 3514761] + * Adjust the ensemble tracking record if necessary. [Bug 3514761] */ if (TclInitRewriteEnsemble(interp, skip, skip, objv)) { @@ -1813,9 +1795,8 @@ FinalizeAlloc( Tcl_Object *objectPtr = data[3]; /* - * It's an error if the object was whacked in the constructor. Force this - * if it isn't already an error (don't want to lose errors by accident...) - * [Bug 2903011] + * Ensure an error if the object was deleted in the constructor. + * Don't want to lose errors by accident. [Bug 2903011] */ if (result != TCL_ERROR && Deleted(oPtr)) { -- cgit v0.12 From fe65a79d19b49f2cb167f72b3e422a71be69bead Mon Sep 17 00:00:00 2001 From: pooryorick Date: Tue, 28 Nov 2017 15:43:41 +0000 Subject: Minor refactoring of TclOO object reference count booking during object creation. --- generic/tclOO.c | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/generic/tclOO.c b/generic/tclOO.c index 07a96a7..d7ae349 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -1678,11 +1678,6 @@ TclNRNewObjectInstance( Tcl_InterpState state; Object *oPtr; - /* - * Protect classPtr from getting cleaned up when the command is created. - */ - AddRef(classPtr); - oPtr = TclNewObjectInstanceCommon(interp, classPtr, nameStr, nsNameStr); if (oPtr == NULL) {return TCL_ERROR;} @@ -1693,13 +1688,11 @@ TclNRNewObjectInstance( if (objc < 0) { *objectPtr = (Tcl_Object) oPtr; - DelRef(classPtr); return TCL_OK; } contextPtr = TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL); if (contextPtr == NULL) { *objectPtr = (Tcl_Object) oPtr; - DelRef(classPtr); return TCL_OK; } @@ -1723,7 +1716,6 @@ TclNRNewObjectInstance( TclNRAddCallback(interp, FinalizeAlloc, contextPtr, oPtr, state, objectPtr); TclPushTailcallPoint(interp); - DelRef(classPtr); return TclOOInvokeContext(contextPtr, interp, objc, objv); } @@ -1755,7 +1747,15 @@ TclNewObjectInstanceCommon( * Create the object. */ + /* + * The command for the object could have the same name as the command + * associated with classPtr, so protect the structure from deallocation + * here. + */ + AddRef(classPtr); + oPtr = AllocObject(interp, nameStr, nsNameStr); + DelRef(classPtr); oPtr->selfCls = classPtr; TclOOAddToInstances(oPtr, classPtr); -- cgit v0.12 From 8396e878da979c46691b73731c51888f05e7bb77 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Tue, 28 Nov 2017 23:33:14 +0000 Subject: Fix for issue [6cf568a21b]: Tcl_Eval() causes new segfault (TclOO object creation by qualified name). --- generic/tclOO.c | 60 +++++++++++++++++++++++++++++++-------------------------- tests/oo.test | 3 +++ 2 files changed, 36 insertions(+), 27 deletions(-) diff --git a/generic/tclOO.c b/generic/tclOO.c index d7ae349..93abf3f 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -59,7 +59,7 @@ static const struct { static Class * AllocClass(Tcl_Interp *interp, Object *useThisObj); static Object * AllocObject(Tcl_Interp *interp, const char *nameStr, - const char *nsNameStr); + Namespace *nsPtr, const char *nsNameStr); static void ClearMixins(Class *clsPtr); static void ClearSuperclasses(Class *clsPtr); static int CloneClassMethod(Tcl_Interp *interp, Class *clsPtr, @@ -380,9 +380,9 @@ InitFoundation( */ fPtr->objectCls = AllocClass(interp, - AllocObject(interp, "::oo::object", NULL)); + AllocObject(interp, "object", (Namespace *)fPtr->ooNs, NULL)); fPtr->classCls = AllocClass(interp, - AllocObject(interp, "::oo::class", NULL)); + AllocObject(interp, "class", (Namespace *)fPtr->ooNs, NULL)); fPtr->objectCls->thisPtr->selfCls = fPtr->classCls; fPtr->objectCls->thisPtr->flags |= ROOT_OBJECT; fPtr->objectCls->flags |= ROOT_OBJECT; @@ -552,6 +552,8 @@ AllocObject( * if the OO system should pick the object * name itself (equal to the namespace * name). */ + Namespace *nsPtr, /* The namespace to create the object in, + or NULL if *nameStr is NULL */ const char *nsNameStr) /* The name of the namespace to create, or * NULL if the OO system should pick a unique * name itself. If this is non-NULL but names @@ -562,10 +564,7 @@ AllocObject( Object *oPtr; Command *cmdPtr; CommandTrace *tracePtr; - Namespace *nsPtr, *altNsPtr, *cxtNsPtr; - Tcl_Namespace *inNsPtr; int creationEpoch, ignored; - const char *simpleName; oPtr = ckalloc(sizeof(Object)); memset(oPtr, 0, sizeof(Object)); @@ -653,17 +652,11 @@ AllocObject( * command is deleted). */ - if (nameStr) { - inNsPtr = TclGetCurrentNamespace(interp); - } else { + if (!nameStr) { nameStr = oPtr->namespacePtr->name; - inNsPtr = oPtr->namespacePtr; + nsPtr = (Namespace *)oPtr->namespacePtr; } - - TclGetNamespaceForQualName(interp, nameStr, (Namespace *) inNsPtr, 0, - &nsPtr, &altNsPtr, &cxtNsPtr, &simpleName); - - oPtr->command = TclCreateObjCommandInNs(interp, simpleName, + oPtr->command = TclCreateObjCommandInNs(interp, nameStr, (Tcl_Namespace *)nsPtr, PublicObjectCmd, oPtr, NULL); /* @@ -1528,7 +1521,7 @@ AllocClass( memset(clsPtr, 0, sizeof(Class)); if (useThisObj == NULL) { - clsPtr->thisPtr = AllocObject(interp, NULL, NULL); + clsPtr->thisPtr = AllocObject(interp, NULL, NULL, NULL); } else { clsPtr->thisPtr = useThisObj; } @@ -1727,20 +1720,33 @@ TclNewObjectInstanceCommon( const char *nameStr, const char *nsNameStr) { + Tcl_HashEntry *hPtr; Foundation *fPtr = GetFoundation(interp); Object *oPtr; + const char *simpleName = NULL; + Namespace *nsPtr = NULL, *dummy, + *inNsPtr = (Namespace *)TclGetCurrentNamespace(interp); + int isNew; - /* - * Disallow creation of an object over an existing command. - */ + if (nameStr) { + TclGetNamespaceForQualName(interp, nameStr, inNsPtr, TCL_CREATE_NS_IF_UNKNOWN, + &nsPtr, &dummy, &dummy, &simpleName); - if (nameStr && Tcl_FindCommand(interp, nameStr, NULL, - TCL_NAMESPACE_ONLY)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't create object \"%s\": command already exists with" - " that name", nameStr)); - Tcl_SetErrorCode(interp, "TCL", "OO", "OVERWRITE_OBJECT", NULL); - return NULL; + /* + * Disallow creation of an object over an existing command. + */ + + hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, simpleName, &isNew); + if (isNew) { + /* Just kidding */ + Tcl_DeleteHashEntry(hPtr); + } else { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't create object \"%s\": command already exists with" + " that name", nameStr)); + Tcl_SetErrorCode(interp, "TCL", "OO", "OVERWRITE_OBJECT", NULL); + return NULL; + } } /* @@ -1754,7 +1760,7 @@ TclNewObjectInstanceCommon( */ AddRef(classPtr); - oPtr = AllocObject(interp, nameStr, nsNameStr); + oPtr = AllocObject(interp, simpleName, nsPtr, nsNameStr); DelRef(classPtr); oPtr->selfCls = classPtr; TclOOAddToInstances(oPtr, classPtr); diff --git a/tests/oo.test b/tests/oo.test index b6af1ee..c44ec18 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -128,6 +128,9 @@ test oo-1.3 {basic test of OO functionality: no classes} { test oo-1.4 {basic test of OO functionality} -body { oo::object create {} } -returnCodes 1 -result {object name must not be empty} +test oo-1.4.1 {fully-qualified nested name} -body { + oo::object create ::one::two::three +} -result {::one::two::three} test oo-1.5 {basic test of OO functionality} -body { oo::object doesnotexist } -returnCodes 1 -result {unknown method "doesnotexist": must be create, destroy or new} -- cgit v0.12 From 4fc9a4c991e75f3060fad431f5951cda27377a5a Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 29 Nov 2017 11:04:20 +0000 Subject: Update some functions in tclUtf.c to handle surrogate pairs when TCL_UTF_MAX == 4. Also update documentation to distinguish better between "Tcl_UniChar" and "Unicode character": Those are not necessary the same when TCL_UTF_MAX == 4. No change when TCL_UTF_MAX == 4 or TCL_UTF_MAX == 6. --- doc/ToUpper.3 | 2 +- doc/UniCharIsAlpha.3 | 5 +--- doc/Utf.3 | 2 +- generic/tclUtf.c | 74 ++++++++++++++++++++++++++++++++++++++++------------ 4 files changed, 61 insertions(+), 22 deletions(-) diff --git a/doc/ToUpper.3 b/doc/ToUpper.3 index b933e9c..be614e7 100644 --- a/doc/ToUpper.3 +++ b/doc/ToUpper.3 @@ -33,7 +33,7 @@ int .SH ARGUMENTS .AS char *str in/out .AP int ch in -The Tcl_UniChar to be converted. +The Unicode character to be converted. .AP char *str in/out Pointer to UTF-8 string to be converted in place. .BE diff --git a/doc/UniCharIsAlpha.3 b/doc/UniCharIsAlpha.3 index 2336c34..5ba3fc9 100644 --- a/doc/UniCharIsAlpha.3 +++ b/doc/UniCharIsAlpha.3 @@ -53,14 +53,11 @@ The Tcl_UniChar to be examined. .SH DESCRIPTION .PP -All of the routines described examine Tcl_UniChars and return a +All of the routines described examine Unicode characters and return a boolean value. A non-zero return value means that the character does belong to the character class associated with the called routine. The rest of this document just describes the character classes associated with the various routines. -.PP -Note: A Tcl_UniChar is a Unicode character represented as an unsigned, -fixed-size quantity. .SH "CHARACTER CLASSES" .PP diff --git a/doc/Utf.3 b/doc/Utf.3 index 378c806..9d0c617 100644 --- a/doc/Utf.3 +++ b/doc/Utf.3 @@ -77,7 +77,7 @@ int Buffer in which the UTF-8 representation of the Tcl_UniChar is stored. At most \fBTCL_UTF_MAX\fR bytes are stored in the buffer. .AP int ch in -The Tcl_UniChar to be converted or examined. +The Unicode character to be converted or examined. .AP Tcl_UniChar *chPtr out Filled with the Tcl_UniChar represented by the head of the UTF-8 string. .AP "const char" *src in diff --git a/generic/tclUtf.c b/generic/tclUtf.c index 3b39226..17f769d 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -404,7 +404,7 @@ Tcl_UtfToUniCharDString( * appended to this previously initialized * DString. */ { - Tcl_UniChar ch, *w, *wString; + Tcl_UniChar ch = 0, *w, *wString; const char *p, *end; int oldLength; @@ -528,13 +528,13 @@ Tcl_NumUtfChars( * * Tcl_UtfFindFirst -- * - * Returns a pointer to the first occurance of the given Tcl_UniChar in - * the NULL-terminated UTF-8 string. The NULL terminator is considered + * Returns a pointer to the first occurance of the given Unicode character + * in the NULL-terminated UTF-8 string. The NULL terminator is considered * part of the UTF-8 string. Equivalent to Plan 9 utfrune(). * * Results: - * As above. If the Tcl_UniChar does not exist in the given string, the - * return value is NULL. + * As above. If the Unicode character does not exist in the given string, + * the return value is NULL. * * Side effects: * None. @@ -545,14 +545,21 @@ Tcl_NumUtfChars( const char * Tcl_UtfFindFirst( const char *src, /* The UTF-8 string to be searched. */ - int ch) /* The Tcl_UniChar to search for. */ + int ch) /* The Unicode character to search for. */ { - int len; + int len, fullchar; Tcl_UniChar find = 0; while (1) { len = TclUtfToUniChar(src, &find); - if (find == ch) { + fullchar = find; +#if TCL_UTF_MAX == 4 + if (!len) { + len += TclUtfToUniChar(src, &find); + fullchar = (((fullchar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000; + } +#endif + if (find == fullchar) { return src; } if (*src == '\0') { @@ -567,8 +574,8 @@ Tcl_UtfFindFirst( * * Tcl_UtfFindLast -- * - * Returns a pointer to the last occurance of the given Tcl_UniChar in - * the NULL-terminated UTF-8 string. The NULL terminator is considered + * Returns a pointer to the last occurance of the given Unicode character + * in the NULL-terminated UTF-8 string. The NULL terminator is considered * part of the UTF-8 string. Equivalent to Plan 9 utfrrune(). * * Results: @@ -584,16 +591,23 @@ Tcl_UtfFindFirst( const char * Tcl_UtfFindLast( const char *src, /* The UTF-8 string to be searched. */ - int ch) /* The Tcl_UniChar to search for. */ + int ch) /* The Unicode character to search for. */ { - int len; + int len, fullchar; Tcl_UniChar find = 0; const char *last; last = NULL; while (1) { len = TclUtfToUniChar(src, &find); - if (find == ch) { + fullchar = find; +#if TCL_UTF_MAX == 4 + if (!len) { + len += TclUtfToUniChar(src, &find); + fullchar = (((fullchar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000; + } +#endif + if (find == fullchar) { last = src; } if (*src == '\0') { @@ -1058,6 +1072,15 @@ Tcl_UtfNcmp( cs += TclUtfToUniChar(cs, &ch1); ct += TclUtfToUniChar(ct, &ch2); +#if TCL_UTF_MAX == 4 + /* map high surrogate characters to values > 0xffff */ + if ((ch1 & 0xFC00) == 0xD800) { + ch1 += 0x4000; + } + if ((ch2 & 0xFC00) == 0xD800) { + ch2 += 0x4000; + } +#endif if (ch1 != ch2) { return (ch1 - ch2); } @@ -1090,6 +1113,7 @@ Tcl_UtfNcasecmp( unsigned long numChars) /* Number of UTF chars to compare. */ { Tcl_UniChar ch1 = 0, ch2 = 0; + while (numChars-- > 0) { /* * n must be interpreted as chars, not bytes. @@ -1098,6 +1122,15 @@ Tcl_UtfNcasecmp( */ cs += TclUtfToUniChar(cs, &ch1); ct += TclUtfToUniChar(ct, &ch2); +#if TCL_UTF_MAX == 4 + /* map high surrogate characters to values > 0xffff */ + if ((ch1 & 0xFC00) == 0xD800) { + ch1 += 0x4000; + } + if ((ch2 & 0xFC00) == 0xD800) { + ch2 += 0x4000; + } +#endif if (ch1 != ch2) { ch1 = Tcl_UniCharToLower(ch1); ch2 = Tcl_UniCharToLower(ch2); @@ -1112,7 +1145,7 @@ Tcl_UtfNcasecmp( /* *---------------------------------------------------------------------- * - * Tcl_UtfNcasecmp -- + * TclUtfCasecmp -- * * Compare UTF chars of string cs to string ct case insensitively. * Replacement for strcasecmp in Tcl core, in places where UTF-8 should @@ -1132,11 +1165,20 @@ TclUtfCasecmp( const char *cs, /* UTF string to compare to ct. */ const char *ct) /* UTF string cs is compared to. */ { - while (*cs && *ct) { - Tcl_UniChar ch1, ch2; + Tcl_UniChar ch1 = 0, ch2 = 0; + while (*cs && *ct) { cs += TclUtfToUniChar(cs, &ch1); ct += TclUtfToUniChar(ct, &ch2); +#if TCL_UTF_MAX == 4 + /* map high surrogate characters to values > 0xffff */ + if ((ch1 & 0xFC00) == 0xD800) { + ch1 += 0x4000; + } + if ((ch2 & 0xFC00) == 0xD800) { + ch2 += 0x4000; + } +#endif if (ch1 != ch2) { ch1 = Tcl_UniCharToLower(ch1); ch2 = Tcl_UniCharToLower(ch2); -- cgit v0.12 From c032f5043e88e8f54ac32f526413a3b62c9a20f4 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Wed, 29 Nov 2017 12:01:21 +0000 Subject: Fix for [6bca38d59b], TclOO segmentation fault cleaning up objects that that have mixed themselves into themselves. --- generic/tclOO.c | 128 ++++++++++++++++++++++++++++++++------------------------ tests/oo.test | 33 +++++++++++++-- 2 files changed, 103 insertions(+), 58 deletions(-) diff --git a/generic/tclOO.c b/generic/tclOO.c index 93abf3f..5404abc 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -913,28 +913,30 @@ ReleaseClassContents( } if (!IsRootClass(oPtr)) { FOREACH(instancePtr, clsPtr->instances) { - int j; - if (instancePtr->selfCls == clsPtr) { - instancePtr->flags |= CLASS_GONE; - } - for(j=0 ; jmixins.num ; j++) { - Class *mixin = instancePtr->mixins.list[j]; - Class *nextMixin = NULL; - if (mixin == clsPtr) { - if (j < instancePtr->mixins.num - 1) { - nextMixin = instancePtr->mixins.list[j+1]; - } - if (j == 0) { - instancePtr->mixins.num = 0; - instancePtr->mixins.list = NULL; - } else { - instancePtr->mixins.list[j-1] = nextMixin; + if (instancePtr != oPtr) { + int j; + if (instancePtr->selfCls == clsPtr) { + instancePtr->flags |= CLASS_GONE; + } + for(j=0 ; jmixins.num ; j++) { + Class *mixin = instancePtr->mixins.list[j]; + Class *nextMixin = NULL; + if (mixin == clsPtr) { + if (j < instancePtr->mixins.num - 1) { + nextMixin = instancePtr->mixins.list[j+1]; + } + if (j == 0) { + instancePtr->mixins.num = 0; + instancePtr->mixins.list = NULL; + } else { + instancePtr->mixins.list[j-1] = nextMixin; + } + instancePtr->mixins.num -= 1; } - instancePtr->mixins.num -= 1; } - } - if (instancePtr != NULL && !IsRoot(instancePtr)) { - AddRef(instancePtr); + if (instancePtr != NULL && !IsRoot(instancePtr)) { + AddRef(instancePtr); + } } } } @@ -944,13 +946,15 @@ ReleaseClassContents( */ FOREACH(mixinSubclassPtr, clsPtr->mixinSubs) { - if (!Deleted(mixinSubclassPtr->thisPtr)) { - Tcl_DeleteCommandFromToken(interp, - mixinSubclassPtr->thisPtr->command); + if (mixinSubclassPtr != clsPtr) { + if (!Deleted(mixinSubclassPtr->thisPtr)) { + Tcl_DeleteCommandFromToken(interp, + mixinSubclassPtr->thisPtr->command); + } + ClearMixins(mixinSubclassPtr); + DelRef(mixinSubclassPtr->thisPtr); + DelRef(mixinSubclassPtr); } - ClearMixins(mixinSubclassPtr); - DelRef(mixinSubclassPtr->thisPtr); - DelRef(mixinSubclassPtr); } if (clsPtr->mixinSubs.list != NULL) { ckfree(clsPtr->mixinSubs.list); @@ -985,19 +989,21 @@ ReleaseClassContents( if (!IsRootClass(oPtr)) { FOREACH(instancePtr, clsPtr->instances) { - if (instancePtr == NULL || IsRoot(instancePtr)) { - continue; - } - if (!Deleted(instancePtr)) { - Tcl_DeleteCommandFromToken(interp, instancePtr->command); - /* - * Tcl_DeleteCommandFromToken() may have done to whole - * job for us. Roll back and check again. - */ - i--; - continue; + if (instancePtr != oPtr) { + if (instancePtr == NULL || IsRoot(instancePtr)) { + continue; + } + if (!Deleted(instancePtr)) { + Tcl_DeleteCommandFromToken(interp, instancePtr->command); + /* + * Tcl_DeleteCommandFromToken() may have done to whole + * job for us. Roll back and check again. + */ + i--; + continue; + } + DelRef(instancePtr); } - DelRef(instancePtr); } } if (clsPtr->instances.list != NULL) { @@ -1084,6 +1090,10 @@ ReleaseClassContents( ckfree(clsPtr->variables.list); } + /* Tell oPtr that it's class is gone so that it doesn't try to remove + * itself from it's classe's list of instances + */ + oPtr->flags |= CLASS_GONE; DelRef(clsPtr); } @@ -1177,22 +1187,6 @@ ObjectNamespaceDeleted( } /* - * The class of objects needs some special care; if it is deleted (and - * we're not killing the whole interpreter) we force the delete of the - * class of classes now as well. Due to the incestuous nature of those two - * classes, if one goes the other must too and yet the tangle can - * sometimes not go away automatically; we force it here. [Bug 2962664] - */ - if (!Tcl_InterpDeleted(interp) && IsRootObject(oPtr) - && !Deleted(fPtr->classCls->thisPtr)) { - Tcl_DeleteCommandFromToken(interp, fPtr->classCls->thisPtr->command); - } - - if (oPtr->classPtr != NULL) { - ReleaseClassContents(interp, oPtr); - } - - /* * Splice the object out of its context. After this, we must *not* call * methods on the object. */ @@ -1202,7 +1196,7 @@ ObjectNamespaceDeleted( } FOREACH(mixinPtr, oPtr->mixins) { - if (mixinPtr) { + if (mixinPtr && mixinPtr != oPtr->classPtr) { TclOORemoveFromInstances(oPtr, mixinPtr); } } @@ -1251,6 +1245,30 @@ ObjectNamespaceDeleted( } /* + * Because an object can be a class that is an instance of itself, the + * A class object's class structure should only be cleaned after most of + * the cleanup on the object is done. + */ + + + /* + * The class of objects needs some special care; if it is deleted (and + * we're not killing the whole interpreter) we force the delete of the + * class of classes now as well. Due to the incestuous nature of those two + * classes, if one goes the other must too and yet the tangle can + * sometimes not go away automatically; we force it here. [Bug 2962664] + */ + if (!Tcl_InterpDeleted(interp) && IsRootObject(oPtr) + && !Deleted(fPtr->classCls->thisPtr)) { + Tcl_DeleteCommandFromToken(interp, fPtr->classCls->thisPtr->command); + } + + if (oPtr->classPtr != NULL) { + ReleaseClassContents(interp, oPtr); + } + + + /* * Delete the object structure itself. */ diff --git a/tests/oo.test b/tests/oo.test index c44ec18..556d529 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -1501,7 +1501,7 @@ test oo-11.5 {OO: cleanup} { test oo-11.6 { OO: cleanup ReleaseClassContents() where class is mixed into one of its instances -} { +} -body { oo::class create obj1 ::oo::define obj1 {self mixin [self]} @@ -1509,12 +1509,14 @@ test oo-11.6 { ::oo::objdefine obj2 {mixin [self]} ::oo::copy obj2 obj3 - trace add command obj3 delete [list obj3 dying] + rename obj3 {} rename obj2 {} # No segmentation fault return done -} done +} -cleanup { + rename obj1 {} +} -result done test oo-12.1 {OO: filters} { oo::class create Aclass @@ -3867,6 +3869,31 @@ test oo-35.5 {Bug 1a56550e96: introspectors must traverse mixin links correctly} } -cleanup { base destroy } -result {{c d e} {c d e}} +test oo-35.6 { + Bug : teardown of an object that is a class that is an instance of itself +} -setup { + oo::class create obj + + oo::copy obj obj1 obj1 + oo::objdefine obj1 { + mixin obj1 obj + } + oo::copy obj1 obj2 + oo::objdefine obj2 { + mixin obj2 obj1 + } +} -body { + rename obj2 {} + rename obj1 {} + # doesn't crash + return done +} -cleanup { + rename obj {} +} -result done + + + + test oo-36.1 {TIP #470: introspection within oo::define} { oo::define oo::object self } ::oo::object -- cgit v0.12 From e87d0bcdf463e1858295c83daaee867dd695dba0 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 29 Nov 2017 12:27:22 +0000 Subject: Fix Tcl_UtfFindFirst()/Tcl_UtfFindLast(), which were broken by [83c0c569d6]. Not detected, because those functions aren't used anywhere in Tcl. So, added new test-cases, makeing sure this doesn't happen again. --- generic/tclTest.c | 54 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ generic/tclUtf.c | 14 +++++++------- tests/utf.test | 11 +++++++++-- 3 files changed, 70 insertions(+), 9 deletions(-) diff --git a/generic/tclTest.c b/generic/tclTest.c index e8539e8..8a59b83 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -407,6 +407,12 @@ static Tcl_FSMatchInDirectoryProc SimpleMatchInDirectory; static int TestNumUtfCharsCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); +static int TestFindFirstCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +static int TestFindLastCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); static int TestHashSystemHashCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); @@ -668,6 +674,10 @@ Tcltest_Init( TestsetobjerrorcodeCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testnumutfchars", TestNumUtfCharsCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "testfindfirst", + TestFindFirstCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "testfindlast", + TestFindLastCmd, NULL, NULL); Tcl_CreateCommand(interp, "testsetplatform", TestsetplatformCmd, NULL, NULL); Tcl_CreateCommand(interp, "teststaticpkg", TeststaticpkgCmd, @@ -6680,6 +6690,50 @@ TestNumUtfCharsCmd( return TCL_OK; } +/* + * Used to check correct operation of Tcl_UtfFindFirst + */ + +static int +TestFindFirstCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + if (objc > 1) { + int len = -1; + + if (objc > 2) { + (void) Tcl_GetIntFromObj(interp, objv[2], &len); + } + Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_UtfFindFirst(Tcl_GetString(objv[1]), len), -1)); + } + return TCL_OK; +} + +/* + * Used to check correct operation of Tcl_UtfFindLast + */ + +static int +TestFindLastCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + if (objc > 1) { + int len = -1; + + if (objc > 2) { + (void) Tcl_GetIntFromObj(interp, objv[2], &len); + } + Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_UtfFindLast(Tcl_GetString(objv[1]), len), -1)); + } + return TCL_OK; +} + #if defined(HAVE_CPUID) || defined(_WIN32) /* *---------------------------------------------------------------------- diff --git a/generic/tclUtf.c b/generic/tclUtf.c index 17f769d..c60e99e 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -100,7 +100,7 @@ static int UtfCount(int ch); static inline int UtfCount( - int ch) /* The Tcl_UniChar whose size is returned. */ + int ch) /* The Unicode character whose size is returned. */ { if ((unsigned)(ch - 1) < (UNICODE_SELF - 1)) { return 1; @@ -556,10 +556,10 @@ Tcl_UtfFindFirst( #if TCL_UTF_MAX == 4 if (!len) { len += TclUtfToUniChar(src, &find); - fullchar = (((fullchar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000; + fullchar = (((fullchar & 0x3ff) << 10) | (find & 0x3ff)) + 0x10000; } #endif - if (find == fullchar) { + if (fullchar == ch) { return src; } if (*src == '\0') { @@ -579,7 +579,7 @@ Tcl_UtfFindFirst( * part of the UTF-8 string. Equivalent to Plan 9 utfrrune(). * * Results: - * As above. If the Tcl_UniChar does not exist in the given string, the + * As above. If the Unicode character does not exist in the given string, the * return value is NULL. * * Side effects: @@ -604,10 +604,10 @@ Tcl_UtfFindLast( #if TCL_UTF_MAX == 4 if (!len) { len += TclUtfToUniChar(src, &find); - fullchar = (((fullchar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000; + fullchar = (((fullchar & 0x3ff) << 10) | (find & 0x3ff)) + 0x10000; } #endif - if (find == fullchar) { + if (fullchar == ch) { last = src; } if (*src == '\0') { @@ -707,7 +707,7 @@ Tcl_UtfPrev( * * Tcl_UniCharAtIndex -- * - * Returns the Unicode character represented at the specified character + * Returns the Tcl_UniChar represented at the specified character * (not byte) position in the UTF-8 string. * * Results: diff --git a/tests/utf.test b/tests/utf.test index 45f9c0c..d0fa7be 100644 --- a/tests/utf.test +++ b/tests/utf.test @@ -86,6 +86,9 @@ test utf-3.1 {Tcl_UtfCharComplete} { } {} testConstraint testnumutfchars [llength [info commands testnumutfchars]] +testConstraint testfindfirst [llength [info commands testfindfirst]] +testConstraint testfindlast [llength [info commands testfindlast]] + test utf-4.1 {Tcl_NumUtfChars: zero length} testnumutfchars { testnumutfchars "" } {0} @@ -118,8 +121,12 @@ test utf-4.10 {Tcl_NumUtfChars: #u0000, calc len, overcomplete} {testnumutfchars testnumutfchars [testbytestring "\x00"] 2 } {2} -test utf-5.1 {Tcl_UtfFindFirsts} { -} {} +test utf-5.1 {Tcl_UtfFindFirst} {testfindfirst testbytestring} { + testfindfirst [testbytestring "abcbc"] 98 +} {bcbc} +test utf-5.1 {Tcl_UtfFindLast} {testfindlast testbytestring} { + testfindlast [testbytestring "abcbc"] 98 +} {bc} test utf-6.1 {Tcl_UtfNext} { } {} -- cgit v0.12 From e68b4918069d622ccc7f9f6f98e8432df3f3baad Mon Sep 17 00:00:00 2001 From: sebres Date: Wed, 29 Nov 2017 13:59:42 +0000 Subject: Cherry-picked test-cases from [046a5af026]: fix for issue [4f6a1ebd64]: ensemble: segmentation fault when -subcommand and -map values are the same object. --- tests/namespace.test | 18 +++++++++++++++++- 1 file changed, 17 insertions(+), 1 deletion(-) diff --git a/tests/namespace.test b/tests/namespace.test index 71b6860..7d41258 100644 --- a/tests/namespace.test +++ b/tests/namespace.test @@ -1576,7 +1576,10 @@ test namespace-42.7 {ensembles: nested} { namespace delete ns set result } {{1 ::ns::x0::z} 1 2 3} -test namespace-42.8 {ensembles: [Bug 1670091]} -setup { +test namespace-42.8 { + ensembles: [Bug 1670091], panic due to pointer to a deallocated List + struct. +} -setup { proc demo args {} variable target [list [namespace which demo] x] proc trial args {variable target; string length $target} @@ -1591,6 +1594,19 @@ test namespace-42.8 {ensembles: [Bug 1670091]} -setup { rename foo {} } -result {} +test namespace-42.9 { + ensembles: [Bug 4f6a1ebd64], segmentation fault due to pointer to a + deallocated List struct. +} -setup { + namespace eval n {namespace ensemble create} + dict set list one ::two + namespace ensemble configure n -subcommands $list -map $list +} -body { + n one +} -cleanup { + namespace delete n +} -returnCodes error -match glob -result {invalid command name*} + test namespace-43.1 {ensembles: dict-driven} { namespace eval ns { namespace export x* -- cgit v0.12 From c47ba70f4545f7c961160a6beb0a466e3bfd5532 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Wed, 29 Nov 2017 18:35:51 +0000 Subject: Add TCL_CREATE_NS_IF_UNKNOWN back into Tcl_CreateEnsemble(). --- generic/tclEnsemble.c | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index c5ccd22..a981851 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -732,7 +732,6 @@ Tcl_CreateEnsemble( Tcl_Namespace *namespacePtr, int flags) { - Tcl_Obj *nameObj = NULL; Namespace *nsPtr = (Namespace *)namespacePtr, *foundNsPtr, *altNsPtr, *actualNsPtr; const char * simpleName; @@ -741,11 +740,8 @@ Tcl_CreateEnsemble( nsPtr = (Namespace *) TclGetCurrentNamespace(interp); } - TclGetNamespaceForQualName(interp, name, nsPtr, 0, + TclGetNamespaceForQualName(interp, name, nsPtr, TCL_CREATE_NS_IF_UNKNOWN, &foundNsPtr, &altNsPtr, &actualNsPtr, &simpleName); - if (nameObj != NULL) { - TclDecrRefCount(nameObj); - } return TclCreateEnsembleInNs(interp, simpleName, (Tcl_Namespace *) foundNsPtr, (Tcl_Namespace *) nsPtr, flags); } -- cgit v0.12 From 72998869a3be3534fec99499faabe2d1557d6bcb Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 30 Nov 2017 13:14:43 +0000 Subject: Fix [8e1e31eac0fd6b6c4452bc108a98ab08c6b64588|8e1e31eac0]: lsort treats NUL chars strangely. Also fix various initializations, which only make a difference when TCL_UTF_MAX == 4. Add new test-cases which demonstrate the fix. For TCL_UTF_MAX == 4, surrogates will now be handled as expected as well when sorting. --- doc/UniCharIsAlpha.3 | 2 +- generic/tclCmdIL.c | 4 +- generic/tclCmdMZ.c | 2 +- generic/tclInt.h | 3 +- generic/tclScan.c | 2 +- generic/tclStringObj.c | 10 ++--- generic/tclUtf.c | 103 +++++++++++++++++++++++++++++++++++-------------- generic/tclUtil.c | 10 ++--- tests/cmdIL.test | 13 +++++++ win/tclWinSerial.c | 2 +- 10 files changed, 105 insertions(+), 46 deletions(-) diff --git a/doc/UniCharIsAlpha.3 b/doc/UniCharIsAlpha.3 index 5ba3fc9..61490ed 100644 --- a/doc/UniCharIsAlpha.3 +++ b/doc/UniCharIsAlpha.3 @@ -48,7 +48,7 @@ int .SH ARGUMENTS .AS int ch .AP int ch in -The Tcl_UniChar to be examined. +The Unicode character to be examined. .BE .SH DESCRIPTION diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 47076ec..b41d312 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -2945,7 +2945,7 @@ Tcl_LsearchObjCmd( double patDouble, objDouble; SortInfo sortInfo; Tcl_Obj *patObj, **listv, *listPtr, *startPtr, *itemPtr; - SortStrCmpFn_t strCmpFn = strcmp; + SortStrCmpFn_t strCmpFn = TclUtfCmp; Tcl_RegExp regexp = NULL; static const char *const options[] = { "-all", "-ascii", "-bisect", "-decreasing", "-dictionary", @@ -4263,7 +4263,7 @@ SortCompare( int order = 0; if (infoPtr->sortMode == SORTMODE_ASCII) { - order = strcmp(elemPtr1->collationKey.strValuePtr, + order = TclUtfCmp(elemPtr1->collationKey.strValuePtr, elemPtr2->collationKey.strValuePtr); } else if (infoPtr->sortMode == SORTMODE_ASCII_NC) { order = TclUtfCasecmp(elemPtr1->collationKey.strValuePtr, diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index ad1dd5f..a206cc5 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -3547,7 +3547,7 @@ TclNRSwitchObjCmd( OPT_LAST }; typedef int (*strCmpFn_t)(const char *, const char *); - strCmpFn_t strCmpFn = strcmp; + strCmpFn_t strCmpFn = TclUtfCmp; mode = OPT_EXACT; foundmode = 0; diff --git a/generic/tclInt.h b/generic/tclInt.h index ef88bf5..ad1d9c6 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3219,6 +3219,7 @@ MODULE_SCOPE int TclTrimLeft(const char *bytes, int numBytes, const char *trim, int numTrim); MODULE_SCOPE int TclTrimRight(const char *bytes, int numBytes, const char *trim, int numTrim); +MODULE_SCOPE int TclUtfCmp(const char *cs, const char *ct); MODULE_SCOPE int TclUtfCasecmp(const char *cs, const char *ct); MODULE_SCOPE int TclUtfCount(int ch); MODULE_SCOPE Tcl_Obj * TclpNativeToNormalized(ClientData clientData); @@ -4446,7 +4447,7 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, */ #define TclUtfToUniChar(str, chPtr) \ - ((((unsigned char) *(str)) < 0xC0) ? \ + ((((unsigned char) *(str)) < 0x80) ? \ ((*(chPtr) = (unsigned char) *(str)), 1) \ : Tcl_UtfToUniChar(str, chPtr)) diff --git a/generic/tclScan.c b/generic/tclScan.c index 7f71262..e0798df 100644 --- a/generic/tclScan.c +++ b/generic/tclScan.c @@ -889,7 +889,7 @@ Tcl_ScanObjCmd( i = (int)sch; #if TCL_UTF_MAX == 4 if (!offset) { - offset = Tcl_UtfToUniChar(string, &sch); + offset = TclUtfToUniChar(string, &sch); i = (((i<<10) & 0x0FFC00) + 0x10000) + (sch & 0x3FF); } #endif diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 547f7c6..b943095 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -1869,20 +1869,20 @@ Tcl_AppendFormatToObj( } else if (ch == 'I') { if ((format[1] == '6') && (format[2] == '4')) { format += (step + 2); - step = Tcl_UtfToUniChar(format, &ch); + step = TclUtfToUniChar(format, &ch); #ifndef TCL_WIDE_INT_IS_LONG useWide = 1; #endif } else if ((format[1] == '3') && (format[2] == '2')) { format += (step + 2); - step = Tcl_UtfToUniChar(format, &ch); + step = TclUtfToUniChar(format, &ch); } else { format += step; - step = Tcl_UtfToUniChar(format, &ch); + step = TclUtfToUniChar(format, &ch); } } else if ((ch == 't') || (ch == 'z')) { format += step; - step = Tcl_UtfToUniChar(format, &ch); + step = TclUtfToUniChar(format, &ch); #ifndef TCL_WIDE_INT_IS_LONG if (sizeof(size_t) > sizeof(int)) { useWide = 1; @@ -1890,7 +1890,7 @@ Tcl_AppendFormatToObj( #endif } else if ((ch == 'q') ||(ch == 'j')) { format += step; - step = Tcl_UtfToUniChar(format, &ch); + step = TclUtfToUniChar(format, &ch); #ifndef TCL_WIDE_INT_IS_LONG useWide = 1; #endif diff --git a/generic/tclUtf.c b/generic/tclUtf.c index a72394d..43636b4 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -720,8 +720,7 @@ Tcl_UniCharAtIndex( { Tcl_UniChar ch = 0; - while (index >= 0) { - index--; + while (index-- >= 0) { src += TclUtfToUniChar(src, &ch); } return ch; @@ -751,8 +750,7 @@ Tcl_UtfAtIndex( { Tcl_UniChar ch = 0; - while (index > 0) { - index--; + while (index-- > 0) { src += TclUtfToUniChar(src, &ch); } return src; @@ -1066,16 +1064,17 @@ Tcl_UtfNcmp( cs += TclUtfToUniChar(cs, &ch1); ct += TclUtfToUniChar(ct, &ch2); + if (ch1 != ch2) { #if TCL_UTF_MAX == 4 - /* map high surrogate characters to values > 0xffff */ - if ((ch1 & 0xFC00) == 0xD800) { - ch1 += 0x4000; - } - if ((ch2 & 0xFC00) == 0xD800) { - ch2 += 0x4000; - } + /* Surrogates always report higher than non-surrogates */ + if (((ch1 & 0xFC00) == 0xD800)) { + if ((ch2 & 0xFC00) != 0xD800) { + return ch1; + } + } else if ((ch2 & 0xFC00) == 0xD800) { + return -ch2; + } #endif - if (ch1 != ch2) { return (ch1 - ch2); } } @@ -1116,16 +1115,17 @@ Tcl_UtfNcasecmp( */ cs += TclUtfToUniChar(cs, &ch1); ct += TclUtfToUniChar(ct, &ch2); + if (ch1 != ch2) { #if TCL_UTF_MAX == 4 - /* map high surrogate characters to values > 0xffff */ - if ((ch1 & 0xFC00) == 0xD800) { - ch1 += 0x4000; - } - if ((ch2 & 0xFC00) == 0xD800) { - ch2 += 0x4000; - } + /* Surrogates always report higher than non-surrogates */ + if (((ch1 & 0xFC00) == 0xD800)) { + if ((ch2 & 0xFC00) != 0xD800) { + return ch1; + } + } else if ((ch2 & 0xFC00) == 0xD800) { + return -ch2; + } #endif - if (ch1 != ch2) { ch1 = Tcl_UniCharToLower(ch1); ch2 = Tcl_UniCharToLower(ch2); if (ch1 != ch2) { @@ -1135,6 +1135,52 @@ Tcl_UtfNcasecmp( } return 0; } + +/* + *---------------------------------------------------------------------- + * + * Tcl_UtfCmp -- + * + * Compare UTF chars of string cs to string ct case sensitively. + * Replacement for strcmp in Tcl core, in places where UTF-8 should + * be handled. + * + * Results: + * Return <0 if cs < ct, 0 if cs == ct, or >0 if cs > ct. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclUtfCmp( + const char *cs, /* UTF string to compare to ct. */ + const char *ct) /* UTF string cs is compared to. */ +{ + Tcl_UniChar ch1 = 0, ch2 = 0; + + while (*cs && *ct) { + cs += TclUtfToUniChar(cs, &ch1); + ct += TclUtfToUniChar(ct, &ch2); + if (ch1 != ch2) { +#if TCL_UTF_MAX == 4 + /* Surrogates always report higher than non-surrogates */ + if (((ch1 & 0xFC00) == 0xD800)) { + if ((ch2 & 0xFC00) != 0xD800) { + return ch1; + } + } else if ((ch2 & 0xFC00) == 0xD800) { + return -ch2; + } +#endif + return ch1 - ch2; + } + } + return UCHAR(*cs) - UCHAR(*ct); +} + /* *---------------------------------------------------------------------- @@ -1164,16 +1210,17 @@ TclUtfCasecmp( while (*cs && *ct) { cs += TclUtfToUniChar(cs, &ch1); ct += TclUtfToUniChar(ct, &ch2); + if (ch1 != ch2) { #if TCL_UTF_MAX == 4 - /* map high surrogate characters to values > 0xffff */ - if ((ch1 & 0xFC00) == 0xD800) { - ch1 += 0x4000; - } - if ((ch2 & 0xFC00) == 0xD800) { - ch2 += 0x4000; - } + /* Surrogates always report higher than non-surrogates */ + if (((ch1 & 0xFC00) == 0xD800)) { + if ((ch2 & 0xFC00) != 0xD800) { + return ch1; + } + } else if ((ch2 & 0xFC00) == 0xD800) { + return -ch2; + } #endif - if (ch1 != ch2) { ch1 = Tcl_UniCharToLower(ch1); ch2 = Tcl_UniCharToLower(ch2); if (ch1 != ch2) { diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 8ebace5..51af016 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -1665,6 +1665,7 @@ TclTrimRight( { const char *p = bytes + numBytes; int pInc; + Tcl_UniChar ch1 = 0, ch2 = 0; if ((bytes[numBytes] != '\0') || (trim[numTrim] != '\0')) { Tcl_Panic("TclTrimRight works only on null-terminated strings"); @@ -1683,7 +1684,6 @@ TclTrimRight( */ do { - Tcl_UniChar ch1; const char *q = trim; int bytesLeft = numTrim; @@ -1695,7 +1695,6 @@ TclTrimRight( */ do { - Tcl_UniChar ch2; int qInc = TclUtfToUniChar(q, &ch2); if (ch1 == ch2) { @@ -1745,6 +1744,7 @@ TclTrimLeft( int numTrim) /* ...and its length in bytes */ { const char *p = bytes; + Tcl_UniChar ch1 = 0, ch2 = 0; if ((bytes[numBytes] != '\0') || (trim[numTrim] != '\0')) { Tcl_Panic("TclTrimLeft works only on null-terminated strings"); @@ -1763,7 +1763,6 @@ TclTrimLeft( */ do { - Tcl_UniChar ch1; int pInc = TclUtfToUniChar(p, &ch1); const char *q = trim; int bytesLeft = numTrim; @@ -1773,7 +1772,6 @@ TclTrimLeft( */ do { - Tcl_UniChar ch2; int qInc = TclUtfToUniChar(q, &ch2); if (ch1 == ch2) { @@ -2107,7 +2105,7 @@ Tcl_StringCaseMatch( { int p, charLen; const char *pstart = pattern; - Tcl_UniChar ch1, ch2; + Tcl_UniChar ch1 = 0, ch2 = 0; while (1) { p = *pattern; @@ -2217,7 +2215,7 @@ Tcl_StringCaseMatch( */ if (p == '[') { - Tcl_UniChar startChar, endChar; + Tcl_UniChar startChar = 0, endChar = 0; pattern++; if (UCHAR(*str) < 0x80) { diff --git a/tests/cmdIL.test b/tests/cmdIL.test index 70ac6bb..df59e6e 100644 --- a/tests/cmdIL.test +++ b/tests/cmdIL.test @@ -19,6 +19,7 @@ catch [list package require -exact Tcltest [info patchlevel]] # Used for constraining memory leak tests testConstraint memory [llength [info commands memory]] testConstraint testobj [llength [info commands testobj]] +testConstraint fullutf [expr {[format %c 0x010000] != "\ufffd"}] test cmdIL-1.1 {Tcl_LsortObjCmd procedure} -returnCodes error -body { lsort @@ -147,6 +148,18 @@ test cmdIL-1.36 {lsort -stride and -index: Bug 2918962} { {{b i g} 12345} {{d e m o} 34512} } } {{{b i g} 12345} {{d e m o} 34512} {{c o d e} 54321} {{b l a h} 94729}} +test cmdIL-1.37 {Tcl_LsortObjCmd procedure, Bug 8e1e31eac0fd6b6c} { + lsort -ascii [list \0 \x7f \x80 \uffff] +} [list \0 \x7f \x80 \uffff] +test cmdIL-1.38 {Tcl_LsortObjCmd procedure, Bug 8e1e31eac0fd6b6c} { + lsort -ascii -nocase [list \0 \x7f \x80 \uffff] +} [list \0 \x7f \x80 \uffff] +test cmdIL-1.39 {Tcl_LsortObjCmd procedure, Bug 8e1e31eac0fd6b6c} fullutf { + lsort -ascii [list \0 \x7f \x80 \U01ffff \uffff] +} [list \0 \x7f \x80 \uffff \U01ffff] +test cmdIL-1.40 {Tcl_LsortObjCmd procedure, Bug 8e1e31eac0fd6b6c} fullutf { + lsort -ascii -nocase [list \0 \x7f \x80 \U01ffff \uffff] +} [list \0 \x7f \x80 \uffff \U01ffff] # Can't think of any good tests for the MergeSort and MergeLists procedures, # except a bunch of random lists to sort. diff --git a/win/tclWinSerial.c b/win/tclWinSerial.c index ed1a8e5..acfeecb 100644 --- a/win/tclWinSerial.c +++ b/win/tclWinSerial.c @@ -1738,7 +1738,7 @@ SerialSetOptionProc( dcb.XonChar = argv[0][0]; dcb.XoffChar = argv[1][0]; if (argv[0][0] & 0x80 || argv[1][0] & 0x80) { - Tcl_UniChar character; + Tcl_UniChar character = 0; int charLen; charLen = Tcl_UtfToUniChar(argv[0], &character); -- cgit v0.12 From d7d31d6041d72ace8e80d409c12749ab819499ec Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 30 Nov 2017 14:14:01 +0000 Subject: Don't provide the setFromAnyProc through the invalidRealType objType. This is a Tcl internal type, extensions shouldn't be able to convert their own Tcl_Obj to this. This shouldn't have been exposed to begin with. Tcl itself never calls it this way. --- generic/tclLink.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclLink.c b/generic/tclLink.c index 7d1e3a8..6f75849 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -638,7 +638,7 @@ static Tcl_ObjType invalidRealType = { NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ NULL, /* updateStringProc */ - SetInvalidRealFromAny /* setFromAnyProc */ + NULL /* setFromAnyProc */ }; static int -- cgit v0.12 From 99798b2202f0a40a22c5d5e2d457759a5526005a Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 30 Nov 2017 15:24:39 +0000 Subject: Fix build of test-suite, after previous commit --- generic/tclIntDecls.h | 63 +++++++++++++++++++++++++++++++++++++++++---------- 1 file changed, 51 insertions(+), 12 deletions(-) diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index f2654c0..c3ee084 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -1354,31 +1354,70 @@ extern const TclIntStubs *tclIntStubsPtr; # undef TclSetStartupScript # undef TclGetStartupScript # undef TclCreateNamespace -# define tcl_CreateNamespace tclCreateNamespace # undef TclDeleteNamespace -# define tcl_DeleteNamespace tclDeleteNamespace # undef TclAppendExportList -# define tcl_AppendExportList tclAppendExportList # undef TclExport -# define tcl_Export tclExport # undef TclImport -# define tcl_Import tclImport # undef TclForgetImport -# define tcl_ForgetImport tclForgetImport # undef TclGetCurrentNamespace_ -# define tcl_GetCurrentNamespace tclGetCurrentNamespace_ # undef TclGetGlobalNamespace_ -# define tcl_GetGlobalNamespace tclGetGlobalNamespace_ # undef TclFindNamespace -# define tcl_FindNamespace tclFindNamespace # undef TclFindCommand -# define tcl_FindCommand tclFindCommand # undef TclGetCommandFromObj -# define tcl_GetCommandFromObj tclGetCommandFromObj # undef TclGetCommandFullName -# define tcl_GetCommandFullName tclGetCommandFullName # undef TclCopyChannelOld # undef TclSockMinimumBuffersOld + +#if !defined(TCL_NO_DEPRECATED) +# undef Tcl_CreateNamespace +# define Tcl_CreateNamespace \ + (tclIntStubsPtr->tclCreateNamespace) /* 113 */ +# define tcl_CreateNamespace tclCreateNamespace +# undef Tcl_DeleteNamespace +# define Tcl_DeleteNamespace \ + (tclIntStubsPtr->tclDeleteNamespace) /* 114 */ +# define tcl_DeleteNamespace tclDeleteNamespace +# undef Tcl_AppendExportList +# define Tcl_AppendExportList \ + (tclIntStubsPtr->tclAppendExportList) /* 112 */ +# define tcl_AppendExportList tclAppendExportList +# undef Tcl_Export +# define Tcl_Export \ + (tclIntStubsPtr->tclExport) /* 115 */ +# define tcl_Export tclExport +# undef Tcl_Import +# define Tcl_Import \ + (tclIntStubsPtr->tclImport) /* 127 */ +# define tcl_Import tclImport +# undef Tcl_ForgetImport +# define Tcl_ForgetImport \ + (tclIntStubsPtr->tclForgetImport) /* 121 */ +# define tcl_ForgetImport tclForgetImport +# undef Tcl_GetCurrentNamespace +# define Tcl_GetCurrentNamespace \ + (tclIntStubsPtr->tclGetCurrentNamespace_) /* 124 */ +# define tcl_GetCurrentNamespace tclGetCurrentNamespace_ +# undef Tcl_GetGlobalNamespace +# define Tcl_GetGlobalNamespace \ + (tclIntStubsPtr->tclGetGlobalNamespace_) /* 125 */ +# define tcl_GetGlobalNamespace tclGetGlobalNamespace_ +# undef Tcl_FindNamespace +# define Tcl_FindNamespace \ + (tclIntStubsPtr->tclFindNamespace) /* 117 */ +# define tcl_FindNamespace tclFindNamespace +# undef Tcl_FindCommand +# define Tcl_FindCommand \ + (tclIntStubsPtr->tclFindCommand) /* 116 */ +# define tcl_FindCommand tclFindCommand +# undef Tcl_GetCommandFromObj +# define Tcl_GetCommandFromObj \ + (tclIntStubsPtr->tclGetCommandFromObj) /* 122 */ +# define tcl_GetCommandFromObj tclGetCommandFromObj +# undef Tcl_GetCommandFullName +# define Tcl_GetCommandFullName \ + (tclIntStubsPtr->tclGetCommandFullName) /* 123 */ +# define tcl_GetCommandFullName tclGetCommandFullName +#endif /* !defined(TCL_NO_DEPRECATED) */ #endif #endif /* _TCLINTDECLS */ -- cgit v0.12 From 0efada5548249fb9f61dcd3a5eea4ceb381e3e52 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 30 Nov 2017 16:03:01 +0000 Subject: Eliminate use of certain unnecessary struct names. Also white-spacing. Nothing functional. --- generic/tclEncoding.c | 8 ++++---- generic/tclEnsemble.c | 10 +++++----- generic/tclIORTrans.c | 6 +++--- generic/tclIOUtil.c | 2 +- generic/tclOO.c | 6 +++--- tests/oo.test | 4 ++-- 6 files changed, 18 insertions(+), 18 deletions(-) diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 1f48a1c..e1e26d3 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -18,7 +18,7 @@ typedef size_t (LengthProc)(const char *src); * convert between various character sets and UTF-8. */ -typedef struct Encoding { +typedef struct { char *name; /* Name of encoding. Malloced because (1) hash * table entry that owns this encoding may be * freed prior to this encoding being freed, @@ -57,7 +57,7 @@ typedef struct Encoding { * encoding. */ -typedef struct TableEncodingData { +typedef struct { int fallback; /* Character (in this encoding) to substitute * when this encoding cannot represent a UTF-8 * character. */ @@ -91,7 +91,7 @@ typedef struct TableEncodingData { * for switching character sets. */ -typedef struct EscapeSubTable { +typedef struct { unsigned sequenceLen; /* Length of following string. */ char sequence[16]; /* Escape code that marks this encoding. */ char name[32]; /* Name for encoding. */ @@ -100,7 +100,7 @@ typedef struct EscapeSubTable { * yet. */ } EscapeSubTable; -typedef struct EscapeEncodingData { +typedef struct { int fallback; /* Character (in this encoding) to substitute * when this encoding cannot represent a UTF-8 * character. */ diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index a981851..972c33e 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -649,12 +649,12 @@ TclNamespaceEnsembleCmd( Tcl_Command TclCreateEnsembleInNs( - Tcl_Interp *interp, - + Tcl_Interp *interp, + const char *name, /* Simple name of command to create (no */ /* namespace components). */ - Tcl_Namespace /* Name of namespace to create the command in. */ - *nameNsPtr, + Tcl_Namespace /* Name of namespace to create the command in. */ + *nameNsPtr, Tcl_Namespace *ensembleNsPtr, /* Name of the namespace for the ensemble. */ int flags @@ -2591,7 +2591,7 @@ BuildEnsembleConfig( if (ensemblePtr->subcmdList == ensemblePtr->subcommandDict) { subcmdDictCopy = Tcl_DuplicateObj(ensemblePtr->subcommandDict); } else { - subcmdDictCopy = ensemblePtr->subcommandDict; + subcmdDictCopy = ensemblePtr->subcommandDict; } Tcl_IncrRefCount(subcmdDictCopy); } diff --git a/generic/tclIORTrans.c b/generic/tclIORTrans.c index f198c69..fe2e458 100644 --- a/generic/tclIORTrans.c +++ b/generic/tclIORTrans.c @@ -87,7 +87,7 @@ static const Tcl_ChannelType tclRTransformType = { * layers upon reading from the channel, plus the functions to manage such. */ -typedef struct _ResultBuffer_ { +typedef struct { unsigned char *buf; /* Reference to the buffer area. */ int allocated; /* Allocated size of the buffer area. */ int used; /* Number of bytes in the buffer, @@ -253,7 +253,7 @@ typedef enum { * sharing problems. */ -typedef struct ForwardParamBase { +typedef struct { int code; /* O: Ok/Fail of the cmd handler */ char *msgStr; /* O: Error message for handler failure */ int mustFree; /* O: True if msgStr is allocated, false if @@ -298,7 +298,7 @@ typedef struct ForwardingResult ForwardingResult; * General event structure, with reference to operation specific data. */ -typedef struct ForwardingEvent { +typedef struct { Tcl_Event event; /* Basic event data, has to be first item */ ForwardingResult *resultPtr; ForwardedOperation op; /* Forwarded driver operation */ diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index 4f2288e..8fb3aa8 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -245,7 +245,7 @@ static Tcl_ThreadDataKey fsDataKey; * code. */ -typedef struct FsDivertLoad { +typedef struct { Tcl_LoadHandle loadHandle; Tcl_FSUnloadFileProc *unloadProcPtr; Tcl_Obj *divertedFile; diff --git a/generic/tclOO.c b/generic/tclOO.c index 5404abc..84380e0 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -1091,8 +1091,8 @@ ReleaseClassContents( } /* Tell oPtr that it's class is gone so that it doesn't try to remove - * itself from it's classe's list of instances - */ + * itself from it's classe's list of instances + */ oPtr->flags |= CLASS_GONE; DelRef(clsPtr); @@ -1247,7 +1247,7 @@ ObjectNamespaceDeleted( /* * Because an object can be a class that is an instance of itself, the * A class object's class structure should only be cleaned after most of - * the cleanup on the object is done. + * the cleanup on the object is done. */ diff --git a/tests/oo.test b/tests/oo.test index 556d529..b9c5067 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -129,7 +129,7 @@ test oo-1.4 {basic test of OO functionality} -body { oo::object create {} } -returnCodes 1 -result {object name must not be empty} test oo-1.4.1 {fully-qualified nested name} -body { - oo::object create ::one::two::three + oo::object create ::one::two::three } -result {::one::two::three} test oo-1.5 {basic test of OO functionality} -body { oo::object doesnotexist @@ -3889,7 +3889,7 @@ test oo-35.6 { return done } -cleanup { rename obj {} -} -result done +} -result done -- cgit v0.12 From 4bbfdee3db6fbfb19e5d19f48bac51280d2e55fa Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 30 Nov 2017 17:10:37 +0000 Subject: [5808081213] Permit all bytearrays (including impure ones) to report length without shimmering --- generic/tclStringObj.c | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index d43cc45..0f238cf 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -418,12 +418,16 @@ Tcl_GetCharLength( int numChars; /* - * Optimize the case where we're really dealing with a bytearray object - * without string representation; we don't need to convert to a string to - * perform the get-length operation. + * Optimize the case where we're really dealing with a bytearray object; + * we don't need to convert to a string to perform the get-length operation. + * + * NOTE that we do not need the bytearray to be "pure". A ByteArray value + * with a string rep cannot be trusted to represent the same value as the + * string rep, but it *can* be trusted to have the same character length + * as the string rep, which is all this routine cares about. */ - if (TclIsPureByteArray(objPtr)) { + if (objPtr->typePtr == &tclByteArrayType) { int length; (void) Tcl_GetByteArrayFromObj(objPtr, &length); -- cgit v0.12 From 1a237e67df1f72fce66636d7efcd7cffa82bd0b8 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 1 Dec 2017 10:38:04 +0000 Subject: Simpler solution for Itcl 3.4 build (compatibilty) problem. Thanks to Don Porter for bringing this to my attention! --- generic/tclIntDecls.h | 67 ++++++++++++--------------------------------------- 1 file changed, 16 insertions(+), 51 deletions(-) diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index c3ee084..5848bb3 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -28,6 +28,22 @@ # endif #endif +#if !defined(TCL_NO_DEPRECATED) && (TCL_MAJOR_VERSION < 9) +/* Those macro's are especially for Itcl 3.4 compatibility */ +# define tclCreateNamespace tcl_CreateNamespace +# define tclDeleteNamespace tcl_DeleteNamespace +# define tclAppendExportList tcl_AppendExportList +# define tclExport tcl_Export +# define tclImport tcl_Import +# define tclForgetImport tcl_ForgetImport +# define tclGetCurrentNamespace_ tcl_GetCurrentNamespace +# define tclGetGlobalNamespace_ tcl_GetGlobalNamespace +# define tclFindNamespace tcl_FindNamespace +# define tclFindCommand tcl_FindCommand +# define tclGetCommandFromObj tcl_GetCommandFromObj +# define tclGetCommandFullName tcl_GetCommandFullName +#endif /* !defined(TCL_NO_DEPRECATED) */ + /* * WARNING: This file is automatically generated by the tools/genStubs.tcl * script. Any modifications to the function declarations below should be made @@ -1367,57 +1383,6 @@ extern const TclIntStubs *tclIntStubsPtr; # undef TclGetCommandFullName # undef TclCopyChannelOld # undef TclSockMinimumBuffersOld - -#if !defined(TCL_NO_DEPRECATED) -# undef Tcl_CreateNamespace -# define Tcl_CreateNamespace \ - (tclIntStubsPtr->tclCreateNamespace) /* 113 */ -# define tcl_CreateNamespace tclCreateNamespace -# undef Tcl_DeleteNamespace -# define Tcl_DeleteNamespace \ - (tclIntStubsPtr->tclDeleteNamespace) /* 114 */ -# define tcl_DeleteNamespace tclDeleteNamespace -# undef Tcl_AppendExportList -# define Tcl_AppendExportList \ - (tclIntStubsPtr->tclAppendExportList) /* 112 */ -# define tcl_AppendExportList tclAppendExportList -# undef Tcl_Export -# define Tcl_Export \ - (tclIntStubsPtr->tclExport) /* 115 */ -# define tcl_Export tclExport -# undef Tcl_Import -# define Tcl_Import \ - (tclIntStubsPtr->tclImport) /* 127 */ -# define tcl_Import tclImport -# undef Tcl_ForgetImport -# define Tcl_ForgetImport \ - (tclIntStubsPtr->tclForgetImport) /* 121 */ -# define tcl_ForgetImport tclForgetImport -# undef Tcl_GetCurrentNamespace -# define Tcl_GetCurrentNamespace \ - (tclIntStubsPtr->tclGetCurrentNamespace_) /* 124 */ -# define tcl_GetCurrentNamespace tclGetCurrentNamespace_ -# undef Tcl_GetGlobalNamespace -# define Tcl_GetGlobalNamespace \ - (tclIntStubsPtr->tclGetGlobalNamespace_) /* 125 */ -# define tcl_GetGlobalNamespace tclGetGlobalNamespace_ -# undef Tcl_FindNamespace -# define Tcl_FindNamespace \ - (tclIntStubsPtr->tclFindNamespace) /* 117 */ -# define tcl_FindNamespace tclFindNamespace -# undef Tcl_FindCommand -# define Tcl_FindCommand \ - (tclIntStubsPtr->tclFindCommand) /* 116 */ -# define tcl_FindCommand tclFindCommand -# undef Tcl_GetCommandFromObj -# define Tcl_GetCommandFromObj \ - (tclIntStubsPtr->tclGetCommandFromObj) /* 122 */ -# define tcl_GetCommandFromObj tclGetCommandFromObj -# undef Tcl_GetCommandFullName -# define Tcl_GetCommandFullName \ - (tclIntStubsPtr->tclGetCommandFullName) /* 123 */ -# define tcl_GetCommandFullName tclGetCommandFullName -#endif /* !defined(TCL_NO_DEPRECATED) */ #endif #endif /* _TCLINTDECLS */ -- cgit v0.12 From 92f8ce13dfb1299030dc844252d7478caaaa7687 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 4 Dec 2017 18:36:14 +0000 Subject: [4f6a1ebd64] Different fix for the problem. Re-order the filling of the subcommand table so there is no longer a conflict where multiple intreps of a single value are sought. If the mapDict and exportList are the same, then each key in the mapDict is known to be an element of the exportList without needing to check. --- generic/tclNamesp.c | 115 +++++++++++++++++++++++++-------------------------- tests/namespace.test | 19 ++++++++- 2 files changed, 73 insertions(+), 61 deletions(-) diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 4b72e03..18cd07c 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -6582,6 +6582,8 @@ BuildEnsembleConfig( int i, j, isNew; Tcl_HashTable *hash = &ensemblePtr->subcommandTable; Tcl_HashEntry *hPtr; + Tcl_Obj *mapDict = ensemblePtr->subcommandDict; + Tcl_Obj *exportList = ensemblePtr->subcmdList; if (hash->numEntries != 0) { /* @@ -6601,51 +6603,67 @@ BuildEnsembleConfig( Tcl_InitHashTable(hash, TCL_STRING_KEYS); } - /* - * See if we've got an export list. If so, we will only export exactly - * those commands, which may be either implemented by the prefix in the - * subcommandDict or mapped directly onto the namespace's commands. - */ - - if (ensemblePtr->subcmdList != NULL) { - Tcl_Obj **subcmdv, *target, *cmdObj, *cmdPrefixObj; - int subcmdc; + if (mapDict) { + /* + * We have a mapping dictionary to direct filling of the subcommand + * table. Every key, value in the dict should go into the table + * unless we have an export list that holds some of the keys back. + */ - TclListObjGetElements(NULL, ensemblePtr->subcmdList, &subcmdc, - &subcmdv); - for (i=0 ; isubcommandDict != NULL) { - Tcl_DictObjGet(NULL, ensemblePtr->subcommandDict, subcmdv[i], - &target); - if (target != NULL) { - Tcl_SetHashValue(hPtr, target); - Tcl_IncrRefCount(target); - continue; - } - } - - /* - * Not there, so map onto the namespace. Note in this case that we - * do not guarantee that the command is actually there; that is - * the programmer's responsibility (or [::unknown] of course). - */ - + /* Need to put entry in table, but it's not in mapDict */ cmdObj = Tcl_NewStringObj(ensemblePtr->nsPtr->fullName, -1); if (ensemblePtr->nsPtr->parentPtr != NULL) { Tcl_AppendStringsToObj(cmdObj, "::", name, NULL); @@ -6656,28 +6674,7 @@ BuildEnsembleConfig( Tcl_SetHashValue(hPtr, cmdPrefixObj); Tcl_IncrRefCount(cmdPrefixObj); } - } else if (ensemblePtr->subcommandDict != NULL) { - /* - * No subcmd list, but we do have a mapping dictionary so we should - * use the keys of that. Convert the dictionary's contents into the - * form required for the ensemble's internal hashtable. - */ - - Tcl_DictSearch dictSearch; - Tcl_Obj *keyObj, *valueObj; - int done; - - Tcl_DictObjFirst(NULL, ensemblePtr->subcommandDict, &dictSearch, - &keyObj, &valueObj, &done); - while (!done) { - char *name = TclGetString(keyObj); - - hPtr = Tcl_CreateHashEntry(hash, name, &isNew); - Tcl_SetHashValue(hPtr, valueObj); - Tcl_IncrRefCount(valueObj); - Tcl_DictObjNext(&dictSearch, &keyObj, &valueObj, &done); - } - } else { + } else if (mapDict == NULL) { /* * Discover what commands are actually exported by the namespace. * What we have is an array of patterns and a hash table whose keys diff --git a/tests/namespace.test b/tests/namespace.test index 7d41258..0ad8451 100644 --- a/tests/namespace.test +++ b/tests/namespace.test @@ -1599,14 +1599,29 @@ test namespace-42.9 { deallocated List struct. } -setup { namespace eval n {namespace ensemble create} - dict set list one ::two - namespace ensemble configure n -subcommands $list -map $list + set lst [dict create one ::two] + namespace ensemble configure n -subcommands $lst -map $lst } -body { n one } -cleanup { namespace delete n + unset -nocomplain lst } -returnCodes error -match glob -result {invalid command name*} +test namespace-42.10 { + ensembles: [Bug 4f6a1ebd64] segmentation fault due to pointer to a + deallocated List struct (this time with duplicate of one in "dict"). +} -setup { + namespace eval n {namespace ensemble create} + set lst [list one ::two one ::three] + namespace ensemble configure n -subcommands $lst -map $lst +} -body { + n one +} -cleanup { + namespace delete n + unset -nocomplain lst +} -returnCodes error -match glob -result {invalid command name *three*} + test namespace-43.1 {ensembles: dict-driven} { namespace eval ns { namespace export x* -- cgit v0.12 From 8a44c35e8c34860fe2ea418899c8f62fc25e06bb Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 5 Dec 2017 14:36:33 +0000 Subject: Another revised fix, much closer to sebres' patch now. --- generic/tclNamesp.c | 152 +++++++++++++++++++++++++++++++--------------------- 1 file changed, 90 insertions(+), 62 deletions(-) diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 18cd07c..1556ec9 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -6583,7 +6583,7 @@ BuildEnsembleConfig( Tcl_HashTable *hash = &ensemblePtr->subcommandTable; Tcl_HashEntry *hPtr; Tcl_Obj *mapDict = ensemblePtr->subcommandDict; - Tcl_Obj *exportList = ensemblePtr->subcmdList; + Tcl_Obj *subList = ensemblePtr->subcmdList; if (hash->numEntries != 0) { /* @@ -6603,78 +6603,106 @@ BuildEnsembleConfig( Tcl_InitHashTable(hash, TCL_STRING_KEYS); } - if (mapDict) { + if (subList) { + int subc; + Tcl_Obj **subv, *target, *cmdObj, *cmdPrefixObj; + char *name; + /* - * We have a mapping dictionary to direct filling of the subcommand - * table. Every key, value in the dict should go into the table - * unless we have an export list that holds some of the keys back. + * There is a list of exactly what subcommands go in the table. + * Must determine the target for each. */ - Tcl_DictSearch dictSearch; - Tcl_Obj *keyObj, *valueObj; - int done; - - Tcl_DictObjFirst(NULL, mapDict, &dictSearch, &keyObj, &valueObj, &done); - while (!done) { - int nameLen, insert = 1; - char *name = TclGetStringFromObj(keyObj, &nameLen); - - if (exportList && (exportList != mapDict)) { - Tcl_Obj **subv; - int subc; - - insert = 0; - TclListObjGetElements(NULL, exportList, &subc, &subv); - for (i = 0; i < subc; i++) { - int compareLen; - const char *compare - = TclGetStringFromObj(subv[i], &compareLen); - - if ((nameLen == compareLen) - && (memcmp(name, compare, (size_t)nameLen) == 0)) { - insert = 1; - break; - } + Tcl_ListObjGetElements(NULL, subList, &subc, &subv); + if (subList == mapDict) { + /* + * Strange case where explicit list of subcommands is same value + * as the dict mapping to targets. + */ + + for (i = 0; i < subc; i += 2) { + name = TclGetString(subv[i]); + hPtr = Tcl_CreateHashEntry(hash, name, &isNew); + if (!isNew) { + cmdObj = (Tcl_Obj *)Tcl_GetHashValue(hPtr); + Tcl_DecrRefCount(cmdObj); } - } - if (insert) { + Tcl_SetHashValue(hPtr, subv[i+1]); + Tcl_IncrRefCount(subv[i+1]); + + name = TclGetString(subv[i+1]); hPtr = Tcl_CreateHashEntry(hash, name, &isNew); - Tcl_SetHashValue(hPtr, valueObj); - Tcl_IncrRefCount(valueObj); + if (isNew) { + cmdObj = Tcl_NewStringObj(ensemblePtr->nsPtr->fullName, -1); + if (ensemblePtr->nsPtr->parentPtr != NULL) { + Tcl_AppendStringsToObj(cmdObj, "::", name, NULL); + } else { + Tcl_AppendStringsToObj(cmdObj, name, NULL); + } + cmdPrefixObj = Tcl_NewListObj(1, &cmdObj); + Tcl_SetHashValue(hPtr, cmdPrefixObj); + Tcl_IncrRefCount(cmdPrefixObj); + } } - Tcl_DictObjNext(&dictSearch, &keyObj, &valueObj, &done); - } - } - if (exportList) { - /* - * We have an export list. Put into the table each element that's - * not already there. - */ - int subc; - Tcl_Obj **subv, *cmdObj, *cmdPrefixObj; + } else { + /* Usual case where we can freely act on the list and dict. */ - TclListObjGetElements(NULL, exportList, &subc, &subv); - for (i=0 ; insPtr->fullName, -1); - if (ensemblePtr->nsPtr->parentPtr != NULL) { - Tcl_AppendStringsToObj(cmdObj, "::", name, NULL); - } else { - Tcl_AppendStringsToObj(cmdObj, name, NULL); + /* + * target was not in the dictionary so map onto the namespace. + * Note in this case that we do not guarantee that the + * command is actually there; that is the programmer's + * responsibility (or [::unknown] of course). + */ + cmdObj = Tcl_NewStringObj(ensemblePtr->nsPtr->fullName, -1); + if (ensemblePtr->nsPtr->parentPtr != NULL) { + Tcl_AppendStringsToObj(cmdObj, "::", name, NULL); + } else { + Tcl_AppendStringsToObj(cmdObj, name, NULL); + } + cmdPrefixObj = Tcl_NewListObj(1, &cmdObj); + Tcl_SetHashValue(hPtr, cmdPrefixObj); + Tcl_IncrRefCount(cmdPrefixObj); } - cmdPrefixObj = Tcl_NewListObj(1, &cmdObj); - Tcl_SetHashValue(hPtr, cmdPrefixObj); - Tcl_IncrRefCount(cmdPrefixObj); } - } else if (mapDict == NULL) { + } else if (mapDict) { + /* + * No subcmd list, but we do have a mapping dictionary so we should + * use the keys of that. Convert the dictionary's contents into the + * form required for the ensemble's internal hashtable. + */ + + Tcl_DictSearch dictSearch; + Tcl_Obj *keyObj, *valueObj; + int done; + + Tcl_DictObjFirst(NULL, ensemblePtr->subcommandDict, &dictSearch, + &keyObj, &valueObj, &done); + while (!done) { + char *name = TclGetString(keyObj); + + hPtr = Tcl_CreateHashEntry(hash, name, &isNew); + Tcl_SetHashValue(hPtr, valueObj); + Tcl_IncrRefCount(valueObj); + Tcl_DictObjNext(&dictSearch, &keyObj, &valueObj, &done); + } + } else { /* * Discover what commands are actually exported by the namespace. * What we have is an array of patterns and a hash table whose keys -- cgit v0.12 From 3eef9fcea1274b68161aa2c5ebfb6a975ac7143a Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 5 Dec 2017 15:12:05 +0000 Subject: Factor clearing of ensemble subcommand table into utility routine. --- generic/tclNamesp.c | 52 +++++++++++++++++++++++----------------------------- 1 file changed, 23 insertions(+), 29 deletions(-) diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 1556ec9..a2e625e 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -6480,13 +6480,31 @@ MakeCachedEnsembleCommand( */ static void +ClearTable( + EnsembleConfig *ensemblePtr) +{ + Tcl_HashTable *hash = &ensemblePtr->subcommandTable; + + if (hash->numEntries != 0) { + Tcl_HashSearch search; + Tcl_HashEntry *hPtr = Tcl_FirstHashEntry(hash, &search); + + while (hPtr != NULL) { + Tcl_Obj *prefixObj = Tcl_GetHashValue(hPtr); + Tcl_DecrRefCount(prefixObj); + hPtr = Tcl_NextHashEntry(&search); + } + ckfree((char *) ensemblePtr->subcommandArrayPtr); + } + Tcl_DeleteHashTable(hash); +} + +static void DeleteEnsembleConfig( ClientData clientData) { EnsembleConfig *ensemblePtr = clientData; Namespace *nsPtr = ensemblePtr->nsPtr; - Tcl_HashSearch search; - Tcl_HashEntry *hEnt; /* * Unlink from the ensemble chain if it has not been marked as having been @@ -6519,17 +6537,8 @@ DeleteEnsembleConfig( * Kill the pointer-containing fields. */ - if (ensemblePtr->subcommandTable.numEntries != 0) { - ckfree((char *) ensemblePtr->subcommandArrayPtr); - } - hEnt = Tcl_FirstHashEntry(&ensemblePtr->subcommandTable, &search); - while (hEnt != NULL) { - Tcl_Obj *prefixObj = Tcl_GetHashValue(hEnt); + ClearTable(ensemblePtr); - Tcl_DecrRefCount(prefixObj); - hEnt = Tcl_NextHashEntry(&search); - } - Tcl_DeleteHashTable(&ensemblePtr->subcommandTable); if (ensemblePtr->subcmdList != NULL) { Tcl_DecrRefCount(ensemblePtr->subcmdList); } @@ -6585,23 +6594,8 @@ BuildEnsembleConfig( Tcl_Obj *mapDict = ensemblePtr->subcommandDict; Tcl_Obj *subList = ensemblePtr->subcmdList; - if (hash->numEntries != 0) { - /* - * Remove pre-existing table. - */ - - Tcl_HashSearch search; - - ckfree((char *) ensemblePtr->subcommandArrayPtr); - hPtr = Tcl_FirstHashEntry(hash, &search); - while (hPtr != NULL) { - Tcl_Obj *prefixObj = Tcl_GetHashValue(hPtr); - Tcl_DecrRefCount(prefixObj); - hPtr = Tcl_NextHashEntry(&search); - } - Tcl_DeleteHashTable(hash); - Tcl_InitHashTable(hash, TCL_STRING_KEYS); - } + ClearTable(ensemblePtr); + Tcl_InitHashTable(hash, TCL_STRING_KEYS); if (subList) { int subc; -- cgit v0.12