From 7ca040ad884baacea75bb242383440f3ce80e0bb Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 6 Mar 2019 01:42:13 +0000 Subject: [39fed4dae5] Minimal fix for volatile lifetime of string returned by Tcl_PkgRequire(). We need a test for this ticket to go in the test suite. --- generic/tclPkg.c | 34 ++++++++++++++++------------------ 1 file changed, 16 insertions(+), 18 deletions(-) diff --git a/generic/tclPkg.c b/generic/tclPkg.c index d4080c2..510f5e6 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -40,10 +40,7 @@ typedef struct PkgAvail { */ typedef struct Package { - char *version; /* Version that has been supplied in this - * interpreter via "package provide" - * (malloc'ed). NULL means the package doesn't - * exist in this interpreter yet. */ + Tcl_Obj *version; PkgAvail *availPtr; /* First in list of all available versions of * this package. */ const void *clientData; /* Client data. */ @@ -150,12 +147,13 @@ Tcl_PkgProvideEx( pkgPtr = FindPackage(interp, name); if (pkgPtr->version == NULL) { - DupString(pkgPtr->version, version); + pkgPtr->version = Tcl_NewStringObj(version, -1); + Tcl_IncrRefCount(pkgPtr->version); pkgPtr->clientData = clientData; return TCL_OK; } - if (CheckVersionAndConvert(interp, pkgPtr->version, &pvi, + if (CheckVersionAndConvert(interp, Tcl_GetString(pkgPtr->version), &pvi, NULL) != TCL_OK) { return TCL_ERROR; } else if (CheckVersionAndConvert(interp, version, &vi, NULL) != TCL_OK) { @@ -175,7 +173,7 @@ Tcl_PkgProvideEx( } Tcl_SetObjResult(interp, Tcl_ObjPrintf( "conflicting versions provided for package \"%s\": %s, then %s", - name, pkgPtr->version, version)); + name, Tcl_GetString(pkgPtr->version), version)); Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT", NULL); return TCL_ERROR; } @@ -474,7 +472,8 @@ PkgRequireCoreFinal(ClientData data[], Tcl_Interp *interp, int result) { */ if (reqc != 0) { - CheckVersionAndConvert(interp, reqPtr->pkgPtr->version, &pkgVersionI, NULL); + CheckVersionAndConvert(interp, Tcl_GetString(reqPtr->pkgPtr->version), + &pkgVersionI, NULL); satisfies = SomeRequirementSatisfied(pkgVersionI, reqc, reqv); ckfree(pkgVersionI); @@ -482,7 +481,7 @@ PkgRequireCoreFinal(ClientData data[], Tcl_Interp *interp, int result) { if (!satisfies) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "version conflict for package \"%s\": have %s, need", - name, reqPtr->pkgPtr->version)); + name, Tcl_GetString(reqPtr->pkgPtr->version))); Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT", NULL); AddRequirementsToResult(interp, reqc, reqv); @@ -495,7 +494,7 @@ PkgRequireCoreFinal(ClientData data[], Tcl_Interp *interp, int result) { *ptr = reqPtr->pkgPtr->clientData; } - Tcl_SetObjResult(interp, Tcl_NewStringObj(reqPtr->pkgPtr->version, -1)); + Tcl_SetObjResult(interp, reqPtr->pkgPtr->version); return TCL_OK; } @@ -694,8 +693,8 @@ SelectPackageFinal(ClientData data[], Tcl_Interp *interp, int result) { } else { char *pvi, *vi; - if (CheckVersionAndConvert(interp, reqPtr->pkgPtr->version, &pvi, - NULL) != TCL_OK) { + if (TCL_OK != CheckVersionAndConvert(interp, + Tcl_GetString(reqPtr->pkgPtr->version), &pvi, NULL)) { result = TCL_ERROR; } else if (CheckVersionAndConvert(interp, versionToProvide, &vi, NULL) != TCL_OK) { @@ -712,7 +711,7 @@ SelectPackageFinal(ClientData data[], Tcl_Interp *interp, int result) { "attempt to provide package %s %s failed:" " package %s %s provided instead", name, versionToProvide, - name, reqPtr->pkgPtr->version)); + name, Tcl_GetString(reqPtr->pkgPtr->version))); Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "WRONGPROVIDE", NULL); } @@ -750,7 +749,7 @@ SelectPackageFinal(ClientData data[], Tcl_Interp *interp, int result) { */ if (reqPtr->pkgPtr->version != NULL) { - ckfree(reqPtr->pkgPtr->version); + Tcl_DecrRefCount(reqPtr->pkgPtr->version); reqPtr->pkgPtr->version = NULL; } reqPtr->pkgPtr->clientData = NULL; @@ -926,7 +925,7 @@ TclNRPackageObjCmd( pkgPtr = Tcl_GetHashValue(hPtr); Tcl_DeleteHashEntry(hPtr); if (pkgPtr->version != NULL) { - ckfree(pkgPtr->version); + Tcl_DecrRefCount(pkgPtr->version); } while (pkgPtr->availPtr != NULL) { availPtr = pkgPtr->availPtr; @@ -1084,8 +1083,7 @@ TclNRPackageObjCmd( if (hPtr != NULL) { pkgPtr = Tcl_GetHashValue(hPtr); if (pkgPtr->version != NULL) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj(pkgPtr->version, -1)); + Tcl_SetObjResult(interp, pkgPtr->version); } } return TCL_OK; @@ -1378,7 +1376,7 @@ TclFreePackageInfo( hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { pkgPtr = Tcl_GetHashValue(hPtr); if (pkgPtr->version != NULL) { - ckfree(pkgPtr->version); + Tcl_DecrRefCount(pkgPtr->version); } while (pkgPtr->availPtr != NULL) { availPtr = pkgPtr->availPtr; -- cgit v0.12 From 781c32ac29d9ab9c771d3dee2ed305450e9d8378 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 7 Mar 2019 20:02:09 +0000 Subject: [39fed4dae5] Proposed test --- generic/tclTestProcBodyObj.c | 47 +++++++++++++++++++++++++++++++++++++++++++- tests/proc.test | 3 +++ 2 files changed, 49 insertions(+), 1 deletion(-) diff --git a/generic/tclTestProcBodyObj.c b/generic/tclTestProcBodyObj.c index 4d32c5a..fba2844 100644 --- a/generic/tclTestProcBodyObj.c +++ b/generic/tclTestProcBodyObj.c @@ -21,13 +21,14 @@ */ static const char packageName[] = "procbodytest"; -static const char packageVersion[] = "1.0"; +static const char packageVersion[] = "1.1"; /* * Name of the commands exported by this package */ static const char procCommand[] = "proc"; +static const char checkCommand[] = "check"; /* * this struct describes an entry in the table of command names and command @@ -46,6 +47,8 @@ typedef struct CmdTable { static int ProcBodyTestProcObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); +static int ProcBodyTestCheckObjCmd(ClientData dummy, + Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int ProcBodyTestInitInternal(Tcl_Interp *interp, int isSafe); static int RegisterCommand(Tcl_Interp* interp, const char *namespace, const CmdTable *cmdTablePtr); @@ -57,11 +60,13 @@ static int RegisterCommand(Tcl_Interp* interp, static const CmdTable commands[] = { { procCommand, ProcBodyTestProcObjCmd, 1 }, + { checkCommand, ProcBodyTestCheckObjCmd, 1 }, { 0, 0, 0 } }; static const CmdTable safeCommands[] = { { procCommand, ProcBodyTestProcObjCmd, 1 }, + { checkCommand, ProcBodyTestCheckObjCmd, 1 }, { 0, 0, 0 } }; @@ -301,6 +306,46 @@ ProcBodyTestProcObjCmd( } /* + *---------------------------------------------------------------------- + * + * ProcBodyTestCheckObjCmd -- + * + * Implements the "procbodytest::check" command. Here is the command + * description: + * procbodytest::check + * + * Performs an internal check that the Tcl_PkgPresent() command returns + * the same version number as was registered when the procbodytest package + * was provided. Places a boolean in the interp result indicating the + * test outcome. + * + * Results: + * Returns a standard Tcl code. + * + *---------------------------------------------------------------------- + */ + +static int +ProcBodyTestCheckObjCmd( + ClientData dummy, /* context; not used */ + Tcl_Interp *interp, /* the current interpreter */ + int objc, /* argument count */ + Tcl_Obj *const objv[]) /* arguments */ +{ + const char *version; + + if (objc != 1) { + Tcl_WrongNumArgs(interp, 1, objv, ""); + return TCL_ERROR; + } + + version = Tcl_PkgPresent(interp, packageName, packageVersion, 1); + Tcl_SetObjResult(interp, Tcl_NewBooleanObj( + strcmp(version, packageVersion) == 0)); + return TCL_OK; +} + +/* * Local Variables: * mode: c * c-basic-offset: 4 diff --git a/tests/proc.test b/tests/proc.test index e06720e..670ac98 100644 --- a/tests/proc.test +++ b/tests/proc.test @@ -313,6 +313,9 @@ test proc-4.8 {TclCreateProc, procbody obj, no leak on multiple iterations} -set rename getbytes {} unset -nocomplain end i tmp leakedBytes } -result 0 +test proc-4.9 {[39fed4dae5] Valid Tcl_PkgPresent return} procbodytest { + procbodytest::check +} 1 test proc-5.1 {Bytecompiling noop; test for correct argument substitution} -body { proc p args {} ; # this will be bytecompiled into t -- cgit v0.12 From c5abbcaaf4c32c6bfce25ff1a589f6e704116729 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 7 Mar 2019 22:13:25 +0000 Subject: In the 8.6.* releases, Tcl_GetStringResult() still passes through interp->result. Have to ask specifically for the string rep of the value we want. --- generic/tclPkg.c | 4 ++-- generic/tclTestProcBodyObj.c | 2 -- 2 files changed, 2 insertions(+), 4 deletions(-) diff --git a/generic/tclPkg.c b/generic/tclPkg.c index 510f5e6..c1e2078 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -316,7 +316,7 @@ Tcl_PkgRequireEx( if (version == NULL) { if (Tcl_PkgRequireProc(interp, name, 0, NULL, clientDataPtr) == TCL_OK) { - result = Tcl_GetStringResult(interp); + result = Tcl_GetString(Tcl_GetObjResult(interp)); Tcl_ResetResult(interp); } } else { @@ -330,7 +330,7 @@ Tcl_PkgRequireEx( } Tcl_IncrRefCount(ov); if (Tcl_PkgRequireProc(interp, name, 1, &ov, clientDataPtr) == TCL_OK) { - result = Tcl_GetStringResult(interp); + result = Tcl_GetString(Tcl_GetObjResult(interp)); Tcl_ResetResult(interp); } TclDecrRefCount(ov); diff --git a/generic/tclTestProcBodyObj.c b/generic/tclTestProcBodyObj.c index de1fa52..fba2844 100644 --- a/generic/tclTestProcBodyObj.c +++ b/generic/tclTestProcBodyObj.c @@ -340,8 +340,6 @@ ProcBodyTestCheckObjCmd( } version = Tcl_PkgPresent(interp, packageName, packageVersion, 1); -fprintf(stdout, "CHECK %p '%s' %p '%s'\n", version, version, -packageVersion, packageVersion); fflush(stdout); Tcl_SetObjResult(interp, Tcl_NewBooleanObj( strcmp(version, packageVersion) == 0)); return TCL_OK; -- cgit v0.12 From 2d4e87b986c01a174757d0c728164f7809206654 Mon Sep 17 00:00:00 2001 From: sebres Date: Fri, 8 Mar 2019 04:35:41 +0000 Subject: fixed mistake ($howmuch is substituted in tests and can be larger as last event index created by too small measurement time). --- tests-perf/timer-event.perf.tcl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests-perf/timer-event.perf.tcl b/tests-perf/timer-event.perf.tcl index 805f0f8..c5a7d45 100644 --- a/tests-perf/timer-event.perf.tcl +++ b/tests-perf/timer-event.perf.tcl @@ -76,7 +76,7 @@ proc test-queue {{reptime {1000 10000}}} { # cancel forwards "after 0" / $howmuch timer-events in queue: setup {set i 0; timerate {set ev([incr i]) [after 0 {set foo bar}]} {*}$reptime} setup {set le $i; set i 0; list 1 .. $le; # cancel up to $howmuch events} - {after cancel $ev([incr i]); if {$i >= $howmuch} break} + {after cancel $ev([incr i]); if {$i >= $le} break} cleanup {update; unset -nocomplain ev} # cancel backwards "after 0" / $howmuch timer-events in queue: setup {set i 0; timerate {set ev([incr i]) [after 0 {set foo bar}]} {*}$reptime} -- cgit v0.12