From a0c6bf8d922f9e7853a161b064103518dddd4612 Mon Sep 17 00:00:00 2001 From: dgp Date: Sat, 27 Jan 2018 01:38:21 +0000 Subject: Regression test for shimmering danger in [join]. --- tests/join.test | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/tests/join.test b/tests/join.test index 4abe233..4aeb093 100644 --- a/tests/join.test +++ b/tests/join.test @@ -45,6 +45,11 @@ test join-3.1 {joinString is binary ok} { test join-3.2 {join is binary ok} { string length [join "a\0b a\0b a\0b"] } 11 + +test join-4.1 {shimmer segfault prevention} { + set l {0 0} + join $l $l +} {00 00} # cleanup ::tcltest::cleanupTests -- cgit v0.12 From fa7659336ca6c01fbed7cf8497b29e9191b0cb42 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Sat, 27 Jan 2018 18:17:09 +0000 Subject: Remove restriction on defining the class of a TclOO object not explicitly instantiated from ::oo::class. --- generic/tclOODefineCmds.c | 15 --------------- tests/oo.test | 4 ++-- 2 files changed, 2 insertions(+), 17 deletions(-) diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index c08b350..7c2a641 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -1143,7 +1143,6 @@ TclOODefineClassObjCmd( { Object *oPtr; Class *clsPtr; - Foundation *fPtr = TclOOGetFoundation(interp); /* * Parse the context to get the object to operate on. @@ -1180,20 +1179,6 @@ TclOODefineClassObjCmd( return TCL_ERROR; } - /* - * Apply semantic checks. In particular, classes and non-classes are not - * interchangable (too complicated to do the conversion!) so we must - * produce an error if any attempt is made to swap from one to the other. - */ - - if ((oPtr->classPtr==NULL) == TclOOIsReachable(fPtr->classCls, clsPtr)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "may not change a %sclass object into a %sclass object", - (oPtr->classPtr==NULL ? "non-" : ""), - (oPtr->classPtr==NULL ? "" : "non-"))); - Tcl_SetErrorCode(interp, "TCL", "OO", "TRANSMUTATION", NULL); - return TCL_ERROR; - } /* * Set the object's class. diff --git a/tests/oo.test b/tests/oo.test index 3be5f79..4f9490b 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -1707,13 +1707,13 @@ test oo-13.2 {OO: changing an object's class} -body { oo::objdefine foo class oo::class } -cleanup { foo destroy -} -returnCodes 1 -result {may not change a non-class object into a class object} +} -result {} test oo-13.3 {OO: changing an object's class} -body { oo::class create foo oo::objdefine foo class oo::object } -cleanup { foo destroy -} -returnCodes 1 -result {may not change a class object into a non-class object} +} -result {} test oo-13.4 {OO: changing an object's class} -body { oo::class create foo { method m {} { -- cgit v0.12 From 876f2d5b633933c4d5a652a0bc4e1742893cc458 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Sun, 28 Jan 2018 14:37:53 +0000 Subject: Change the signature of PkgRequireCore in preparation to provide TclNRPackageObjCmd. --- generic/tclPkg.c | 43 +++++++++++++++++++++---------------------- 1 file changed, 21 insertions(+), 22 deletions(-) diff --git a/generic/tclPkg.c b/generic/tclPkg.c index 288d5dc..2b842b4 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -85,7 +85,7 @@ static void AddRequirementsToResult(Tcl_Interp *interp, int reqc, static void AddRequirementsToDString(Tcl_DString *dstring, int reqc, Tcl_Obj *const reqv[]); static Package * FindPackage(Tcl_Interp *interp, const char *name); -static const char * PkgRequireCore(Tcl_Interp *interp, const char *name, +static int PkgRequireCore(Tcl_Interp *interp, const char *name, int reqc, Tcl_Obj *const reqv[], void *clientDataPtr); @@ -365,7 +365,10 @@ Tcl_PkgRequireEx( */ if (version == NULL) { - result = PkgRequireCore(interp, name, 0, NULL, clientDataPtr); + if (Tcl_PkgRequireProc(interp, name, 0, NULL, clientDataPtr) == TCL_OK) { + result = Tcl_GetStringResult(interp); + Tcl_ResetResult(interp); + } } else { if (exact && TCL_OK != CheckVersionAndConvert(interp, version, NULL, NULL)) { @@ -376,10 +379,12 @@ Tcl_PkgRequireEx( Tcl_AppendStringsToObj(ov, "-", version, NULL); } Tcl_IncrRefCount(ov); - result = PkgRequireCore(interp, name, 1, &ov, clientDataPtr); + if (Tcl_PkgRequireProc(interp, name, 1, &ov, clientDataPtr) == TCL_OK) { + result = Tcl_GetStringResult(interp); + Tcl_ResetResult(interp); + } TclDecrRefCount(ov); } - return result; } @@ -394,17 +399,14 @@ Tcl_PkgRequireProc( * available. */ void *clientDataPtr) { - const char *result = - PkgRequireCore(interp, name, reqc, reqv, clientDataPtr); - - if (result == NULL) { - return TCL_ERROR; + int code = CheckAllRequirements(interp, reqc, reqv); + if (code != TCL_OK) { + return code; } - Tcl_SetObjResult(interp, Tcl_NewStringObj(result, -1)); - return TCL_OK; + return PkgRequireCore(interp, name, reqc, reqv, clientDataPtr); } -static const char * +int PkgRequireCore( Tcl_Interp *interp, /* Interpreter in which package is now * available. */ @@ -424,10 +426,6 @@ PkgRequireCore( char *script, *pkgVersionI; Tcl_DString command; - if (TCL_OK != CheckAllRequirements(interp, reqc, reqv)) { - return NULL; - } - /* * It can take up to three passes to find the package: one pass to run the * "package unknown" script, one to run the "package ifneeded" script for @@ -453,7 +451,7 @@ PkgRequireCore( name, (char *) pkgPtr->clientData, name)); AddRequirementsToResult(interp, reqc, reqv); Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "CIRCULARITY", NULL); - return NULL; + return TCL_ERROR; } /* @@ -678,7 +676,7 @@ PkgRequireCore( pkgPtr->version = NULL; } pkgPtr->clientData = NULL; - return NULL; + return code; } break; @@ -714,7 +712,7 @@ PkgRequireCore( if (code == TCL_ERROR) { Tcl_AddErrorInfo(interp, "\n (\"package unknown\" script)"); - return NULL; + return code; } Tcl_ResetResult(interp); } @@ -725,7 +723,7 @@ PkgRequireCore( "can't find package %s", name)); Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNFOUND", NULL); AddRequirementsToResult(interp, reqc, reqv); - return NULL; + return TCL_ERROR; } /* @@ -746,7 +744,7 @@ PkgRequireCore( Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT", NULL); AddRequirementsToResult(interp, reqc, reqv); - return NULL; + return TCL_ERROR; } } @@ -755,7 +753,8 @@ PkgRequireCore( *ptr = pkgPtr->clientData; } - return pkgPtr->version; + Tcl_SetObjResult(interp, Tcl_NewStringObj(pkgPtr->version, -1)); + return TCL_OK; } /* -- cgit v0.12