diff options
| -rw-r--r-- | generic/tclCmdIL.c | 5 | ||||
| -rw-r--r-- | generic/tclOODefineCmds.c | 15 | ||||
| -rw-r--r-- | generic/tclPkg.c | 43 | ||||
| -rw-r--r-- | tests/join.test | 5 | ||||
| -rw-r--r-- | tests/oo.test | 4 |
5 files changed, 31 insertions, 41 deletions
diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 4285463..4fb89e3 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -2160,7 +2160,7 @@ Tcl_JoinObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ { - int listLen; + int length, listLen; Tcl_Obj *resObjPtr = NULL, *joinObjPtr, **elemPtrs; if ((objc < 2) || (objc > 3)) { @@ -2191,7 +2191,8 @@ Tcl_JoinObjCmd( joinObjPtr = (objc == 2) ? Tcl_NewStringObj(" ", 1) : objv[2]; Tcl_IncrRefCount(joinObjPtr); - if (Tcl_GetCharLength(joinObjPtr) == 0) { + (void) Tcl_GetStringFromObj(joinObjPtr, &length); + if (length == 0) { TclStringCatObjv(interp, /* inPlace */ 0, listLen, elemPtrs, &resObjPtr); } else { 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/generic/tclPkg.c b/generic/tclPkg.c index d4f4d72..12b7067 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; } /* 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 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 {} { |