summaryrefslogtreecommitdiffstats
path: root/generic/tclPkg.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclPkg.c')
-rw-r--r--generic/tclPkg.c245
1 files changed, 57 insertions, 188 deletions
diff --git a/generic/tclPkg.c b/generic/tclPkg.c
index a534021..8fc4d9f 100644
--- a/generic/tclPkg.c
+++ b/generic/tclPkg.c
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclPkg.c,v 1.28 2007/09/10 14:59:56 dgp Exp $
+ * RCS: @(#) $Id: tclPkg.c,v 1.29 2007/09/11 17:46:07 dgp Exp $
*
* TIP #268.
* Heavily rewritten to handle the extend version numbers, and extended
@@ -64,16 +64,16 @@ static int CheckRequirement(Tcl_Interp *interp,
static int CheckAllRequirements(Tcl_Interp *interp, int reqc,
Tcl_Obj *CONST reqv[]);
static int RequirementSatisfied(char *havei, CONST char *req);
-static int AllRequirementsSatisfied(char *havei, int reqc,
+static int SomeRequirementSatisfied(char *havei, int reqc,
Tcl_Obj *CONST reqv[]);
static void AddRequirementsToResult(Tcl_Interp *interp, int reqc,
Tcl_Obj *CONST reqv[]);
static void AddRequirementsToDString(Tcl_DString *dstring,
int reqc, Tcl_Obj *CONST reqv[]);
static Package * FindPackage(Tcl_Interp *interp, CONST char *name);
-static Tcl_Obj * ExactRequirement(CONST char *version);
-static void VersionCleanupProc(ClientData clientData,
- Tcl_Interp *interp);
+static const char * PkgRequireCore(Tcl_Interp *interp, CONST char *name,
+ int reqc, Tcl_Obj *CONST reqv[],
+ ClientData *clientDataPtr);
/*
* Helper macros.
@@ -218,7 +218,7 @@ Tcl_PkgRequireEx(
* call fails for any reason. */
{
Tcl_Obj *ov;
- int res;
+ const char *result = NULL;
/*
* If an attempt is being made to load this into a standalone executable
@@ -294,53 +294,47 @@ Tcl_PkgRequireEx(
/* Translate between old and new API, and defer to the new function. */
if (version == NULL) {
- res = Tcl_PkgRequireProc(interp, name, 0, NULL, clientDataPtr);
+ result = PkgRequireCore(interp, name, 0, NULL, clientDataPtr);
} else {
+ if (exact && TCL_OK
+ != CheckVersionAndConvert(interp, version, NULL, NULL)) {
+ return NULL;
+ }
+ ov = Tcl_NewStringObj(version, -1);
if (exact) {
- ov = ExactRequirement(version);
- } else {
- ov = Tcl_NewStringObj(version, -1);
+ Tcl_AppendStringsToObj(ov, "-", version, NULL);
}
-
Tcl_IncrRefCount(ov);
- res = Tcl_PkgRequireProc(interp, name, 1, &ov, clientDataPtr);
+ result = PkgRequireCore(interp, name, 1, &ov, clientDataPtr);
TclDecrRefCount(ov);
}
- if (res != TCL_OK) {
- return NULL;
- }
+ return result;
+}
- /*
- * This function returns the version string explictly, and leaves the
- * interpreter result empty. However "Tcl_PkgRequireProc" above returned
- * the version through the interpreter result. Simply resetting the result
- * now potentially deletes the string (obj), and the pointer to its string
- * rep we have, as our result, may be dangling due to this. Our solution
- * is to remember the object in interp associated data, with a proper
- * reference count, and then reset the result. Now pointers will not
- * dangle. It will be a leak however if nothing is done. So the next time
- * we come through here we delete the object remembered by this call, as
- * we can then be sure that there is no pointer to its string around
- * anymore. Beyond that we have a deletion function which cleans up the
- * last remembered object which was not cleaned up directly, here.
- */
+int
+Tcl_PkgRequireProc(
+ Tcl_Interp *interp, /* Interpreter in which package is now
+ * available. */
+ CONST char *name, /* Name of desired package. */
+ int reqc, /* Requirements constraining the desired
+ * version. */
+ Tcl_Obj *CONST reqv[], /* 0 means to use the latest version
+ * available. */
+ ClientData *clientDataPtr)
+{
+ const char *result =
+ PkgRequireCore(interp, name, reqc, reqv, clientDataPtr);
- ov = (Tcl_Obj *) Tcl_GetAssocData(interp, "tcl/Tcl_PkgRequireEx", NULL);
- if (ov != NULL) {
- TclDecrRefCount(ov);
+ if (result == NULL) {
+ return TCL_ERROR;
}
-
- ov = Tcl_GetObjResult(interp);
- Tcl_IncrRefCount(ov);
- Tcl_SetAssocData(interp, "tcl/Tcl_PkgRequireEx", VersionCleanupProc, ov);
- Tcl_ResetResult(interp);
-
- return TclGetString(ov);
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(result, -1));
+ return TCL_OK;
}
-int
-Tcl_PkgRequireProc(
+static const char *
+PkgRequireCore(
Tcl_Interp *interp, /* Interpreter in which package is now
* available. */
CONST char *name, /* Name of desired package. */
@@ -384,7 +378,7 @@ Tcl_PkgRequireProc(
"attempt to provide ", name, " ",
(char *) pkgPtr->clientData, " requires ", name, NULL);
AddRequirementsToResult(interp, reqc, reqv);
- return TCL_ERROR;
+ return NULL;
}
/*
@@ -436,7 +430,7 @@ Tcl_PkgRequireProc(
* Check satisfaction of requirements.
*/
- satisfies = AllRequirementsSatisfied(availVersion,reqc,reqv);
+ satisfies = SomeRequirementSatisfied(availVersion,reqc,reqv);
if (!satisfies) {
ckfree(availVersion);
availVersion = NULL;
@@ -562,7 +556,7 @@ Tcl_PkgRequireProc(
pkgPtr->version = NULL;
}
pkgPtr->clientData = NULL;
- return TCL_ERROR;
+ return NULL;
}
break;
@@ -600,7 +594,7 @@ Tcl_PkgRequireProc(
if (code == TCL_ERROR) {
Tcl_AddErrorInfo(interp,
"\n (\"package unknown\" script)");
- return TCL_ERROR;
+ return NULL;
}
Tcl_ResetResult(interp);
}
@@ -609,7 +603,7 @@ Tcl_PkgRequireProc(
if (pkgPtr->version == NULL) {
Tcl_AppendResult(interp, "can't find package ", name, NULL);
AddRequirementsToResult(interp, reqc, reqv);
- return TCL_ERROR;
+ return NULL;
}
/*
@@ -621,7 +615,7 @@ Tcl_PkgRequireProc(
satisfies = 1;
} else {
CheckVersionAndConvert(interp, pkgPtr->version, &pkgVersionI, NULL);
- satisfies = AllRequirementsSatisfied(pkgVersionI, reqc, reqv);
+ satisfies = SomeRequirementSatisfied(pkgVersionI, reqc, reqv);
ckfree(pkgVersionI);
}
@@ -630,14 +624,13 @@ Tcl_PkgRequireProc(
if (clientDataPtr) {
*clientDataPtr = pkgPtr->clientData;
}
- Tcl_SetObjResult(interp, Tcl_NewStringObj(pkgPtr->version, -1));
- return TCL_OK;
+ return pkgPtr->version;
}
Tcl_AppendResult(interp, "version conflict for package \"", name,
"\": have ", pkgPtr->version, ", need", NULL);
AddRequirementsToResult(interp, reqc, reqv);
- return TCL_ERROR;
+ return NULL;
}
/*
@@ -977,7 +970,8 @@ Tcl_PackageObjCmd(
* Create a new-style requirement for the exact version.
*/
- ov = ExactRequirement(version);
+ ov = Tcl_NewStringObj(version, -1);
+ Tcl_AppendStringsToObj(ov, "-", version, NULL);
version = NULL;
argv3 = TclGetString(objv[3]);
@@ -1114,7 +1108,7 @@ Tcl_PackageObjCmd(
return TCL_ERROR;
}
- satisfies = AllRequirementsSatisfied(argv2i, objc-3, objv+3);
+ satisfies = SomeRequirementSatisfied(argv2i, objc-3, objv+3);
ckfree(argv2i);
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(satisfies));
@@ -1642,7 +1636,15 @@ AddRequirementsToResult(
int i;
for (i = 0; i < reqc; i++) {
- Tcl_AppendResult(interp, " ", TclGetString(reqv[i]), NULL);
+ int length;
+ char *v = Tcl_GetStringFromObj(reqv[i], &length);
+
+ if ((length & 0x1) && (v[length/2] == '-')
+ && (strncmp(v, v+((length+1)/2), length/2) == 0)) {
+ Tcl_AppendResult(interp, " exactly ", v+((length+1)/2), NULL);
+ } else {
+ Tcl_AppendResult(interp, " ", v, NULL);
+ }
}
}
}
@@ -1686,7 +1688,7 @@ AddRequirementsToDString(
/*
*----------------------------------------------------------------------
*
- * AllRequirementSatisfied --
+ * SomeRequirementSatisfied --
*
* This function checks to see whether a version satisfies at least one
* of a set of requirements.
@@ -1703,7 +1705,7 @@ AddRequirementsToDString(
*/
static int
-AllRequirementsSatisfied(
+SomeRequirementSatisfied(
char *availVersionI, /* Candidate version to check against the
* requirements. */
int reqc, /* Requirements constraining the desired
@@ -1823,139 +1825,6 @@ RequirementSatisfied(
}
/*
- *----------------------------------------------------------------------
- *
- * ExactRequirement --
- *
- * This function is the core for the translation of -exact requests. It
- * translates the request of the version into a range of versions. The
- * translation was chosen for backwards compatibility.
- *
- * Results:
- * A Tcl_Obj containing the version range as string.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-static Tcl_Obj *
-ExactRequirement(
- CONST char *version)
-{
- /*
- * A -exact request for a version X.y is translated into the range
- * X.y-X.(y+1). For example -exact 8.4 means the range "8.4-8.5".
- *
- * This translation was chosen to prevent packages which currently use a
- * 'package require -exact tclversion' from being affected by the core now
- * registering itself as 8.4.x (patchlevel) instead of 8.4 (version).
- * Examples are tbcload, compiler, and ITcl.
- *
- * Translating -exact 8.4 to the range "8.4-8.4" instead would require us
- * and everyone else to rebuild these packages to require -exact 8.4.14,
- * or whatever the exact current patchlevel is. A backward compatibility
- * issue with effects similar to the bugfix made in 8.5 now requiring
- * ifneeded and provided versions to match. Instead we have chosen to
- * interpret exactness to not be exactly equal, but to be exact only
- * within the specified level, and allowing variation in the deeper level.
- * More examples:
- *
- * -exact 8 => "8-9"
- * -exact 8.4 => "8.4-8.5"
- * -exact 8.4.14 => "8.4.14-8.4.15"
- * -exact 8.0a2 => "8.0a2-8.0a3"
- */
-
- char *iv, buf[30];
- int lc, i;
- CONST char **lv;
- Tcl_Obj *objPtr = Tcl_NewStringObj(version, -1);
-
- Tcl_AppendStringsToObj(objPtr, "-", NULL);
-
- /*
- * Assuming valid syntax here.
- */
-
- CheckVersionAndConvert(NULL, version, &iv, NULL);
-
- /*
- * Split the list into components.
- */
-
- Tcl_SplitList(NULL, iv, &lc, &lv);
-
- /*
- * Iterate over the components and make them parts of the result. Except
- * for the last, which is handled separately, to allow the incrementation.
- */
-
- for (i=0; i < (lc-1); i++) {
- /*
- * Regular component.
- */
-
- Tcl_AppendStringsToObj(objPtr, lv[i], NULL);
-
- /*
- * Separator component.
- */
-
- i++;
- if (0 == strcmp("-1", lv[i])) {
- Tcl_AppendStringsToObj(objPtr, "b", NULL);
- } else if (0 == strcmp("-2", lv[i])) {
- Tcl_AppendStringsToObj(objPtr, "a", NULL);
- } else {
- Tcl_AppendStringsToObj(objPtr, ".", NULL);
- }
- }
-
- /*
- * Regular component, last.
- */
-
- sprintf(buf, "%d", atoi(lv[lc-1]) + 1);
- Tcl_AppendStringsToObj(objPtr, buf, NULL);
-
- ckfree((char *) iv);
- ckfree((char *) lv);
- return objPtr;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * VersionCleanupProc --
- *
- * This function is called to delete the last remember package version
- * string for an interpreter when the interpreter is deleted. It gets
- * invoked via the Tcl AssocData mechanism.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Storage for the version object for interp get deleted.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-VersionCleanupProc(
- ClientData clientData, /* Pointer to remembered version string object
- * for interp. */
- Tcl_Interp *interp) /* Interpreter that is being deleted. */
-{
- Tcl_Obj *ov = clientData;
- if (ov != NULL) {
- TclDecrRefCount(ov);
- }
-}
-
-/*
* Local Variables:
* mode: c
* c-basic-offset: 4