summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--generic/tclBasic.c4
-rw-r--r--generic/tclPkg.c436
-rw-r--r--tests/package.test12
3 files changed, 288 insertions, 164 deletions
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index fa54551..366fd1f 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -238,7 +238,7 @@ static const CmdInfo builtInCmds[] = {
{"lsearch", Tcl_LsearchObjCmd, NULL, NULL, CMD_IS_SAFE},
{"lset", Tcl_LsetObjCmd, TclCompileLsetCmd, NULL, CMD_IS_SAFE},
{"lsort", Tcl_LsortObjCmd, NULL, NULL, CMD_IS_SAFE},
- {"package", Tcl_PackageObjCmd, NULL, NULL, CMD_IS_SAFE},
+ {"package", Tcl_PackageObjCmd, NULL, TclNRPackageObjCmd, CMD_IS_SAFE},
{"proc", Tcl_ProcObjCmd, NULL, NULL, CMD_IS_SAFE},
{"regexp", Tcl_RegexpObjCmd, TclCompileRegexpCmd, NULL, CMD_IS_SAFE},
{"regsub", Tcl_RegsubObjCmd, TclCompileRegsubCmd, NULL, CMD_IS_SAFE},
@@ -4480,6 +4480,8 @@ TclNRRunCallbacks(
(void) Tcl_GetObjResult(interp);
}
+ /* This is the trampoline. */
+
while (TOP_CB(interp) != rootPtr) {
callbackPtr = TOP_CB(interp);
procPtr = callbackPtr->procPtr;
diff --git a/generic/tclPkg.c b/generic/tclPkg.c
index ce00fbf..6c5b827 100644
--- a/generic/tclPkg.c
+++ b/generic/tclPkg.c
@@ -69,8 +69,14 @@ typedef struct Require {
void * clientDataPtr;
const char *name;
Package *pkgPtr;
+ char *versionToProvide;
} Require;
+typedef struct RequireProcArgs {
+ const char *name;
+ void *clientDataPtr;
+} RequireProcArgs;
+
/*
* Prototypes for functions defined in this file:
*/
@@ -91,10 +97,15 @@ 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 int PkgRequireCore(ClientData clientData, Tcl_Interp *interp,
- int reqc, Tcl_Obj *const reqv[]);
-static int SelectPackage (Tcl_Interp *interp, Require *reqPtr,
- int reqc, Tcl_Obj *const reqv[]);
+static int PkgRequireCore(ClientData data[], Tcl_Interp *interp, int result);
+static int PkgRequireCoreFinal(ClientData data[], Tcl_Interp *interp, int result);
+static int PkgRequireCoreCleanup(ClientData data[], Tcl_Interp *interp, int result);
+static int PkgRequireCoreStep1(ClientData data[], Tcl_Interp *interp, int result);
+static int PkgRequireCoreStep2(ClientData data[], Tcl_Interp *interp, int result);
+static int TclNRPkgRequireProc(ClientData clientData, Tcl_Interp *interp, int reqc, Tcl_Obj *const reqv[]);
+static int SelectPackage(ClientData data[], Tcl_Interp *interp, int result);
+static int SelectPackageFinal(ClientData data[], Tcl_Interp *interp, int result);
+static int TclNRPackageObjCmdCleanup(ClientData data[], Tcl_Interp *interp, int result);
/*
* Helper macros.
@@ -406,80 +417,116 @@ Tcl_PkgRequireProc(
* available. */
void *clientDataPtr)
{
+ RequireProcArgs args;
+ args.name = name;
+ args.clientDataPtr = clientDataPtr;
+ return Tcl_NRCallObjProc(interp, TclNRPkgRequireProc, (void *)&args, reqc, reqv);
+}
+
+static int
+TclNRPkgRequireProc(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int reqc,
+ Tcl_Obj *const reqv[]) {
+ RequireProcArgs *args = clientData;
+ Tcl_NRAddCallback(interp, PkgRequireCore, (void *)args->name, INT2PTR(reqc), (void *)reqv, args->clientDataPtr);
+ return TCL_OK;
+}
+
+static int
+PkgRequireCore(ClientData data[], Tcl_Interp *interp, int result)
+{
+ const char *name = data[0];
+ int reqc = PTR2INT(data[1]);
+ Tcl_Obj *const *reqv = data[2];
int code = CheckAllRequirements(interp, reqc, reqv);
- Require require;
+ Require *reqPtr;
if (code != TCL_OK) {
return code;
}
- require.clientDataPtr = clientDataPtr;
- require.name = name;
- require.pkgPtr = NULL;
- return Tcl_NRCallObjProc(interp, PkgRequireCore, &require, reqc, reqv);
+ reqPtr = ckalloc(sizeof(Require));
+ Tcl_NRAddCallback(interp, PkgRequireCoreCleanup, reqPtr, NULL, NULL, NULL);
+ reqPtr->clientDataPtr = data[3];
+ reqPtr->name = name;
+ reqPtr->pkgPtr = FindPackage(interp, name);
+ if (reqPtr->pkgPtr->version == NULL) {
+ Tcl_NRAddCallback(interp, SelectPackage, reqPtr, INT2PTR(reqc), (void *)reqv, PkgRequireCoreStep1);
+ } else {
+ Tcl_NRAddCallback(interp, PkgRequireCoreFinal, reqPtr, INT2PTR(reqc), (void *)reqv, NULL);
+ }
+ return TCL_OK;
}
-int
-PkgRequireCore(
- ClientData clientData,
- Tcl_Interp *interp, /* Interpreter in which package is now
- * available. */
- int reqc, /* Requirements constraining the desired
- * version. */
- Tcl_Obj *const reqv[] /* 0 means to use the latest version
- * available. */
- )
-{
- int code, satisfies;
+static int
+PkgRequireCoreStep1(ClientData data[], Tcl_Interp *interp, int result) {
Tcl_DString command;
- Require *reqPtr = clientData;
- char *script, *pkgVersionI;
+ char *script;
+ Require *reqPtr = data[0];
+ int reqc = PTR2INT(data[1]);
+ Tcl_Obj **const reqv = data[2];
const char *name = reqPtr->name /* Name of desired package. */;
- void *clientDataPtr = reqPtr->clientDataPtr;
-
- reqPtr->pkgPtr = FindPackage(interp, name);
if (reqPtr->pkgPtr->version == NULL) {
- code = SelectPackage(interp, reqPtr, reqc, reqv);
- if (code != TCL_OK) {
- return code;
- }
- if (reqPtr->pkgPtr->version == NULL) {
- /*
- * The package is not in the database. If there is a "package unknown"
- * command, invoke it.
- */
+ /*
+ * The package is not in the database. If there is a "package unknown"
+ * command, invoke it.
+ */
- script = ((Interp *) interp)->packageUnknown;
- if (script != NULL) {
- Tcl_DStringInit(&command);
- Tcl_DStringAppend(&command, script, -1);
- Tcl_DStringAppendElement(&command, name);
- AddRequirementsToDString(&command, reqc, reqv);
-
- code = Tcl_EvalEx(interp, Tcl_DStringValue(&command),
- Tcl_DStringLength(&command), TCL_EVAL_GLOBAL);
- Tcl_DStringFree(&command);
-
- if ((code != TCL_OK) && (code != TCL_ERROR)) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "bad return code: %d", code));
- Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL);
- code = TCL_ERROR;
- }
- if (code == TCL_ERROR) {
- Tcl_AddErrorInfo(interp,
- "\n (\"package unknown\" script)");
- return code;
- }
- Tcl_ResetResult(interp);
- /* pkgPtr may now be invalid, so refresh it. */
- reqPtr->pkgPtr = FindPackage(interp, name);
- code = SelectPackage(interp, reqPtr, reqc, reqv);
- if (code != TCL_OK) {
- return code;
- }
- }
- }
+ script = ((Interp *) interp)->packageUnknown;
+ if (script == NULL) {
+ Tcl_NRAddCallback(interp, PkgRequireCoreFinal, reqPtr, INT2PTR(reqc), (void *)reqv, NULL);
+ } else {
+ Tcl_DStringInit(&command);
+ Tcl_DStringAppend(&command, script, -1);
+ Tcl_DStringAppendElement(&command, name);
+ AddRequirementsToDString(&command, reqc, reqv);
+
+ Tcl_NRAddCallback(interp, PkgRequireCoreStep2, reqPtr, INT2PTR(reqc), (void *)reqv, NULL);
+ Tcl_NREvalObj(interp,
+ Tcl_NewStringObj(Tcl_DStringValue(&command), Tcl_DStringLength(&command)),
+ TCL_EVAL_GLOBAL
+ );
+ Tcl_DStringFree(&command);
+ }
+ return TCL_OK;
+ } else {
+ Tcl_NRAddCallback(interp, PkgRequireCoreFinal, reqPtr, INT2PTR(reqc), (void *)reqv, NULL);
}
+ return TCL_OK;
+}
+static int
+PkgRequireCoreStep2(ClientData data[], Tcl_Interp *interp, int result) {
+ Require *reqPtr = data[0];
+ int reqc = PTR2INT(data[1]);
+ Tcl_Obj **const reqv = data[2];
+ const char *name = reqPtr->name /* Name of desired package. */;
+ if ((result != TCL_OK) && (result != TCL_ERROR)) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad return code: %d", result));
+ Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL);
+ result = TCL_ERROR;
+ }
+ if (result == TCL_ERROR) {
+ Tcl_AddErrorInfo(interp,
+ "\n (\"package unknown\" script)");
+ return result;
+ }
+ Tcl_ResetResult(interp);
+ /* pkgPtr may now be invalid, so refresh it. */
+ reqPtr->pkgPtr = FindPackage(interp, name);
+ Tcl_NRAddCallback(interp, SelectPackage, reqPtr, INT2PTR(reqc), (void *)reqv, PkgRequireCoreFinal);
+ return TCL_OK;
+}
+
+static int
+PkgRequireCoreFinal(ClientData data[], Tcl_Interp *interp, int result) {
+ Require *reqPtr = data[0];
+ int reqc = PTR2INT(data[1]), satisfies;
+ Tcl_Obj **const reqv = data[2];
+ char *pkgVersionI;
+ void *clientDataPtr = reqPtr->clientDataPtr;
+ const char *name = reqPtr->name /* Name of desired package. */;
if (reqPtr->pkgPtr->version == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't find package %s", name));
@@ -517,13 +564,23 @@ PkgRequireCore(
Tcl_SetObjResult(interp, Tcl_NewStringObj(reqPtr->pkgPtr->version, -1));
return TCL_OK;
}
+
+static int
+PkgRequireCoreCleanup(ClientData data[], Tcl_Interp *interp, int result) {
+ ckfree(data[0]);
+ return result;
+}
+
-int SelectPackage (Tcl_Interp *interp, Require *reqPtr, int reqc, Tcl_Obj *const reqv[]) {
+static int
+SelectPackage(ClientData data[], Tcl_Interp *interp, int result) {
PkgAvail *availPtr, *bestPtr, *bestStablePtr;
char *availVersion, *bestVersion, *bestStableVersion;
/* Internal rep. of versions */
- char *script;
- int availStable, code, satisfies;
+ int availStable, satisfies;
+ Require *reqPtr = data[0];
+ int reqc = PTR2INT(data[1]);
+ Tcl_Obj **const reqv = data[2];
const char *name = reqPtr->name;
Package *pkgPtr = reqPtr->pkgPtr;
Interp *iPtr = (Interp *) interp;
@@ -660,7 +717,9 @@ int SelectPackage (Tcl_Interp *interp, Require *reqPtr, int reqc, Tcl_Obj *const
bestPtr = bestStablePtr;
}
- if (bestPtr != NULL) {
+ if (bestPtr == NULL) {
+ Tcl_NRAddCallback(interp, data[3], reqPtr, INT2PTR(reqc), (void *)reqv, NULL);
+ } else {
/*
* We found an ifneeded script for the package. Be careful while
* executing it: this could cause reentrancy, so (a) protect the
@@ -669,105 +728,118 @@ int SelectPackage (Tcl_Interp *interp, Require *reqPtr, int reqc, Tcl_Obj *const
*/
char *versionToProvide = bestPtr->version;
- PkgFiles *pkgFiles;
- PkgName *pkgName;
- script = bestPtr->script;
-
- pkgPtr->clientData = versionToProvide;
Tcl_Preserve(versionToProvide);
- Tcl_Preserve(script);
- pkgFiles = TclInitPkgFiles(interp);
- /* Push "ifneeded" package name in "tclPkgFiles" assocdata. */
- pkgName = ckalloc(sizeof(PkgName) + strlen(name));
- pkgName->nextPtr = pkgFiles->names;
- strcpy(pkgName->name, name);
- pkgFiles->names = pkgName;
+ pkgPtr->clientData = versionToProvide;
if (bestPtr->pkgIndex) {
TclPkgFileSeen(interp, bestPtr->pkgIndex);
}
- code = Tcl_EvalEx(interp, script, -1, TCL_EVAL_GLOBAL);
- /* Pop the "ifneeded" package name from "tclPkgFiles" assocdata*/
- pkgFiles->names = pkgName->nextPtr;
- ckfree(pkgName);
- Tcl_Release(script);
+ reqPtr->versionToProvide = versionToProvide;
+ Tcl_NRAddCallback(interp, SelectPackageFinal, reqPtr, INT2PTR(reqc), (void *)reqv, data[3]);
+ Tcl_NREvalObj(interp, Tcl_NewStringObj(bestPtr->script, -1), TCL_EVAL_GLOBAL);
+ }
+ return TCL_OK;
+}
+
+static int
+SelectPackageFinal(ClientData data[], Tcl_Interp *interp, int result) {
+ Require *reqPtr = data[0];
+ int reqc = PTR2INT(data[1]);
+ Tcl_Obj **const reqv = data[2];
+ const char *name = reqPtr->name;
+ char *versionToProvide = reqPtr->versionToProvide;
- reqPtr->pkgPtr = FindPackage(interp, name);
- if (code == TCL_OK) {
- Tcl_ResetResult(interp);
- if (reqPtr->pkgPtr->version == NULL) {
- code = TCL_ERROR;
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "attempt to provide package %s %s failed:"
- " no version of package %s provided",
- name, versionToProvide, name));
- Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNPROVIDED",
- NULL);
- } else {
- char *pvi, *vi;
-
- if (CheckVersionAndConvert(interp, reqPtr->pkgPtr->version, &pvi,
- NULL) != TCL_OK) {
- code = TCL_ERROR;
- } else if (CheckVersionAndConvert(interp,
- versionToProvide, &vi, NULL) != TCL_OK) {
- ckfree(pvi);
- code = TCL_ERROR;
- } else {
- int res = CompareVersions(pvi, vi, NULL);
-
- ckfree(pvi);
- ckfree(vi);
- if (res != 0) {
- code = TCL_ERROR;
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "attempt to provide package %s %s failed:"
- " package %s %s provided instead",
- name, versionToProvide,
- name, reqPtr->pkgPtr->version));
- Tcl_SetErrorCode(interp, "TCL", "PACKAGE",
- "WRONGPROVIDE", NULL);
- }
- }
- }
- } else if (code != TCL_ERROR) {
- Tcl_Obj *codePtr = Tcl_NewIntObj(code);
+ PkgFiles *pkgFiles;
+ PkgName *pkgName;
+
+ pkgFiles = TclInitPkgFiles(interp);
+ /* Push "ifneeded" package name in "tclPkgFiles" assocdata. */
+ pkgName = ckalloc(sizeof(PkgName) + strlen(name));
+ pkgName->nextPtr = pkgFiles->names;
+ strcpy(pkgName->name, name);
+ pkgFiles->names = pkgName;
+
+ /* Pop the "ifneeded" package name from "tclPkgFiles" assocdata*/
+ pkgFiles->names = pkgName->nextPtr;
+ ckfree(pkgName);
+ reqPtr->pkgPtr = FindPackage(interp, name);
+ if (result == TCL_OK) {
+ Tcl_ResetResult(interp);
+ if (reqPtr->pkgPtr->version == NULL) {
+ result = TCL_ERROR;
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"attempt to provide package %s %s failed:"
- " bad return code: %s",
- name, versionToProvide, TclGetString(codePtr)));
- Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL);
- TclDecrRefCount(codePtr);
- code = TCL_ERROR;
- }
+ " no version of package %s provided",
+ name, versionToProvide, name));
+ Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNPROVIDED",
+ NULL);
+ } else {
+ char *pvi, *vi;
- if (code == TCL_ERROR) {
- Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
- "\n (\"package ifneeded %s %s\" script)",
- name, versionToProvide));
+ if (CheckVersionAndConvert(interp, reqPtr->pkgPtr->version, &pvi,
+ NULL) != TCL_OK) {
+ result = TCL_ERROR;
+ } else if (CheckVersionAndConvert(interp,
+ versionToProvide, &vi, NULL) != TCL_OK) {
+ ckfree(pvi);
+ result = TCL_ERROR;
+ } else {
+ int res = CompareVersions(pvi, vi, NULL);
+
+ ckfree(pvi);
+ ckfree(vi);
+ if (res != 0) {
+ result = TCL_ERROR;
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "attempt to provide package %s %s failed:"
+ " package %s %s provided instead",
+ name, versionToProvide,
+ name, reqPtr->pkgPtr->version));
+ Tcl_SetErrorCode(interp, "TCL", "PACKAGE",
+ "WRONGPROVIDE", NULL);
+ }
+ }
}
- Tcl_Release(versionToProvide);
+ } else if (result != TCL_ERROR) {
+ Tcl_Obj *codePtr = Tcl_NewIntObj(result);
- if (code != TCL_OK) {
- /*
- * Take a non-TCL_OK code from the script as an indication the
- * package wasn't loaded properly, so the package system
- * should not remember an improper load.
- *
- * This is consistent with our returning NULL. If we're not
- * willing to tell our caller we got a particular version, we
- * shouldn't store that version for telling future callers
- * either.
- */
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "attempt to provide package %s %s failed:"
+ " bad return code: %s",
+ name, versionToProvide, TclGetString(codePtr)));
+ Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL);
+ TclDecrRefCount(codePtr);
+ result = TCL_ERROR;
+ }
- if (reqPtr->pkgPtr->version != NULL) {
- ckfree(reqPtr->pkgPtr->version);
- reqPtr->pkgPtr->version = NULL;
- }
- reqPtr->pkgPtr->clientData = NULL;
- return code;
+ if (result == TCL_ERROR) {
+ Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
+ "\n (\"package ifneeded %s %s\" script)",
+ name, versionToProvide));
+ }
+ Tcl_Release(versionToProvide);
+
+ if (result != TCL_OK) {
+ /*
+ * Take a non-TCL_OK code from the script as an indication the
+ * package wasn't loaded properly, so the package system
+ * should not remember an improper load.
+ *
+ * This is consistent with our returning NULL. If we're not
+ * willing to tell our caller we got a particular version, we
+ * shouldn't store that version for telling future callers
+ * either.
+ */
+
+ if (reqPtr->pkgPtr->version != NULL) {
+ ckfree(reqPtr->pkgPtr->version);
+ reqPtr->pkgPtr->version = NULL;
}
+ reqPtr->pkgPtr->clientData = NULL;
+ return result;
}
+
+ Tcl_NRAddCallback(interp, data[3], reqPtr, INT2PTR(reqc), (void *)reqv, NULL);
return TCL_OK;
}
@@ -874,10 +946,19 @@ Tcl_PkgPresentEx(
*
*----------------------------------------------------------------------
*/
+int
+Tcl_PackageObjCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ return Tcl_NRCallObjProc(interp, TclNRPackageObjCmd, NULL, objc, objv);
+}
/* ARGSUSED */
int
-Tcl_PackageObjCmd(
+TclNRPackageObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
@@ -894,7 +975,7 @@ Tcl_PackageObjCmd(
PKG_VERSIONS, PKG_VSATISFIES
};
Interp *iPtr = (Interp *) interp;
- int optionIndex, exact, i, satisfies;
+ int optionIndex, exact, i, newobjc, satisfies;
PkgAvail *availPtr, *prevPtr;
Package *pkgPtr;
Tcl_HashEntry *hPtr;
@@ -903,6 +984,7 @@ Tcl_PackageObjCmd(
const char *version;
const char *argv2, *argv3, *argv4;
char *iva = NULL, *ivb = NULL;
+ Tcl_Obj *objvListPtr, **newObjvPtr;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
@@ -1148,7 +1230,6 @@ Tcl_PackageObjCmd(
argv2 = TclGetString(objv[2]);
if ((argv2[0] == '-') && (strcmp(argv2, "-exact") == 0)) {
Tcl_Obj *ov;
- int res;
if (objc != 5) {
goto requireSyntax;
@@ -1165,20 +1246,42 @@ Tcl_PackageObjCmd(
*/
ov = Tcl_NewStringObj(version, -1);
+ Tcl_IncrRefCount(ov);
Tcl_AppendStringsToObj(ov, "-", version, NULL);
version = NULL;
argv3 = TclGetString(objv[3]);
+ Tcl_IncrRefCount(objv[3]);
- Tcl_IncrRefCount(ov);
- res = Tcl_PkgRequireProc(interp, argv3, 1, &ov, NULL);
- TclDecrRefCount(ov);
- return res;
+ objvListPtr = Tcl_NewListObj(0, NULL);
+ Tcl_IncrRefCount(objvListPtr);
+ Tcl_ListObjAppendElement(interp, objvListPtr, ov);
+ Tcl_ListObjGetElements(interp, objvListPtr, &newobjc, &newObjvPtr);
+
+ Tcl_NRAddCallback(interp, TclNRPackageObjCmdCleanup, objv[3], objvListPtr, NULL, NULL);
+ Tcl_NRAddCallback(interp, PkgRequireCore, (void *)argv3, INT2PTR(newobjc), newObjvPtr, NULL);
+ return TCL_OK;
} else {
+ int i, newobjc = objc-3;
+ Tcl_Obj *const *newobjv = objv + 3;
if (CheckAllRequirements(interp, objc-3, objv+3) != TCL_OK) {
return TCL_ERROR;
}
+ objvListPtr = Tcl_NewListObj(0, NULL);
+ Tcl_IncrRefCount(objvListPtr);
+ Tcl_IncrRefCount(objv[2]);
+ for (i = 0; i < newobjc; i++) {
- return Tcl_PkgRequireProc(interp, argv2, objc-3, objv+3, NULL);
+ /*
+ * Tcl_Obj structures may have come from another interpreter,
+ * so duplicate them.
+ */
+
+ Tcl_ListObjAppendElement(interp, objvListPtr, Tcl_DuplicateObj(newobjv[i]));
+ }
+ Tcl_ListObjGetElements(interp, objvListPtr, &newobjc, &newObjvPtr);
+ Tcl_NRAddCallback(interp, TclNRPackageObjCmdCleanup, objv[2], objvListPtr, NULL, NULL);
+ Tcl_NRAddCallback(interp, PkgRequireCore, (void *)argv2, INT2PTR(newobjc), newObjvPtr, NULL);
+ return TCL_OK;
}
break;
case PKG_UNKNOWN: {
@@ -1318,6 +1421,13 @@ Tcl_PackageObjCmd(
}
return TCL_OK;
}
+
+static int
+TclNRPackageObjCmdCleanup(ClientData data[], Tcl_Interp *interp, int result) {
+ TclDecrRefCount((Tcl_Obj *)data[0]);
+ TclDecrRefCount((Tcl_Obj *)data[1]);
+ return result;
+}
/*
*----------------------------------------------------------------------
diff --git a/tests/package.test b/tests/package.test
index bb938b8..2843701 100644
--- a/tests/package.test
+++ b/tests/package.test
@@ -625,6 +625,18 @@ test pkg-3.53 {Tcl_PkgRequire procedure, picking best stable version} -constrain
package require t
set x
} -result {1.1}
+test package-3.54 {Tcl_PkgRequire procedure, coroutine support} -setup {
+ package forget t
+} -body {
+ coroutine coro1 apply {{} {
+ package ifneeded t 2.1 {
+ yield
+ package provide t 2.1
+ }
+ package require t 2.1
+ }}
+ list [catch {coro1} msg] $msg
+} -match glob -result {0 2.1}
test package-4.1 {Tcl_PackageCmd procedure} -returnCodes error -body {
generated by cgit v0.12 at 2024-10-21 23:45:14 (GMT)