summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--generic/tclCmdIL.c5
-rw-r--r--generic/tclOODefineCmds.c15
-rw-r--r--generic/tclPkg.c43
-rw-r--r--tests/chanio.test7
-rw-r--r--tests/exec.test1
-rw-r--r--tests/info.test2
-rw-r--r--tests/io.test5
-rw-r--r--tests/ioCmd.test5
-rw-r--r--tests/join.test5
-rw-r--r--tests/oo.test4
10 files changed, 43 insertions, 49 deletions
diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index b41d312..77b8434 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 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;
}
/*
diff --git a/tests/chanio.test b/tests/chanio.test
index 2d900d0..97e7e70 100644
--- a/tests/chanio.test
+++ b/tests/chanio.test
@@ -5866,6 +5866,8 @@ test chan-io-47.6 {file events on shared files, deleting file events} -setup {
testfevent delete
chan close $f
} -result {{script 1} {}}
+unset path(foo)
+removeFile foo
set path(bar) [makeFile {} bar]
@@ -5961,6 +5963,9 @@ test chan-io-48.3 {testing readability conditions} -setup {
} -cleanup {
chan close $f
} -result {done {0 1 0 1 0 1 0 1 0 1 0 1 0 0}}
+unset path(bar)
+removeFile bar
+
test chan-io-48.4 {lf write, testing readability, ^Z termination, auto read mode} -setup {
file delete $path(test1)
set c 0
@@ -6790,8 +6795,6 @@ test chan-io-52.11 {TclCopyChannel & encodings} -setup {
chan close $in
chan close $out
file size $path(kyrillic.txt)
-} -cleanup {
- file delete $path(utf8-fcopy.txt)
} -result 3
test chan-io-53.1 {CopyData} -setup {
diff --git a/tests/exec.test b/tests/exec.test
index dffd960..3d1cd56 100644
--- a/tests/exec.test
+++ b/tests/exec.test
@@ -300,7 +300,6 @@ test exec-6.3 {redirecting stderr through a pipeline} {exec stdio} {
# I/O redirection: combinations.
set path(gorp.file2) [makeFile {} gorp.file2]
-file delete $path(gorp.file2)
test exec-7.1 {multiple I/O redirections} {exec} {
exec << "command input" > $path(gorp.file2) [interpreter] $path(cat) < $path(gorp.file)
diff --git a/tests/info.test b/tests/info.test
index fd89b47..8176ad3 100644
--- a/tests/info.test
+++ b/tests/info.test
@@ -2398,7 +2398,7 @@ test info-33.35 {{*}, literal, simple, bytecompiled} -body {
# -------------------------------------------------------------------------
unset -nocomplain res
-test info-39.0 {Bug 4b61afd660} -setup {
+test info-39.2 {Bug 4b61afd660} -setup {
proc probe {} {
return [dict get [info frame -1] line]
}
diff --git a/tests/io.test b/tests/io.test
index 5c81d52..20bb565 100644
--- a/tests/io.test
+++ b/tests/io.test
@@ -6163,6 +6163,8 @@ test io-47.6 {file events on shared files, deleting file events} {testfevent fil
close $f
set x
} {{script 1} {}}
+unset path(foo)
+removeFile foo
set path(bar) [makeFile {} bar]
@@ -6265,6 +6267,9 @@ test io-48.3 {testing readability conditions} {stdio unix nonBlockFiles openpipe
close $f
list $x $l
} {done {0 1 0 1 0 1 0 1 0 1 0 1 0 0}}
+unset path(bar)
+removeFile bar
+
test io-48.4 {lf write, testing readability, ^Z termination, auto read mode} {fileevent} {
file delete $path(test1)
set f [open $path(test1) w]
diff --git a/tests/ioCmd.test b/tests/ioCmd.test
index cd89a02..b4ba04a 100644
--- a/tests/ioCmd.test
+++ b/tests/ioCmd.test
@@ -384,7 +384,6 @@ test iocmd-10.5 {fblocked command} {
set path(test4) [makeFile {} test4]
set path(test5) [makeFile {} test5]
-file delete $path(test5)
test iocmd-11.1 {I/O to command pipelines} {unixOrPc unixExecs} {
set f [open $path(test4) w]
close $f
@@ -3836,8 +3835,6 @@ foreach file [list test1 test2 test3 test4] {
}
# delay long enough for background processes to finish
after 500
-foreach file [list test5] {
- removeFile $file
-}
+removeFile test5
cleanupTests
return
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 {} {
generated by cgit v0.12 at 2024-10-22 01:56:30 (GMT)