diff options
Diffstat (limited to 'generic/tclPkg.c')
| -rw-r--r-- | generic/tclPkg.c | 1202 |
1 files changed, 391 insertions, 811 deletions
diff --git a/generic/tclPkg.c b/generic/tclPkg.c index 82860a6..52f33c3 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -4,8 +4,8 @@ * This file implements package and version control for Tcl via the * "package" command and a few C APIs. * - * Copyright © 1996 Sun Microsystems, Inc. - * Copyright © 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net> + * Copyright (c) 1996 Sun Microsystems, Inc. + * Copyright (c) 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net> * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -17,10 +17,6 @@ #include "tclInt.h" -MODULE_SCOPE char *tclEmptyStringRep; - -char *tclEmptyStringRep = &tclEmptyString; - /* * Each invocation of the "package ifneeded" command creates a structure of * the following type, which is used to load the package into the interpreter @@ -32,24 +28,10 @@ typedef struct PkgAvail { char *script; /* Script to invoke to provide this version of * the package. Malloc'ed and protected by * Tcl_Preserve and Tcl_Release. */ - char *pkgIndex; /* Full file name of pkgIndex file */ struct PkgAvail *nextPtr; /* Next in list of available versions of the * same package. */ } PkgAvail; -typedef struct PkgName { - struct PkgName *nextPtr; /* Next in list of package names being - * initialized. */ - char name[TCLFLEXARRAY]; -} PkgName; - -typedef struct PkgFiles { - PkgName *names; /* Package names being initialized. Must be - * first field. */ - Tcl_HashTable table; /* Table which contains files for each - * package. */ -} PkgFiles; - /* * For each package that is known in any way to an interpreter, there is one * record of the following type. These records are stored in the @@ -58,24 +40,15 @@ typedef struct PkgFiles { */ typedef struct Package { - Tcl_Obj *version; + 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. */ PkgAvail *availPtr; /* First in list of all available versions of * this package. */ - const void *clientData; /* Client data. */ + ClientData clientData; /* Client data. */ } Package; -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: */ @@ -96,25 +69,19 @@ 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 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); +static const char * PkgRequireCore(Tcl_Interp *interp, const char *name, + int reqc, Tcl_Obj *const reqv[], + ClientData *clientDataPtr); /* * Helper macros. */ #define DupBlock(v,s,len) \ - ((v) = (char *)ckalloc(len), memcpy((v),(s),(len))) + ((v) = ckalloc(len), memcpy((v),(s),(len))) #define DupString(v,s) \ do { \ - size_t local__len = strlen(s) + 1; \ + unsigned local__len = (unsigned) (strlen(s) + 1); \ DupBlock((v),(s),local__len); \ } while (0) @@ -156,7 +123,7 @@ Tcl_PkgProvideEx( * available. */ const char *name, /* Name of package. */ const char *version, /* Version string for package. */ - const void *clientData) /* clientdata for this package (normally used + ClientData clientData) /* clientdata for this package (normally used * for C callback function table) */ { Package *pkgPtr; @@ -165,13 +132,12 @@ Tcl_PkgProvideEx( pkgPtr = FindPackage(interp, name); if (pkgPtr->version == NULL) { - pkgPtr->version = Tcl_NewStringObj(version, -1); - Tcl_IncrRefCount(pkgPtr->version); + DupString(pkgPtr->version, version); pkgPtr->clientData = clientData; return TCL_OK; } - if (CheckVersionAndConvert(interp, Tcl_GetString(pkgPtr->version), &pvi, + if (CheckVersionAndConvert(interp, pkgPtr->version, &pvi, NULL) != TCL_OK) { return TCL_ERROR; } else if (CheckVersionAndConvert(interp, version, &vi, NULL) != TCL_OK) { @@ -189,10 +155,8 @@ Tcl_PkgProvideEx( } return TCL_OK; } - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "conflicting versions provided for package \"%s\": %s, then %s", - name, Tcl_GetString(pkgPtr->version), version)); - Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT", (void *)NULL); + Tcl_AppendResult(interp, "conflicting versions provided for package \"", + name, "\": ", pkgPtr->version, ", then ", version, NULL); return TCL_ERROR; } @@ -223,78 +187,6 @@ Tcl_PkgProvideEx( *---------------------------------------------------------------------- */ -static void -PkgFilesCleanupProc( - ClientData clientData, - TCL_UNUSED(Tcl_Interp *)) -{ - PkgFiles *pkgFiles = (PkgFiles *) clientData; - Tcl_HashSearch search; - Tcl_HashEntry *entry; - - while (pkgFiles->names) { - PkgName *name = pkgFiles->names; - - pkgFiles->names = name->nextPtr; - ckfree(name); - } - entry = Tcl_FirstHashEntry(&pkgFiles->table, &search); - while (entry) { - Tcl_Obj *obj = (Tcl_Obj *)Tcl_GetHashValue(entry); - - Tcl_DecrRefCount(obj); - entry = Tcl_NextHashEntry(&search); - } - Tcl_DeleteHashTable(&pkgFiles->table); - ckfree(pkgFiles); - return; -} - -void * -TclInitPkgFiles( - Tcl_Interp *interp) -{ - /* - * If assocdata "tclPkgFiles" doesn't exist yet, create it. - */ - - PkgFiles *pkgFiles = (PkgFiles *)Tcl_GetAssocData(interp, "tclPkgFiles", NULL); - - if (!pkgFiles) { - pkgFiles = (PkgFiles *)ckalloc(sizeof(PkgFiles)); - pkgFiles->names = NULL; - Tcl_InitHashTable(&pkgFiles->table, TCL_STRING_KEYS); - Tcl_SetAssocData(interp, "tclPkgFiles", PkgFilesCleanupProc, pkgFiles); - } - return pkgFiles; -} - -void -TclPkgFileSeen( - Tcl_Interp *interp, - const char *fileName) -{ - PkgFiles *pkgFiles = (PkgFiles *) - Tcl_GetAssocData(interp, "tclPkgFiles", NULL); - - if (pkgFiles && pkgFiles->names) { - const char *name = pkgFiles->names->name; - Tcl_HashTable *table = &pkgFiles->table; - int isNew; - Tcl_HashEntry *entry = (Tcl_HashEntry *)Tcl_CreateHashEntry(table, name, &isNew); - Tcl_Obj *list; - - if (isNew) { - TclNewObj(list); - Tcl_SetHashValue(entry, list); - Tcl_IncrRefCount(list); - } else { - list = (Tcl_Obj *)Tcl_GetHashValue(entry); - } - Tcl_ListObjAppendElement(interp, list, Tcl_NewStringObj(fileName, -1)); - } -} - #undef Tcl_PkgRequire const char * Tcl_PkgRequire( @@ -320,7 +212,7 @@ Tcl_PkgRequireEx( int exact, /* Non-zero means that only the particular * version given is acceptable. Zero means use * the latest compatible version. */ - void *clientDataPtr) /* Used to return the client data for this + ClientData *clientDataPtr) /* Used to return the client data for this * package. If it is NULL then the client data * is not returned. This is unchanged if this * call fails for any reason. */ @@ -364,12 +256,12 @@ Tcl_PkgRequireEx( * * Second, how does this work? If we reach this point, then the global * variable tclEmptyStringRep has the value NULL. Compare that with - * the definition of tclEmptyStringRep near the top of this file. It - * clearly should not have the value NULL; it should point to the char - * tclEmptyString. If we see it having the value NULL, then somehow we - * are seeing a Tcl library that isn't completely initialized, and - * that's an indicator for the error condition described above. - * (Further explanation is welcome.) + * the definition of tclEmptyStringRep near the top of the file + * generic/tclObj.c. It clearly should not have the value NULL; it + * should point to the char tclEmptyString. If we see it having the + * value NULL, then somehow we are seeing a Tcl library that isn't + * completely initialized, and that's an indicator for the error + * condition described above. (Further explanation is welcome.) * * Third, so what do we do about it? This situation indicates the * package we just loaded wasn't properly compiled to be stub-enabled, @@ -381,15 +273,21 @@ Tcl_PkgRequireEx( * After all, two Tcl libraries can't be a good thing!) * * Trouble is that's going to be tricky. We're now using a Tcl library - * that's not fully initialized. Functions in it may not work - * reliably, so be very careful about adding any other calls here - * without checking how they behave when initialization is incomplete. + * that's not fully initialized. In particular, it doesn't have a + * proper value for tclEmptyStringRep. The Tcl_Obj system heavily + * depends on the value of tclEmptyStringRep and all of Tcl depends + * (increasingly) on the Tcl_Obj system, we need to correct that flaw + * before making the calls to set the interpreter result to the error + * message. That's the only flaw corrected; other problems with + * initialization of the Tcl library are not remedied, so be very + * careful about adding any other calls here without checking how they + * behave when initialization is incomplete. */ - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "Cannot load package \"%s\" in standalone executable:" - " This package is not compiled with stub support", name)); - Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNSTUBBED", (void *)NULL); + tclEmptyStringRep = &tclEmptyString; + Tcl_AppendResult(interp, "Cannot load package \"", name, + "\" in standalone executable: This package is not " + "compiled with stub support", NULL); return NULL; } @@ -398,10 +296,7 @@ Tcl_PkgRequireEx( */ if (version == NULL) { - if (Tcl_PkgRequireProc(interp, name, 0, NULL, clientDataPtr) == TCL_OK) { - result = Tcl_GetString(Tcl_GetObjResult(interp)); - Tcl_ResetResult(interp); - } + result = PkgRequireCore(interp, name, 0, NULL, clientDataPtr); } else { if (exact && TCL_OK != CheckVersionAndConvert(interp, version, NULL, NULL)) { @@ -409,15 +304,13 @@ Tcl_PkgRequireEx( } ov = Tcl_NewStringObj(version, -1); if (exact) { - Tcl_AppendStringsToObj(ov, "-", version, (void *)NULL); + Tcl_AppendStringsToObj(ov, "-", version, NULL); } Tcl_IncrRefCount(ov); - if (Tcl_PkgRequireProc(interp, name, 1, &ov, clientDataPtr) == TCL_OK) { - result = Tcl_GetString(Tcl_GetObjResult(interp)); - Tcl_ResetResult(interp); - } + result = PkgRequireCore(interp, name, 1, &ov, clientDataPtr); TclDecrRefCount(ov); } + return result; } @@ -430,522 +323,317 @@ Tcl_PkgRequireProc( * version. */ Tcl_Obj *const reqv[], /* 0 means to use the latest version * available. */ - void *clientDataPtr) + ClientData *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 = (RequireProcArgs *)clientData; - - Tcl_NRAddCallback(interp, - PkgRequireCore, (void *) args->name, INT2PTR(reqc), (void *) reqv, - args->clientDataPtr); - return TCL_OK; -} + const char *result = + PkgRequireCore(interp, name, reqc, reqv, clientDataPtr); -static int -PkgRequireCore( - ClientData data[], - Tcl_Interp *interp, - TCL_UNUSED(int)) -{ - const char *name = (const char *)data[0]; - int reqc = PTR2INT(data[1]); - Tcl_Obj **reqv = (Tcl_Obj **)data[2]; - int code = CheckAllRequirements(interp, reqc, reqv); - Require *reqPtr; - - if (code != TCL_OK) { - return code; - } - reqPtr = (Require *)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), reqv, - (void *)PkgRequireCoreStep1); - } else { - Tcl_NRAddCallback(interp, - PkgRequireCoreFinal, reqPtr, INT2PTR(reqc), reqv, NULL); + if (result == NULL) { + return TCL_ERROR; } + Tcl_SetObjResult(interp, Tcl_NewStringObj(result, -1)); return TCL_OK; } -static int -PkgRequireCoreStep1( - ClientData data[], - Tcl_Interp *interp, - TCL_UNUSED(int)) +static const char * +PkgRequireCore( + 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) { + Interp *iPtr = (Interp *) interp; + Package *pkgPtr; + PkgAvail *availPtr, *bestPtr, *bestStablePtr; + char *availVersion, *bestVersion; + /* Internal rep. of versions */ + int availStable, code, satisfies, pass; + char *script, *pkgVersionI; Tcl_DString command; - char *script; - Require *reqPtr = (Require *)data[0]; - int reqc = PTR2INT(data[1]); - Tcl_Obj **const reqv = (Tcl_Obj **)data[2]; - const char *name = reqPtr->name /* Name of desired package. */; - /* - * If we've got the package in the DB already, go on to actually loading - * it. - */ - - if (reqPtr->pkgPtr->version != NULL) { - Tcl_NRAddCallback(interp, - PkgRequireCoreFinal, reqPtr, INT2PTR(reqc), (void *)reqv, NULL); - return TCL_OK; + if (TCL_OK != CheckAllRequirements(interp, reqc, reqv)) { + return NULL; } /* - * The package is not in the database. If there is a "package unknown" - * command, invoke it. + * 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 + * a specific version, and a final pass to lookup the package loaded by + * the "package ifneeded" script. */ - script = ((Interp *) interp)->packageUnknown; - if (script == NULL) { + for (pass=1 ;; pass++) { + pkgPtr = FindPackage(interp, name); + if (pkgPtr->version != NULL) { + break; + } + /* - * No package unknown script. Move on to finalizing. + * Check whether we're already attempting to load some version of this + * package (circular dependency detection). */ - Tcl_NRAddCallback(interp, - PkgRequireCoreFinal, reqPtr, INT2PTR(reqc), (void *)reqv, NULL); - return TCL_OK; - } - - /* - * Invoke the "package unknown" script synchronously. - */ - - 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; -} - -static int -PkgRequireCoreStep2( - ClientData data[], - Tcl_Interp *interp, - int result) -{ - Require *reqPtr = (Require *)data[0]; - int reqc = PTR2INT(data[1]); - Tcl_Obj **const reqv = (Tcl_Obj **)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", (void *)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. - */ + if (pkgPtr->clientData != NULL) { + Tcl_AppendResult(interp, "circular package dependency: " + "attempt to provide ", name, " ", + (char *) pkgPtr->clientData, " requires ", name, NULL); + AddRequirementsToResult(interp, reqc, reqv); + return NULL; + } - reqPtr->pkgPtr = FindPackage(interp, name); - Tcl_NRAddCallback(interp, - SelectPackage, reqPtr, INT2PTR(reqc), reqv, - (void *)PkgRequireCoreFinal); - return TCL_OK; -} + /* + * The package isn't yet present. Search the list of available + * versions and invoke the script for the best available version. We + * are actually locating the best, and the best stable version. One of + * them is then chosen based on the selection mode. + */ -static int -PkgRequireCoreFinal( - ClientData data[], - Tcl_Interp *interp, - TCL_UNUSED(int)) -{ - Require *reqPtr = (Require *)data[0]; - int reqc = PTR2INT(data[1]), satisfies; - Tcl_Obj **const reqv = (Tcl_Obj **)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)); - Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNFOUND", (void *)NULL); - AddRequirementsToResult(interp, reqc, reqv); - return TCL_ERROR; - } + bestPtr = NULL; + bestStablePtr = NULL; + bestVersion = NULL; - /* - * Ensure that the provided version meets the current requirements. - */ + for (availPtr = pkgPtr->availPtr; availPtr != NULL; + availPtr = availPtr->nextPtr) { + if (CheckVersionAndConvert(interp, availPtr->version, + &availVersion, &availStable) != TCL_OK) { + /* + * The provided version number has invalid syntax. This + * should not happen. This should have been caught by the + * 'package ifneeded' registering the package. + */ - if (reqc != 0) { - CheckVersionAndConvert(interp, Tcl_GetString(reqPtr->pkgPtr->version), - &pkgVersionI, NULL); - satisfies = SomeRequirementSatisfied(pkgVersionI, reqc, reqv); + continue; + } - ckfree(pkgVersionI); + if (bestPtr != NULL) { + int res = CompareVersions(availVersion, bestVersion, NULL); - if (!satisfies) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "version conflict for package \"%s\": have %s, need", - name, Tcl_GetString(reqPtr->pkgPtr->version))); - Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT", - (void *)NULL); - AddRequirementsToResult(interp, reqc, reqv); - return TCL_ERROR; - } - } + /* + * Note: Use internal reps! + */ - if (clientDataPtr) { - const void **ptr = (const void **) clientDataPtr; + if (res <= 0) { + /* + * The version of the package sought is not as good as the + * currently selected version. Ignore it. + */ - *ptr = reqPtr->pkgPtr->clientData; - } - Tcl_SetObjResult(interp, reqPtr->pkgPtr->version); - return TCL_OK; -} + ckfree(availVersion); + availVersion = NULL; + continue; + } + } -static int -PkgRequireCoreCleanup( - ClientData data[], - TCL_UNUSED(Tcl_Interp *), - int result) -{ - ckfree(data[0]); - return result; -} - -static int -SelectPackage( - ClientData data[], - Tcl_Interp *interp, - TCL_UNUSED(int)) -{ - PkgAvail *availPtr, *bestPtr, *bestStablePtr; - char *availVersion, *bestVersion, *bestStableVersion; - /* Internal rep. of versions */ - int availStable, satisfies; - Require *reqPtr = (Require *)data[0]; - int reqc = PTR2INT(data[1]); - Tcl_Obj **const reqv = (Tcl_Obj **)data[2]; - const char *name = reqPtr->name; - Package *pkgPtr = reqPtr->pkgPtr; - Interp *iPtr = (Interp *) interp; + /* We have found a version which is better than our max. */ - /* - * Check whether we're already attempting to load some version of this - * package (circular dependency detection). - */ + if (reqc > 0) { + /* Check satisfaction of requirements. */ - if (pkgPtr->clientData != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "circular package dependency:" - " attempt to provide %s %s requires %s", - name, (char *) pkgPtr->clientData, name)); - AddRequirementsToResult(interp, reqc, reqv); - Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "CIRCULARITY", (void *)NULL); - return TCL_ERROR; - } + satisfies = SomeRequirementSatisfied(availVersion, reqc, reqv); + if (!satisfies) { + ckfree(availVersion); + availVersion = NULL; + continue; + } + } - /* - * The package isn't yet present. Search the list of available versions - * and invoke the script for the best available version. We are actually - * locating the best, and the best stable version. One of them is then - * chosen based on the selection mode. - */ + bestPtr = availPtr; - bestPtr = NULL; - bestStablePtr = NULL; - bestVersion = NULL; - bestStableVersion = NULL; + if (bestVersion != NULL) { + ckfree(bestVersion); + } + bestVersion = availVersion; - for (availPtr = pkgPtr->availPtr; availPtr != NULL; - availPtr = availPtr->nextPtr) { - if (CheckVersionAndConvert(interp, availPtr->version, - &availVersion, &availStable) != TCL_OK) { /* - * The provided version number has invalid syntax. This should not - * happen. This should have been caught by the 'package ifneeded' - * registering the package. + * If this new best version is stable then it also has to be + * better than the max stable version found so far. */ - continue; + if (availStable) { + bestStablePtr = availPtr; + } + } + + if (bestVersion != NULL) { + ckfree(bestVersion); } /* - * Check satisfaction of requirements before considering the current - * version further. + * Now choose a version among the two best. For 'latest' we simply + * take (actually keep) the best. For 'stable' we take the best + * stable, if there is any, or the best if there is nothing stable. */ - if (reqc > 0) { - satisfies = SomeRequirementSatisfied(availVersion, reqc, reqv); - if (!satisfies) { - ckfree(availVersion); - availVersion = NULL; - continue; - } + if ((iPtr->packagePrefer == PKG_PREFER_STABLE) + && (bestStablePtr != NULL)) { + bestPtr = bestStablePtr; } if (bestPtr != NULL) { - int res = CompareVersions(availVersion, bestVersion, NULL); - /* - * Note: Used internal reps in the comparison! + * We found an ifneeded script for the package. Be careful while + * executing it: this could cause reentrancy, so (a) protect the + * script itself from deletion and (b) don't assume that bestPtr + * will still exist when the script completes. */ - if (res > 0) { - /* - * The version of the package sought is better than the - * currently selected version. - */ - - ckfree(bestVersion); - bestVersion = NULL; - goto newbest; + const char *versionToProvide = bestPtr->version; + script = bestPtr->script; + + pkgPtr->clientData = (ClientData) versionToProvide; + Tcl_Preserve((ClientData) script); + Tcl_Preserve((ClientData) versionToProvide); + code = Tcl_EvalEx(interp, script, -1, TCL_EVAL_GLOBAL); + Tcl_Release((ClientData) script); + + pkgPtr = FindPackage(interp, name); + if (code == TCL_OK) { + Tcl_ResetResult(interp); + if (pkgPtr->version == NULL) { + code = TCL_ERROR; + Tcl_AppendResult(interp, "attempt to provide package ", + name, " ", versionToProvide, + " failed: no version of package ", name, + " provided", NULL); + } else { + char *pvi, *vi; + + if (CheckVersionAndConvert(interp, 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_AppendResult(interp, + "attempt to provide package ", name, " ", + versionToProvide, " failed: package ", + name, " ", pkgPtr->version, + " provided instead", NULL); + } + } + } + } else if (code != TCL_ERROR) { + Tcl_Obj *codePtr = Tcl_NewIntObj(code); + + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "attempt to provide package ", name, + " ", versionToProvide, " failed: bad return code: ", + TclGetString(codePtr), NULL); + TclDecrRefCount(codePtr); + code = TCL_ERROR; } - } else { - newbest: - /* - * We have found a version which is better than our max. - */ - bestPtr = availPtr; - CheckVersionAndConvert(interp, bestPtr->version, &bestVersion, NULL); - } - - if (!availStable) { - ckfree(availVersion); - availVersion = NULL; - continue; - } - - if (bestStablePtr != NULL) { - int res = CompareVersions(availVersion, bestStableVersion, NULL); - - /* - * Note: Used internal reps in the comparison! - */ + if (code == TCL_ERROR) { + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (\"package ifneeded %s %s\" script)", + name, versionToProvide)); + } + Tcl_Release((ClientData) versionToProvide); - if (res > 0) { + if (code != TCL_OK) { /* - * This stable version of the package sought is better than - * the currently selected stable version. + * 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. */ - ckfree(bestStableVersion); - bestStableVersion = NULL; - goto newstable; + if (pkgPtr->version != NULL) { + ckfree(pkgPtr->version); + pkgPtr->version = NULL; + } + pkgPtr->clientData = NULL; + return NULL; } - } else { - newstable: - /* - * We have found a stable version which is better than our max - * stable. - */ - bestStablePtr = availPtr; - CheckVersionAndConvert(interp, bestStablePtr->version, - &bestStableVersion, NULL); + break; } - ckfree(availVersion); - availVersion = NULL; - } /* end for */ - - /* - * Clean up memorized internal reps, if any. - */ - - if (bestVersion != NULL) { - ckfree(bestVersion); - bestVersion = NULL; - } - - if (bestStableVersion != NULL) { - ckfree(bestStableVersion); - bestStableVersion = NULL; - } - - /* - * Now choose a version among the two best. For 'latest' we simply take - * (actually keep) the best. For 'stable' we take the best stable, if - * there is any, or the best if there is nothing stable. - */ - - if ((iPtr->packagePrefer == PKG_PREFER_STABLE) - && (bestStablePtr != NULL)) { - bestPtr = bestStablePtr; - } - - if (bestPtr == NULL) { - Tcl_NRAddCallback(interp, - (Tcl_NRPostProc *)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 - * script itself from deletion and (b) don't assume that bestPtr will - * still exist when the script completes. + * The package is not in the database. If there is a "package unknown" + * command, invoke it (but only on the first pass; after that, we + * should not get here in the first place). */ - char *versionToProvide = bestPtr->version; - PkgFiles *pkgFiles; - PkgName *pkgName; - - Tcl_Preserve(versionToProvide); - pkgPtr->clientData = versionToProvide; - - pkgFiles = (PkgFiles *)TclInitPkgFiles(interp); - - /* - * Push "ifneeded" package name in "tclPkgFiles" assocdata. - */ + if (pass > 1) { + break; + } - pkgName = (PkgName *)ckalloc(offsetof(PkgName, name) + 1 + strlen(name)); - pkgName->nextPtr = pkgFiles->names; - strcpy(pkgName->name, name); - pkgFiles->names = pkgName; - if (bestPtr->pkgIndex) { - TclPkgFileSeen(interp, bestPtr->pkgIndex); + 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_Obj *codePtr = Tcl_NewIntObj(code); + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "bad return code: ", + TclGetString(codePtr), NULL); + Tcl_DecrRefCount(codePtr); + code = TCL_ERROR; + } + if (code == TCL_ERROR) { + Tcl_AddErrorInfo(interp, + "\n (\"package unknown\" script)"); + return NULL; + } + Tcl_ResetResult(interp); } - 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 = (Require *)data[0]; - int reqc = PTR2INT(data[1]); - Tcl_Obj **const reqv = (Tcl_Obj **)data[2]; - const char *name = reqPtr->name; - char *versionToProvide = reqPtr->versionToProvide; + + if (pkgPtr->version == NULL) { + Tcl_AppendResult(interp, "can't find package ", name, NULL); + AddRequirementsToResult(interp, reqc, reqv); + return NULL; + } /* - * Pop the "ifneeded" package name from "tclPkgFiles" assocdata + * At this point we know that the package is present. Make sure that the + * provided version meets the current requirements. */ - PkgFiles *pkgFiles = (PkgFiles *)Tcl_GetAssocData(interp, "tclPkgFiles", NULL); - PkgName *pkgName = pkgFiles->names; - 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:" - " no version of package %s provided", - name, versionToProvide, name)); - Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNPROVIDED", - (void *)NULL); - } else { - char *pvi, *vi; - - if (TCL_OK != CheckVersionAndConvert(interp, - Tcl_GetString(reqPtr->pkgPtr->version), &pvi, NULL)) { - 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, Tcl_GetString(reqPtr->pkgPtr->version))); - Tcl_SetErrorCode(interp, "TCL", "PACKAGE", - "WRONGPROVIDE", (void *)NULL); - } - } - } - } else if (result != TCL_ERROR) { - Tcl_Obj *codePtr; - - TclNewIntObj(codePtr, result); - 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", (void *)NULL); - TclDecrRefCount(codePtr); - result = TCL_ERROR; - } + if (reqc == 0) { + satisfies = 1; + } else { + CheckVersionAndConvert(interp, pkgPtr->version, &pkgVersionI, NULL); + satisfies = SomeRequirementSatisfied(pkgVersionI, reqc, reqv); - if (result == TCL_ERROR) { - Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (\"package ifneeded %s %s\" script)", - name, versionToProvide)); + ckfree(pkgVersionI); } - 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) { - Tcl_DecrRefCount(reqPtr->pkgPtr->version); - reqPtr->pkgPtr->version = NULL; + if (satisfies) { + if (clientDataPtr) { + *clientDataPtr = pkgPtr->clientData; } - reqPtr->pkgPtr->clientData = NULL; - return result; + return pkgPtr->version; } - Tcl_NRAddCallback(interp, - (Tcl_NRPostProc *)data[3], reqPtr, INT2PTR(reqc), (void *) reqv, NULL); - return TCL_OK; + Tcl_AppendResult(interp, "version conflict for package \"", name, + "\": have ", pkgPtr->version, ", need", NULL); + AddRequirementsToResult(interp, reqc, reqv); + return NULL; } /* @@ -994,7 +682,7 @@ Tcl_PkgPresentEx( int exact, /* Non-zero means that only the particular * version given is acceptable. Zero means use * the latest compatible version. */ - void *clientDataPtr) /* Used to return the client data for this + ClientData *clientDataPtr) /* Used to return the client data for this * package. If it is NULL then the client data * is not returned. This is unchanged if this * call fails for any reason. */ @@ -1005,7 +693,7 @@ Tcl_PkgPresentEx( hPtr = Tcl_FindHashEntry(&iPtr->packageTable, name); if (hPtr) { - pkgPtr = (Package *)Tcl_GetHashValue(hPtr); + pkgPtr = Tcl_GetHashValue(hPtr); if (pkgPtr->version != NULL) { /* * At this point we know that the package is present. Make sure @@ -1018,20 +706,19 @@ Tcl_PkgPresentEx( if (foundVersion == NULL) { Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PACKAGE", name, - (void *)NULL); + NULL); } return foundVersion; } } if (version != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "package %s %s is not present", name, version)); + Tcl_AppendResult(interp, "package ", name, " ", version, + " is not present", NULL); } else { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "package %s is not present", name)); + Tcl_AppendResult(interp, "package ", name, " is not present", NULL); } - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PACKAGE", name, (void *)NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PACKAGE", name, NULL); return NULL; } @@ -1051,47 +738,37 @@ Tcl_PkgPresentEx( * *---------------------------------------------------------------------- */ -int -Tcl_PackageObjCmd( - ClientData clientData, - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - return Tcl_NRCallObjProc(interp, TclNRPackageObjCmd, clientData, objc, objv); -} + /* ARGSUSED */ int -TclNRPackageObjCmd( - TCL_UNUSED(ClientData), +Tcl_PackageObjCmd( + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - static const char *const pkgOptions[] = { - "files", "forget", "ifneeded", "names", "prefer", - "present", "provide", "require", "unknown", "vcompare", - "versions", "vsatisfies", NULL + static const char *pkgOptions[] = { + "forget", "ifneeded", "names", "prefer", "present", + "provide", "require", "unknown", "vcompare", "versions", + "vsatisfies", NULL }; - enum pkgOptionsEnum { - PKG_FILES, PKG_FORGET, PKG_IFNEEDED, PKG_NAMES, PKG_PREFER, - PKG_PRESENT, PKG_PROVIDE, PKG_REQUIRE, PKG_UNKNOWN, PKG_VCOMPARE, - PKG_VERSIONS, PKG_VSATISFIES + enum pkgOptions { + PKG_FORGET, PKG_IFNEEDED, PKG_NAMES, PKG_PREFER, PKG_PRESENT, + PKG_PROVIDE, PKG_REQUIRE, PKG_UNKNOWN, PKG_VCOMPARE, PKG_VERSIONS, + PKG_VSATISFIES }; Interp *iPtr = (Interp *) interp; - int optionIndex, exact, i, newobjc, satisfies; + int optionIndex, exact, i, satisfies; PkgAvail *availPtr, *prevPtr; Package *pkgPtr; Tcl_HashEntry *hPtr; Tcl_HashSearch search; Tcl_HashTable *tablePtr; const char *version; - const char *argv2, *argv3, *argv4; - char *iva = NULL, *ivb = NULL; - Tcl_Obj *objvListPtr, **newObjvPtr; + char *argv2, *argv3, *argv4, *iva = NULL, *ivb = NULL; if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?"); + Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?"); return TCL_ERROR; } @@ -1099,61 +776,29 @@ TclNRPackageObjCmd( &optionIndex) != TCL_OK) { return TCL_ERROR; } - switch ((enum pkgOptionsEnum) optionIndex) { - case PKG_FILES: { - PkgFiles *pkgFiles; - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "package"); - return TCL_ERROR; - } - pkgFiles = (PkgFiles *) Tcl_GetAssocData(interp, "tclPkgFiles", NULL); - if (pkgFiles) { - Tcl_HashEntry *entry = - Tcl_FindHashEntry(&pkgFiles->table, Tcl_GetString(objv[2])); - if (entry) { - Tcl_SetObjResult(interp, (Tcl_Obj *)Tcl_GetHashValue(entry)); - } - } - break; - } + switch ((enum pkgOptions) optionIndex) { case PKG_FORGET: { - const char *keyString; - PkgFiles *pkgFiles = (PkgFiles *) - Tcl_GetAssocData(interp, "tclPkgFiles", NULL); + char *keyString; for (i = 2; i < objc; i++) { keyString = TclGetString(objv[i]); - if (pkgFiles) { - hPtr = Tcl_FindHashEntry(&pkgFiles->table, keyString); - if (hPtr) { - Tcl_Obj *obj = (Tcl_Obj *)Tcl_GetHashValue(hPtr); - Tcl_DeleteHashEntry(hPtr); - Tcl_DecrRefCount(obj); - } - } - hPtr = Tcl_FindHashEntry(&iPtr->packageTable, keyString); if (hPtr == NULL) { continue; } - pkgPtr = (Package *)Tcl_GetHashValue(hPtr); + pkgPtr = Tcl_GetHashValue(hPtr); Tcl_DeleteHashEntry(hPtr); if (pkgPtr->version != NULL) { - Tcl_DecrRefCount(pkgPtr->version); + ckfree(pkgPtr->version); } while (pkgPtr->availPtr != NULL) { availPtr = pkgPtr->availPtr; pkgPtr->availPtr = availPtr->nextPtr; - Tcl_EventuallyFree(availPtr->version, TCL_DYNAMIC); - Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC); - if (availPtr->pkgIndex) { - Tcl_EventuallyFree(availPtr->pkgIndex, TCL_DYNAMIC); - availPtr->pkgIndex = NULL; - } - ckfree(availPtr); + Tcl_EventuallyFree((ClientData)availPtr->version, TCL_DYNAMIC); + Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC); + ckfree((char *) availPtr); } - ckfree(pkgPtr); + ckfree((char *) pkgPtr); } break; } @@ -1176,11 +821,11 @@ TclNRPackageObjCmd( ckfree(argv3i); return TCL_OK; } - pkgPtr = (Package *)Tcl_GetHashValue(hPtr); + pkgPtr = Tcl_GetHashValue(hPtr); } else { pkgPtr = FindPackage(interp, argv2); } - argv3 = TclGetStringFromObj(objv[3], &length); + argv3 = Tcl_GetStringFromObj(objv[3], &length); for (availPtr = pkgPtr->availPtr, prevPtr = NULL; availPtr != NULL; prevPtr = availPtr, availPtr = availPtr->nextPtr) { @@ -1193,18 +838,13 @@ TclNRPackageObjCmd( res = CompareVersions(avi, argv3i, NULL); ckfree(avi); - if (res == 0) { + if (res == 0){ if (objc == 4) { ckfree(argv3i); - Tcl_SetObjResult(interp, - Tcl_NewStringObj(availPtr->script, -1)); + Tcl_SetResult(interp, availPtr->script, TCL_VOLATILE); return TCL_OK; } - Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC); - if (availPtr->pkgIndex) { - Tcl_EventuallyFree(availPtr->pkgIndex, TCL_DYNAMIC); - availPtr->pkgIndex = NULL; - } + Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC); break; } } @@ -1214,9 +854,8 @@ TclNRPackageObjCmd( return TCL_OK; } if (availPtr == NULL) { - availPtr = (PkgAvail *)ckalloc(sizeof(PkgAvail)); - availPtr->pkgIndex = NULL; - DupBlock(availPtr->version, argv3, length + 1); + availPtr = (PkgAvail *) ckalloc(sizeof(PkgAvail)); + DupBlock(availPtr->version, argv3, (unsigned) length + 1); if (prevPtr == NULL) { availPtr->nextPtr = pkgPtr->availPtr; @@ -1226,37 +865,26 @@ TclNRPackageObjCmd( prevPtr->nextPtr = availPtr; } } - if (iPtr->scriptFile) { - argv4 = TclGetStringFromObj(iPtr->scriptFile, &length); - DupBlock(availPtr->pkgIndex, argv4, length + 1); - } - argv4 = TclGetStringFromObj(objv[4], &length); - DupBlock(availPtr->script, argv4, length + 1); + argv4 = Tcl_GetStringFromObj(objv[4], &length); + DupBlock(availPtr->script, argv4, (unsigned) length + 1); break; } case PKG_NAMES: if (objc != 2) { Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; - } else { - Tcl_Obj *resultObj; - - TclNewObj(resultObj); - tablePtr = &iPtr->packageTable; - for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL; - hPtr = Tcl_NextHashEntry(&search)) { - pkgPtr = (Package *)Tcl_GetHashValue(hPtr); - if ((pkgPtr->version != NULL) || (pkgPtr->availPtr != NULL)) { - Tcl_ListObjAppendElement(NULL,resultObj, Tcl_NewStringObj( - (char *)Tcl_GetHashKey(tablePtr, hPtr), -1)); - } + } + tablePtr = &iPtr->packageTable; + for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL; + hPtr = Tcl_NextHashEntry(&search)) { + pkgPtr = Tcl_GetHashValue(hPtr); + if ((pkgPtr->version != NULL) || (pkgPtr->availPtr != NULL)) { + Tcl_AppendElement(interp, Tcl_GetHashKey(tablePtr, hPtr)); } - Tcl_SetObjResult(interp, resultObj); } break; case PKG_PRESENT: { const char *name; - if (objc < 3) { goto require; } @@ -1274,7 +902,7 @@ TclNRPackageObjCmd( hPtr = Tcl_FindHashEntry(&iPtr->packageTable, name); if (hPtr != NULL) { - pkgPtr = (Package *)Tcl_GetHashValue(hPtr); + pkgPtr = Tcl_GetHashValue(hPtr); if (pkgPtr->version != NULL) { goto require; } @@ -1309,9 +937,9 @@ TclNRPackageObjCmd( if (objc == 3) { hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2); if (hPtr != NULL) { - pkgPtr = (Package *)Tcl_GetHashValue(hPtr); + pkgPtr = Tcl_GetHashValue(hPtr); if (pkgPtr->version != NULL) { - Tcl_SetObjResult(interp, pkgPtr->version); + Tcl_SetResult(interp, pkgPtr->version, TCL_VOLATILE); } } return TCL_OK; @@ -1326,7 +954,7 @@ TclNRPackageObjCmd( if (objc < 3) { requireSyntax: Tcl_WrongNumArgs(interp, 2, objv, - "?-exact? package ?requirement ...?"); + "?-exact? package ?requirement...?"); return TCL_ERROR; } @@ -1335,6 +963,7 @@ TclNRPackageObjCmd( argv2 = TclGetString(objv[2]); if ((argv2[0] == '-') && (strcmp(argv2, "-exact") == 0)) { Tcl_Obj *ov; + int res; if (objc != 5) { goto requireSyntax; @@ -1351,48 +980,20 @@ TclNRPackageObjCmd( */ ov = Tcl_NewStringObj(version, -1); - Tcl_AppendStringsToObj(ov, "-", version, (void *)NULL); + Tcl_AppendStringsToObj(ov, "-", version, NULL); version = NULL; argv3 = TclGetString(objv[3]); - Tcl_IncrRefCount(objv[3]); - - objvListPtr = Tcl_NewListObj(0, NULL); - Tcl_IncrRefCount(objvListPtr); - Tcl_ListObjAppendElement(interp, objvListPtr, ov); - TclListObjGetElements(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 { - Tcl_Obj *const *newobjv = objv + 3; - newobjc = objc - 3; + Tcl_IncrRefCount(ov); + res = Tcl_PkgRequireProc(interp, argv3, 1, &ov, NULL); + TclDecrRefCount(ov); + return res; + } else { 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++) { - /* - * Tcl_Obj structures may have come from another interpreter, - * so duplicate them. - */ - Tcl_ListObjAppendElement(interp, objvListPtr, - Tcl_DuplicateObj(newobjv[i])); - } - TclListObjGetElements(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; + return Tcl_PkgRequireProc(interp, argv2, objc-3, objv+3, NULL); } break; case PKG_UNKNOWN: { @@ -1400,18 +1001,17 @@ TclNRPackageObjCmd( if (objc == 2) { if (iPtr->packageUnknown != NULL) { - Tcl_SetObjResult(interp, - Tcl_NewStringObj(iPtr->packageUnknown, -1)); + Tcl_SetResult(interp, iPtr->packageUnknown, TCL_VOLATILE); } } else if (objc == 3) { if (iPtr->packageUnknown != NULL) { ckfree(iPtr->packageUnknown); } - argv2 = TclGetStringFromObj(objv[2], &length); + argv2 = Tcl_GetStringFromObj(objv[2], &length); if (argv2[0] == 0) { iPtr->packageUnknown = NULL; } else { - DupBlock(iPtr->packageUnknown, argv2, length+1); + DupBlock(iPtr->packageUnknown, argv2, (unsigned) length+1); } } else { Tcl_WrongNumArgs(interp, 2, objv, "?command?"); @@ -1420,7 +1020,7 @@ TclNRPackageObjCmd( break; } case PKG_PREFER: { - static const char *const pkgPreferOptions[] = { + static const char *pkgPreferOptions[] = { "latest", "stable", NULL }; @@ -1481,7 +1081,7 @@ TclNRPackageObjCmd( */ Tcl_SetObjResult(interp, - Tcl_NewWideIntObj(CompareVersions(iva, ivb, NULL))); + Tcl_NewIntObj(CompareVersions(iva, ivb, NULL))); ckfree(iva); ckfree(ivb); break; @@ -1489,28 +1089,23 @@ TclNRPackageObjCmd( if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "package"); return TCL_ERROR; - } else { - Tcl_Obj *resultObj; - - TclNewObj(resultObj); - argv2 = TclGetString(objv[2]); - hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2); - if (hPtr != NULL) { - pkgPtr = (Package *)Tcl_GetHashValue(hPtr); - for (availPtr = pkgPtr->availPtr; availPtr != NULL; - availPtr = availPtr->nextPtr) { - Tcl_ListObjAppendElement(NULL, resultObj, - Tcl_NewStringObj(availPtr->version, -1)); - } + } + argv2 = TclGetString(objv[2]); + hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2); + if (hPtr != NULL) { + pkgPtr = Tcl_GetHashValue(hPtr); + for (availPtr = pkgPtr->availPtr; availPtr != NULL; + availPtr = availPtr->nextPtr) { + Tcl_AppendElement(interp, availPtr->version); } - Tcl_SetObjResult(interp, resultObj); } break; case PKG_VSATISFIES: { char *argv2i = NULL; if (objc < 4) { - Tcl_WrongNumArgs(interp, 2, objv, "version ?requirement ...?"); + Tcl_WrongNumArgs(interp, 2, objv, + "version requirement requirement..."); return TCL_ERROR; } @@ -1533,17 +1128,6 @@ TclNRPackageObjCmd( } return TCL_OK; } - -static int -TclNRPackageObjCmdCleanup( - ClientData data[], - TCL_UNUSED(Tcl_Interp *), - int result) -{ - TclDecrRefCount((Tcl_Obj *) data[0]); - TclDecrRefCount((Tcl_Obj *) data[1]); - return result; -} /* *---------------------------------------------------------------------- @@ -1575,13 +1159,13 @@ FindPackage( hPtr = Tcl_CreateHashEntry(&iPtr->packageTable, name, &isNew); if (isNew) { - pkgPtr = (Package *)ckalloc(sizeof(Package)); + pkgPtr = (Package *) ckalloc(sizeof(Package)); pkgPtr->version = NULL; pkgPtr->availPtr = NULL; pkgPtr->clientData = NULL; Tcl_SetHashValue(hPtr, pkgPtr); } else { - pkgPtr = (Package *)Tcl_GetHashValue(hPtr); + pkgPtr = Tcl_GetHashValue(hPtr); } return pkgPtr; } @@ -1605,7 +1189,7 @@ FindPackage( void TclFreePackageInfo( - Interp *iPtr) /* Interpreter that is being deleted. */ + Interp *iPtr) /* Interpereter that is being deleted. */ { Package *pkgPtr; Tcl_HashSearch search; @@ -1614,22 +1198,18 @@ TclFreePackageInfo( for (hPtr = Tcl_FirstHashEntry(&iPtr->packageTable, &search); hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { - pkgPtr = (Package *)Tcl_GetHashValue(hPtr); + pkgPtr = Tcl_GetHashValue(hPtr); if (pkgPtr->version != NULL) { - Tcl_DecrRefCount(pkgPtr->version); + ckfree(pkgPtr->version); } while (pkgPtr->availPtr != NULL) { availPtr = pkgPtr->availPtr; pkgPtr->availPtr = availPtr->nextPtr; - Tcl_EventuallyFree(availPtr->version, TCL_DYNAMIC); - Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC); - if (availPtr->pkgIndex) { - Tcl_EventuallyFree(availPtr->pkgIndex, TCL_DYNAMIC); - availPtr->pkgIndex = NULL; - } - ckfree(availPtr); + Tcl_EventuallyFree((ClientData)availPtr->version, TCL_DYNAMIC); + Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC); + ckfree((char *) availPtr); } - ckfree(pkgPtr); + ckfree((char *) pkgPtr); } Tcl_DeleteHashTable(&iPtr->packageTable); if (iPtr->packageUnknown != NULL) { @@ -1671,9 +1251,9 @@ CheckVersionAndConvert( int hasunstable = 0; /* * 4* assuming that each char is a separator (a,b become ' -x '). - * 4+ to have space for an additional -2 at the end + * 4+ to have spce for an additional -2 at the end */ - char *ibuf = (char *)ckalloc(4 + 4*strlen(string)); + char *ibuf = ckalloc(4 + 4*strlen(string)); char *ip = ibuf; /* @@ -1696,7 +1276,7 @@ CheckVersionAndConvert( *ip++ = *p; - for (prevChar = *p, p++; (*p != 0) && (*p != '+'); p++) { + for (prevChar = *p, p++; *p != 0; p++) { if (!isdigit(UCHAR(*p)) && /* INTL: digit */ ((*p!='.' && *p!='a' && *p!='b') || ((hasunstable && (*p=='a' || *p=='b')) || @@ -1751,9 +1331,8 @@ CheckVersionAndConvert( error: ckfree(ibuf); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "expected version number but got \"%s\"", string)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "VERSION", (void *)NULL); + Tcl_AppendResult(interp, "expected version number but got \"", string, + "\"", NULL); return TCL_ERROR; } @@ -1782,7 +1361,7 @@ CompareVersions( * of version numbers). */ int *isMajorPtr) /* If non-null, the word pointed to is filled * in with a 0/1 value. 1 means that the - * difference occurred in the first element. */ + * difference occured in the first element. */ { int thisIsMajor, res, flip; char *s1, *e1, *s2, *e2, o1, o2; @@ -2000,10 +1579,10 @@ CheckRequirement( char *dash = NULL, *buf; - dash = strchr(string, '+') ? NULL : (char *)strchr(string, '-'); + dash = strchr(string, '-'); if (dash == NULL) { /* - * '+' found or no dash found: has to be a simple version. + * No dash found, has to be a simple version. */ return CheckVersionAndConvert(interp, string, NULL, NULL); @@ -2014,9 +1593,8 @@ CheckRequirement( * More dashes found after the first. This is wrong. */ - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "expected versionMin-versionMax but got \"%s\"", string)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "VERSIONRANGE", (void *)NULL); + Tcl_AppendResult(interp, "expected versionMin-versionMax but got \"", + string, "\"", NULL); return TCL_ERROR; } @@ -2067,17 +1645,19 @@ AddRequirementsToResult( Tcl_Obj *const reqv[]) /* 0 means to use the latest version * available. */ { - Tcl_Obj *result = Tcl_GetObjResult(interp); - int i, length; + if (reqc > 0) { + int i; - for (i = 0; i < reqc; i++) { - const char *v = TclGetStringFromObj(reqv[i], &length); + for (i = 0; i < reqc; i++) { + 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_AppendPrintfToObj(result, " exactly %s", v+((length+1)/2)); - } else { - Tcl_AppendPrintfToObj(result, " %s", v); + 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); + } } } } @@ -2106,15 +1686,15 @@ AddRequirementsToDString( Tcl_Obj *const reqv[]) /* 0 means to use the latest version * available. */ { - int i; - if (reqc > 0) { + int i; + for (i = 0; i < reqc; i++) { - TclDStringAppendLiteral(dsPtr, " "); - TclDStringAppendObj(dsPtr, reqv[i]); + Tcl_DStringAppend(dsPtr, " ", 1); + Tcl_DStringAppend(dsPtr, TclGetString(reqv[i]), -1); } } else { - TclDStringAppendLiteral(dsPtr, " 0-"); + Tcl_DStringAppend(dsPtr, " 0-", -1); } } @@ -2188,7 +1768,7 @@ RequirementSatisfied( int satisfied, res; char *dash = NULL, *buf, *min, *max; - dash = (char *)strchr(req, '-'); + dash = strchr(req, '-'); if (dash == NULL) { /* * No dash found, is a simple version, fallback to regular check. The @@ -2235,7 +1815,7 @@ RequirementSatisfied( /* * We have both min and max, and generate their internal reps. When - * identical we compare as is, otherwise we pad with 'a0' to over the range + * identical we compare as is, otherwise we pad with 'a0' to ove the range * a bit. */ @@ -2284,7 +1864,7 @@ Tcl_PkgInitStubsCheck( { const char *actualVersion = Tcl_PkgPresent(interp, "Tcl", version, 0); - if ((exact&1) && actualVersion) { + if (exact && actualVersion) { const char *p = version; int count = 0; |