diff options
Diffstat (limited to 'tcl8.6/generic/tclPkg.c')
| -rw-r--r-- | tcl8.6/generic/tclPkg.c | 1923 |
1 files changed, 1923 insertions, 0 deletions
diff --git a/tcl8.6/generic/tclPkg.c b/tcl8.6/generic/tclPkg.c new file mode 100644 index 0000000..f6e8b20 --- /dev/null +++ b/tcl8.6/generic/tclPkg.c @@ -0,0 +1,1923 @@ +/* + * tclPkg.c -- + * + * This file implements package and version control for Tcl via the + * "package" command and a few C APIs. + * + * 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. + * + * TIP #268. + * Heavily rewritten to handle the extend version numbers, and extended + * package requirements. + */ + +#include "tclInt.h" + +/* + * Each invocation of the "package ifneeded" command creates a structure of + * the following type, which is used to load the package into the interpreter + * if it is requested with a "package require" command. + */ + +typedef struct PkgAvail { + char *version; /* Version string; malloc'ed. */ + char *script; /* Script to invoke to provide this version of + * the package. Malloc'ed and protected by + * Tcl_Preserve and Tcl_Release. */ + struct PkgAvail *nextPtr; /* Next in list of available versions of the + * same package. */ +} PkgAvail; + +/* + * 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 + * "packageTable" hash table in the interpreter, keyed by package name such as + * "Tk" (no version number). + */ + +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. */ + PkgAvail *availPtr; /* First in list of all available versions of + * this package. */ + const void *clientData; /* Client data. */ +} Package; + +/* + * Prototypes for functions defined in this file: + */ + +static int CheckVersionAndConvert(Tcl_Interp *interp, + const char *string, char **internal, int *stable); +static int CompareVersions(char *v1i, char *v2i, + int *isMajorPtr); +static int CheckRequirement(Tcl_Interp *interp, + const char *string); +static int CheckAllRequirements(Tcl_Interp *interp, int reqc, + Tcl_Obj *const reqv[]); +static int RequirementSatisfied(char *havei, const char *req); +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 const char * PkgRequireCore(Tcl_Interp *interp, const char *name, + int reqc, Tcl_Obj *const reqv[], + void *clientDataPtr); + +/* + * Helper macros. + */ + +#define DupBlock(v,s,len) \ + ((v) = ckalloc(len), memcpy((v),(s),(len))) +#define DupString(v,s) \ + do { \ + unsigned local__len = (unsigned) (strlen(s) + 1); \ + DupBlock((v),(s),local__len); \ + } while (0) + +/* + *---------------------------------------------------------------------- + * + * Tcl_PkgProvide / Tcl_PkgProvideEx -- + * + * This function is invoked to declare that a particular version of a + * particular package is now present in an interpreter. There must not be + * any other version of this package already provided in the interpreter. + * + * Results: + * Normally returns TCL_OK; if there is already another version of the + * package loaded then TCL_ERROR is returned and an error message is left + * in the interp's result. + * + * Side effects: + * The interpreter remembers that this package is available, so that no + * other version of the package may be provided for the interpreter. + * + *---------------------------------------------------------------------- + */ + +#undef Tcl_PkgProvide +int +Tcl_PkgProvide( + Tcl_Interp *interp, /* Interpreter in which package is now + * available. */ + const char *name, /* Name of package. */ + const char *version) /* Version string for package. */ +{ + return Tcl_PkgProvideEx(interp, name, version, NULL); +} + +int +Tcl_PkgProvideEx( + Tcl_Interp *interp, /* Interpreter in which package is now + * available. */ + const char *name, /* Name of package. */ + const char *version, /* Version string for package. */ + const void *clientData) /* clientdata for this package (normally used + * for C callback function table) */ +{ + Package *pkgPtr; + char *pvi, *vi; + int res; + + pkgPtr = FindPackage(interp, name); + if (pkgPtr->version == NULL) { + DupString(pkgPtr->version, version); + pkgPtr->clientData = clientData; + return TCL_OK; + } + + if (CheckVersionAndConvert(interp, pkgPtr->version, &pvi, + NULL) != TCL_OK) { + return TCL_ERROR; + } else if (CheckVersionAndConvert(interp, version, &vi, NULL) != TCL_OK) { + ckfree(pvi); + return TCL_ERROR; + } + + res = CompareVersions(pvi, vi, NULL); + ckfree(pvi); + ckfree(vi); + + if (res == 0) { + if (clientData != NULL) { + pkgPtr->clientData = clientData; + } + return TCL_OK; + } + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "conflicting versions provided for package \"%s\": %s, then %s", + name, pkgPtr->version, version)); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT", NULL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_PkgRequire / Tcl_PkgRequireEx / Tcl_PkgRequireProc -- + * + * This function is called by code that depends on a particular version + * of a particular package. If the package is not already provided in the + * interpreter, this function invokes a Tcl script to provide it. If the + * package is already provided, this function makes sure that the + * caller's needs don't conflict with the version that is present. + * + * Results: + * If successful, returns the version string for the currently provided + * version of the package, which may be different from the "version" + * argument. If the caller's requirements cannot be met (e.g. the version + * requested conflicts with a currently provided version, or the required + * version cannot be found, or the script to provide the required version + * generates an error), NULL is returned and an error message is left in + * the interp's result. + * + * Side effects: + * The script from some previous "package ifneeded" command may be + * invoked to provide the package. + * + *---------------------------------------------------------------------- + */ + +#undef Tcl_PkgRequire +const char * +Tcl_PkgRequire( + Tcl_Interp *interp, /* Interpreter in which package is now + * available. */ + const char *name, /* Name of desired package. */ + const char *version, /* Version string for desired version; NULL + * means use the latest version available. */ + int exact) /* Non-zero means that only the particular + * version given is acceptable. Zero means use + * the latest compatible version. */ +{ + return Tcl_PkgRequireEx(interp, name, version, exact, NULL); +} + +const char * +Tcl_PkgRequireEx( + Tcl_Interp *interp, /* Interpreter in which package is now + * available. */ + const char *name, /* Name of desired package. */ + const char *version, /* Version string for desired version; NULL + * means use the latest version available. */ + 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 + * package. If it is NULL then the client data + * is not returned. This is unchanged if this + * call fails for any reason. */ +{ + Tcl_Obj *ov; + const char *result = NULL; + + /* + * If an attempt is being made to load this into a standalone executable + * on a platform where backlinking is not supported then this must be a + * shared version of Tcl (Otherwise the load would have failed). Detect + * this situation by checking that this library has been correctly + * initialised. If it has not been then return immediately as nothing will + * work. + */ + + if (tclEmptyStringRep == NULL) { + /* + * OK, so what's going on here? + * + * First, what are we doing? We are performing a check on behalf of + * one particular caller, Tcl_InitStubs(). When a package is stub- + * enabled, it is statically linked to libtclstub.a, which contains a + * copy of Tcl_InitStubs(). When a stub-enabled package is loaded, its + * *_Init() function is supposed to call Tcl_InitStubs() before + * calling any other functions in the Tcl library. The first Tcl + * function called by Tcl_InitStubs() through the stub table is + * Tcl_PkgRequireEx(), so this code right here is the first code that + * is part of the original Tcl library in the executable that gets + * executed on behalf of a newly loaded stub-enabled package. + * + * One easy error for the developer/builder of a stub-enabled package + * to make is to forget to define USE_TCL_STUBS when compiling the + * package. When that happens, the package will contain symbols that + * are references to the Tcl library, rather than function pointers + * referencing the stub table. On platforms that lack backlinking, + * those unresolved references may cause the loading of the package to + * also load a second copy of the Tcl library, leading to all kinds of + * trouble. We would like to catch that error and report a useful + * message back to the user. That's what we're doing. + * + * 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 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, + * yet it thinks it is stub-enabled (it called Tcl_InitStubs()). We + * want to report that the package just loaded is broken, so we want + * to place an error message in the interpreter result and return NULL + * to indicate failure to Tcl_InitStubs() so that it will also fail. + * (Further explanation why we don't want to Tcl_Panic() is welcome. + * 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. 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. + */ + + tclEmptyStringRep = &tclEmptyString; + 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", NULL); + return NULL; + } + + /* + * Translate between old and new API, and defer to the new function. + */ + + if (version == NULL) { + 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) { + Tcl_AppendStringsToObj(ov, "-", version, NULL); + } + Tcl_IncrRefCount(ov); + result = PkgRequireCore(interp, name, 1, &ov, clientDataPtr); + TclDecrRefCount(ov); + } + + return result; +} + +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. */ + void *clientDataPtr) +{ + const char *result = + PkgRequireCore(interp, name, reqc, reqv, clientDataPtr); + + if (result == NULL) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, Tcl_NewStringObj(result, -1)); + return TCL_OK; +} + +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. */ + void *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; + + if (TCL_OK != CheckAllRequirements(interp, reqc, reqv)) { + return NULL; + } + + /* + * It can take up to three passes to find the package: one pass to run the + * "package unknown" script, one to run the "package ifneeded" script for + * a specific version, and a final pass to lookup the package loaded by + * the "package ifneeded" script. + */ + + for (pass=1 ;; pass++) { + pkgPtr = FindPackage(interp, name); + if (pkgPtr->version != NULL) { + break; + } + + /* + * Check whether we're already attempting to load some version of this + * package (circular dependency detection). + */ + + 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", NULL); + return NULL; + } + + /* + * 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 = NULL; + bestStablePtr = NULL; + bestVersion = NULL; + + 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. + */ + + continue; + } + + if (bestPtr != NULL) { + int res = CompareVersions(availVersion, bestVersion, NULL); + + /* + * Note: Use internal reps! + */ + + if (res <= 0) { + /* + * The version of the package sought is not as good as the + * currently selected version. Ignore it. + */ + + ckfree(availVersion); + availVersion = NULL; + continue; + } + } + + /* + * We have found a version which is better than our max. + */ + + if (reqc > 0) { + /* Check satisfaction of requirements. */ + + satisfies = SomeRequirementSatisfied(availVersion, reqc, reqv); + if (!satisfies) { + ckfree(availVersion); + availVersion = NULL; + continue; + } + } + + bestPtr = availPtr; + + if (bestVersion != NULL) { + ckfree(bestVersion); + } + bestVersion = availVersion; + + /* + * If this new best version is stable then it also has to be + * better than the max stable version found so far. + */ + + if (availStable) { + bestStablePtr = availPtr; + } + } + + if (bestVersion != NULL) { + ckfree(bestVersion); + } + + /* + * 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) { + /* + * 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. + */ + + char *versionToProvide = bestPtr->version; + script = bestPtr->script; + + pkgPtr->clientData = versionToProvide; + Tcl_Preserve(script); + Tcl_Preserve(versionToProvide); + code = Tcl_EvalEx(interp, script, -1, TCL_EVAL_GLOBAL); + Tcl_Release(script); + + pkgPtr = FindPackage(interp, name); + if (code == TCL_OK) { + Tcl_ResetResult(interp); + if (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, 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, pkgPtr->version)); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", + "WRONGPROVIDE", NULL); + } + } + } + } else if (code != TCL_ERROR) { + Tcl_Obj *codePtr = Tcl_NewIntObj(code); + + 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; + } + + if (code == TCL_ERROR) { + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (\"package ifneeded %s %s\" script)", + name, versionToProvide)); + } + Tcl_Release(versionToProvide); + + 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. + */ + + if (pkgPtr->version != NULL) { + ckfree(pkgPtr->version); + pkgPtr->version = NULL; + } + pkgPtr->clientData = NULL; + return NULL; + } + + break; + } + + /* + * 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). + */ + + if (pass > 1) { + break; + } + + 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 NULL; + } + Tcl_ResetResult(interp); + } + } + + if (pkgPtr->version == NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't find package %s", name)); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNFOUND", NULL); + AddRequirementsToResult(interp, reqc, reqv); + return NULL; + } + + /* + * At this point we know that the package is present. Make sure that the + * provided version meets the current requirements. + */ + + if (reqc != 0) { + CheckVersionAndConvert(interp, pkgPtr->version, &pkgVersionI, NULL); + satisfies = SomeRequirementSatisfied(pkgVersionI, reqc, reqv); + + ckfree(pkgVersionI); + + if (!satisfies) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "version conflict for package \"%s\": have %s, need", + name, pkgPtr->version)); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT", + NULL); + AddRequirementsToResult(interp, reqc, reqv); + return NULL; + } + } + + if (clientDataPtr) { + const void **ptr = (const void **) clientDataPtr; + + *ptr = pkgPtr->clientData; + } + return pkgPtr->version; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_PkgPresent / Tcl_PkgPresentEx -- + * + * Checks to see whether the specified package is present. If it is not + * then no additional action is taken. + * + * Results: + * If successful, returns the version string for the currently provided + * version of the package, which may be different from the "version" + * argument. If the caller's requirements cannot be met (e.g. the version + * requested conflicts with a currently provided version), NULL is + * returned and an error message is left in interp->result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +#undef Tcl_PkgPresent +const char * +Tcl_PkgPresent( + Tcl_Interp *interp, /* Interpreter in which package is now + * available. */ + const char *name, /* Name of desired package. */ + const char *version, /* Version string for desired version; NULL + * means use the latest version available. */ + int exact) /* Non-zero means that only the particular + * version given is acceptable. Zero means use + * the latest compatible version. */ +{ + return Tcl_PkgPresentEx(interp, name, version, exact, NULL); +} + +const char * +Tcl_PkgPresentEx( + Tcl_Interp *interp, /* Interpreter in which package is now + * available. */ + const char *name, /* Name of desired package. */ + const char *version, /* Version string for desired version; NULL + * means use the latest version available. */ + 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 + * package. If it is NULL then the client data + * is not returned. This is unchanged if this + * call fails for any reason. */ +{ + Interp *iPtr = (Interp *) interp; + Tcl_HashEntry *hPtr; + Package *pkgPtr; + + hPtr = Tcl_FindHashEntry(&iPtr->packageTable, name); + if (hPtr) { + pkgPtr = Tcl_GetHashValue(hPtr); + if (pkgPtr->version != NULL) { + /* + * At this point we know that the package is present. Make sure + * that the provided version meets the current requirement by + * calling Tcl_PkgRequireEx() to check for us. + */ + + const char *foundVersion = Tcl_PkgRequireEx(interp, name, version, + exact, clientDataPtr); + + if (foundVersion == NULL) { + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PACKAGE", name, + NULL); + } + return foundVersion; + } + } + + if (version != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "package %s %s is not present", name, version)); + } else { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "package %s is not present", name)); + } + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PACKAGE", name, NULL); + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_PackageObjCmd -- + * + * This function is invoked to process the "package" Tcl command. See the + * user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +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[] = { + "forget", "ifneeded", "names", "prefer", "present", + "provide", "require", "unknown", "vcompare", "versions", + "vsatisfies", NULL + }; + 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, 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; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?"); + return TCL_ERROR; + } + + if (Tcl_GetIndexFromObj(interp, objv[1], pkgOptions, "option", 0, + &optionIndex) != TCL_OK) { + return TCL_ERROR; + } + switch ((enum pkgOptions) optionIndex) { + case PKG_FORGET: { + const char *keyString; + + for (i = 2; i < objc; i++) { + keyString = TclGetString(objv[i]); + hPtr = Tcl_FindHashEntry(&iPtr->packageTable, keyString); + if (hPtr == NULL) { + continue; + } + pkgPtr = Tcl_GetHashValue(hPtr); + Tcl_DeleteHashEntry(hPtr); + if (pkgPtr->version != NULL) { + 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); + ckfree(availPtr); + } + ckfree(pkgPtr); + } + break; + } + case PKG_IFNEEDED: { + int length, res; + char *argv3i, *avi; + + if ((objc != 4) && (objc != 5)) { + Tcl_WrongNumArgs(interp, 2, objv, "package version ?script?"); + return TCL_ERROR; + } + argv3 = TclGetString(objv[3]); + if (CheckVersionAndConvert(interp, argv3, &argv3i, NULL) != TCL_OK) { + return TCL_ERROR; + } + argv2 = TclGetString(objv[2]); + if (objc == 4) { + hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2); + if (hPtr == NULL) { + ckfree(argv3i); + return TCL_OK; + } + pkgPtr = Tcl_GetHashValue(hPtr); + } else { + pkgPtr = FindPackage(interp, argv2); + } + argv3 = Tcl_GetStringFromObj(objv[3], &length); + + for (availPtr = pkgPtr->availPtr, prevPtr = NULL; availPtr != NULL; + prevPtr = availPtr, availPtr = availPtr->nextPtr) { + if (CheckVersionAndConvert(interp, availPtr->version, &avi, + NULL) != TCL_OK) { + ckfree(argv3i); + return TCL_ERROR; + } + + res = CompareVersions(avi, argv3i, NULL); + ckfree(avi); + + if (res == 0){ + if (objc == 4) { + ckfree(argv3i); + Tcl_SetObjResult(interp, + Tcl_NewStringObj(availPtr->script, -1)); + return TCL_OK; + } + Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC); + break; + } + } + ckfree(argv3i); + + if (objc == 4) { + return TCL_OK; + } + if (availPtr == NULL) { + availPtr = ckalloc(sizeof(PkgAvail)); + DupBlock(availPtr->version, argv3, (unsigned) length + 1); + + if (prevPtr == NULL) { + availPtr->nextPtr = pkgPtr->availPtr; + pkgPtr->availPtr = availPtr; + } else { + availPtr->nextPtr = prevPtr->nextPtr; + prevPtr->nextPtr = availPtr; + } + } + 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; + + resultObj = Tcl_NewObj(); + 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_ListObjAppendElement(NULL,resultObj, Tcl_NewStringObj( + Tcl_GetHashKey(tablePtr, hPtr), -1)); + } + } + Tcl_SetObjResult(interp, resultObj); + } + break; + case PKG_PRESENT: { + const char *name; + + if (objc < 3) { + goto require; + } + argv2 = TclGetString(objv[2]); + if ((argv2[0] == '-') && (strcmp(argv2, "-exact") == 0)) { + if (objc != 5) { + goto requireSyntax; + } + exact = 1; + name = TclGetString(objv[3]); + } else { + exact = 0; + name = argv2; + } + + hPtr = Tcl_FindHashEntry(&iPtr->packageTable, name); + if (hPtr != NULL) { + pkgPtr = Tcl_GetHashValue(hPtr); + if (pkgPtr->version != NULL) { + goto require; + } + } + + version = NULL; + if (exact) { + version = TclGetString(objv[4]); + if (CheckVersionAndConvert(interp, version, NULL, + NULL) != TCL_OK) { + return TCL_ERROR; + } + } else { + if (CheckAllRequirements(interp, objc-3, objv+3) != TCL_OK) { + return TCL_ERROR; + } + if ((objc > 3) && (CheckVersionAndConvert(interp, + TclGetString(objv[3]), NULL, NULL) == TCL_OK)) { + version = TclGetString(objv[3]); + } + } + Tcl_PkgPresentEx(interp, name, version, exact, NULL); + return TCL_ERROR; + break; + } + case PKG_PROVIDE: + if ((objc != 3) && (objc != 4)) { + Tcl_WrongNumArgs(interp, 2, objv, "package ?version?"); + return TCL_ERROR; + } + argv2 = TclGetString(objv[2]); + if (objc == 3) { + hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2); + if (hPtr != NULL) { + pkgPtr = Tcl_GetHashValue(hPtr); + if (pkgPtr->version != NULL) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj(pkgPtr->version, -1)); + } + } + return TCL_OK; + } + argv3 = TclGetString(objv[3]); + if (CheckVersionAndConvert(interp, argv3, NULL, NULL) != TCL_OK) { + return TCL_ERROR; + } + return Tcl_PkgProvideEx(interp, argv2, argv3, NULL); + case PKG_REQUIRE: + require: + if (objc < 3) { + requireSyntax: + Tcl_WrongNumArgs(interp, 2, objv, + "?-exact? package ?requirement ...?"); + return TCL_ERROR; + } + + version = NULL; + + argv2 = TclGetString(objv[2]); + if ((argv2[0] == '-') && (strcmp(argv2, "-exact") == 0)) { + Tcl_Obj *ov; + int res; + + if (objc != 5) { + goto requireSyntax; + } + + version = TclGetString(objv[4]); + if (CheckVersionAndConvert(interp, version, NULL, + NULL) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Create a new-style requirement for the exact version. + */ + + ov = Tcl_NewStringObj(version, -1); + Tcl_AppendStringsToObj(ov, "-", version, NULL); + version = NULL; + argv3 = TclGetString(objv[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; + } + + return Tcl_PkgRequireProc(interp, argv2, objc-3, objv+3, NULL); + } + break; + case PKG_UNKNOWN: { + int length; + + if (objc == 2) { + if (iPtr->packageUnknown != NULL) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj(iPtr->packageUnknown, -1)); + } + } else if (objc == 3) { + if (iPtr->packageUnknown != NULL) { + ckfree(iPtr->packageUnknown); + } + argv2 = Tcl_GetStringFromObj(objv[2], &length); + if (argv2[0] == 0) { + iPtr->packageUnknown = NULL; + } else { + DupBlock(iPtr->packageUnknown, argv2, (unsigned) length+1); + } + } else { + Tcl_WrongNumArgs(interp, 2, objv, "?command?"); + return TCL_ERROR; + } + break; + } + case PKG_PREFER: { + static const char *const pkgPreferOptions[] = { + "latest", "stable", NULL + }; + + /* + * See tclInt.h for the enum, just before Interp. + */ + + if (objc > 3) { + Tcl_WrongNumArgs(interp, 2, objv, "?latest|stable?"); + return TCL_ERROR; + } else if (objc == 3) { + /* + * Seting the value. + */ + + int newPref; + + if (Tcl_GetIndexFromObj(interp, objv[2], pkgPreferOptions, + "preference", 0, &newPref) != TCL_OK) { + return TCL_ERROR; + } + + if (newPref < iPtr->packagePrefer) { + iPtr->packagePrefer = newPref; + } + } + + /* + * Always return current value. + */ + + Tcl_SetObjResult(interp, + Tcl_NewStringObj(pkgPreferOptions[iPtr->packagePrefer], -1)); + break; + } + case PKG_VCOMPARE: + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "version1 version2"); + return TCL_ERROR; + } + argv3 = TclGetString(objv[3]); + argv2 = TclGetString(objv[2]); + if (CheckVersionAndConvert(interp, argv2, &iva, NULL) != TCL_OK || + CheckVersionAndConvert(interp, argv3, &ivb, NULL) != TCL_OK) { + if (iva != NULL) { + ckfree(iva); + } + + /* + * ivb cannot be set in this branch. + */ + + return TCL_ERROR; + } + + /* + * Comparison is done on the internal representation. + */ + + Tcl_SetObjResult(interp, + Tcl_NewIntObj(CompareVersions(iva, ivb, NULL))); + ckfree(iva); + ckfree(ivb); + break; + case PKG_VERSIONS: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "package"); + return TCL_ERROR; + } else { + Tcl_Obj *resultObj = Tcl_NewObj(); + + 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_ListObjAppendElement(NULL, resultObj, + Tcl_NewStringObj(availPtr->version, -1)); + } + } + Tcl_SetObjResult(interp, resultObj); + } + break; + case PKG_VSATISFIES: { + char *argv2i = NULL; + + if (objc < 4) { + Tcl_WrongNumArgs(interp, 2, objv, "version ?requirement ...?"); + return TCL_ERROR; + } + + argv2 = TclGetString(objv[2]); + if (CheckVersionAndConvert(interp, argv2, &argv2i, NULL) != TCL_OK) { + return TCL_ERROR; + } else if (CheckAllRequirements(interp, objc-3, objv+3) != TCL_OK) { + ckfree(argv2i); + return TCL_ERROR; + } + + satisfies = SomeRequirementSatisfied(argv2i, objc-3, objv+3); + ckfree(argv2i); + + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(satisfies)); + break; + } + default: + Tcl_Panic("Tcl_PackageObjCmd: bad option index to pkgOptions"); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * FindPackage -- + * + * This function finds the Package record for a particular package in a + * particular interpreter, creating a record if one doesn't already + * exist. + * + * Results: + * The return value is a pointer to the Package record for the package. + * + * Side effects: + * A new Package record may be created. + * + *---------------------------------------------------------------------- + */ + +static Package * +FindPackage( + Tcl_Interp *interp, /* Interpreter to use for package lookup. */ + const char *name) /* Name of package to fine. */ +{ + Interp *iPtr = (Interp *) interp; + Tcl_HashEntry *hPtr; + int isNew; + Package *pkgPtr; + + hPtr = Tcl_CreateHashEntry(&iPtr->packageTable, name, &isNew); + if (isNew) { + pkgPtr = ckalloc(sizeof(Package)); + pkgPtr->version = NULL; + pkgPtr->availPtr = NULL; + pkgPtr->clientData = NULL; + Tcl_SetHashValue(hPtr, pkgPtr); + } else { + pkgPtr = Tcl_GetHashValue(hPtr); + } + return pkgPtr; +} + +/* + *---------------------------------------------------------------------- + * + * TclFreePackageInfo -- + * + * This function is called during interpreter deletion to free all of the + * package-related information for the interpreter. + * + * Results: + * None. + * + * Side effects: + * Memory is freed. + * + *---------------------------------------------------------------------- + */ + +void +TclFreePackageInfo( + Interp *iPtr) /* Interpereter that is being deleted. */ +{ + Package *pkgPtr; + Tcl_HashSearch search; + Tcl_HashEntry *hPtr; + PkgAvail *availPtr; + + for (hPtr = Tcl_FirstHashEntry(&iPtr->packageTable, &search); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + pkgPtr = Tcl_GetHashValue(hPtr); + if (pkgPtr->version != NULL) { + 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); + ckfree(availPtr); + } + ckfree(pkgPtr); + } + Tcl_DeleteHashTable(&iPtr->packageTable); + if (iPtr->packageUnknown != NULL) { + ckfree(iPtr->packageUnknown); + } +} + +/* + *---------------------------------------------------------------------- + * + * CheckVersionAndConvert -- + * + * This function checks to see whether a version number has valid syntax. + * It also generates a semi-internal representation (string rep of a list + * of numbers). + * + * Results: + * If string is a properly formed version number the TCL_OK is returned. + * Otherwise TCL_ERROR is returned and an error message is left in the + * interp's result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +CheckVersionAndConvert( + Tcl_Interp *interp, /* Used for error reporting. */ + const char *string, /* Supposedly a version number, which is + * groups of decimal digits separated by + * dots. */ + char **internal, /* Internal normalized representation */ + int *stable) /* Flag: Version is (un)stable. */ +{ + const char *p = string; + char prevChar; + int hasunstable = 0; + /* + * 4* assuming that each char is a separator (a,b become ' -x '). + * 4+ to have spce for an additional -2 at the end + */ + char *ibuf = ckalloc(4 + 4*strlen(string)); + char *ip = ibuf; + + /* + * Basic rules + * (1) First character has to be a digit. + * (2) All other characters have to be a digit or '.' + * (3) Two '.'s may not follow each other. + * + * TIP 268, Modified rules + * (1) s.a. + * (2) All other characters have to be a digit, 'a', 'b', or '.' + * (3) s.a. + * (4) Only one of 'a' or 'b' may occur. + * (5) Neither 'a', nor 'b' may occur before or after a '.' + */ + + if (!isdigit(UCHAR(*p))) { /* INTL: digit */ + goto error; + } + + *ip++ = *p; + + for (prevChar = *p, p++; *p != 0; p++) { + if (!isdigit(UCHAR(*p)) && /* INTL: digit */ + ((*p!='.' && *p!='a' && *p!='b') || + ((hasunstable && (*p=='a' || *p=='b')) || + ((prevChar=='a' || prevChar=='b' || prevChar=='.') + && (*p=='.')) || + ((*p=='a' || *p=='b' || *p=='.') && prevChar=='.')))) { + goto error; + } + + if (*p == 'a' || *p == 'b') { + hasunstable = 1; + } + + /* + * Translation to the internal rep. Regular version chars are copied + * as is. The separators are translated to numerics. The new separator + * for all parts is space. + */ + + if (*p == '.') { + *ip++ = ' '; + *ip++ = '0'; + *ip++ = ' '; + } else if (*p == 'a') { + *ip++ = ' '; + *ip++ = '-'; + *ip++ = '2'; + *ip++ = ' '; + } else if (*p == 'b') { + *ip++ = ' '; + *ip++ = '-'; + *ip++ = '1'; + *ip++ = ' '; + } else { + *ip++ = *p; + } + + prevChar = *p; + } + if (prevChar!='.' && prevChar!='a' && prevChar!='b') { + *ip = '\0'; + if (internal != NULL) { + *internal = ibuf; + } else { + ckfree(ibuf); + } + if (stable != NULL) { + *stable = !hasunstable; + } + return TCL_OK; + } + + error: + ckfree(ibuf); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "expected version number but got \"%s\"", string)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "VERSION", NULL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * CompareVersions -- + * + * This function compares two version numbers (in internal rep). + * + * Results: + * The return value is -1 if v1 is less than v2, 0 if the two version + * numbers are the same, and 1 if v1 is greater than v2. If *satPtr is + * non-NULL, the word it points to is filled in with 1 if v2 >= v1 and + * both numbers have the same major number or 0 otherwise. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +CompareVersions( + char *v1, char *v2, /* Versions strings, of form 2.1.3 (any number + * 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 occured in the first element. */ +{ + int thisIsMajor, res, flip; + char *s1, *e1, *s2, *e2, o1, o2; + + /* + * Each iteration of the following loop processes one number from each + * string, terminated by a " " (space). If those numbers don't match then + * the comparison is over; otherwise, we loop back for the next number. + * + * TIP 268. + * This is identical the function 'ComparePkgVersion', but using the new + * space separator as used by the internal rep of version numbers. The + * special separators 'a' and 'b' have already been dealt with in + * 'CheckVersionAndConvert', they were translated into numbers as well. + * This keeps the comparison sane. Otherwise we would have to compare + * numerics, the separators, and also deal with the special case of + * end-of-string compared to separators. The semi-list rep we get here is + * much easier to handle, as it is still regular. + * + * Rewritten to not compute a numeric value for the extracted version + * number, but do string comparison. Skip any leading zeros for that to + * work. This change breaks through the 32bit-limit on version numbers. + */ + + thisIsMajor = 1; + s1 = v1; + s2 = v2; + + while (1) { + /* + * Parse one decimal number from the front of each string. Skip + * leading zeros. Terminate found number for upcoming string-wise + * comparison, if needed. + */ + + while ((*s1 != 0) && (*s1 == '0')) { + s1++; + } + while ((*s2 != 0) && (*s2 == '0')) { + s2++; + } + + /* + * s1, s2 now point to the beginnings of the numbers to compare. Test + * for their signs first, as shortcut to the result (different signs), + * or determines if result has to be flipped (both negative). If there + * is no shortcut we have to insert terminators later to limit the + * strcmp. + */ + + if ((*s1 == '-') && (*s2 != '-')) { + /* s1 < 0, s2 >= 0 => s1 < s2 */ + res = -1; + break; + } + if ((*s1 != '-') && (*s2 == '-')) { + /* s1 >= 0, s2 < 0 => s1 > s2 */ + res = 1; + break; + } + + if ((*s1 == '-') && (*s2 == '-')) { + /* a < b => -a > -b, etc. */ + s1++; + s2++; + flip = 1; + } else { + flip = 0; + } + + /* + * The string comparison is needed, so now we determine where the + * numbers end. + */ + + e1 = s1; + while ((*e1 != 0) && (*e1 != ' ')) { + e1++; + } + e2 = s2; + while ((*e2 != 0) && (*e2 != ' ')) { + e2++; + } + + /* + * s1 .. e1 and s2 .. e2 now bracket the numbers to compare. Insert + * terminators, compare, and restore actual contents. First however + * another shortcut. Compare lengths. Shorter string is smaller + * number! Thus we strcmp only strings of identical length. + */ + + if ((e1-s1) < (e2-s2)) { + res = -1; + } else if ((e2-s2) < (e1-s1)) { + res = 1; + } else { + o1 = *e1; + *e1 = '\0'; + o2 = *e2; + *e2 = '\0'; + + res = strcmp(s1, s2); + res = (res < 0) ? -1 : (res ? 1 : 0); + + *e1 = o1; + *e2 = o2; + } + + /* + * Stop comparing segments when a difference has been found. Here we + * may have to flip the result to account for signs. + */ + + if (res != 0) { + if (flip) { + res = -res; + } + break; + } + + /* + * Go on to the next version number if the current numbers match. + * However stop processing if the end of both numbers has been + * reached. + */ + + s1 = e1; + s2 = e2; + + if (*s1 != 0) { + s1++; + } else if (*s2 == 0) { + /* + * s1, s2 both at the end => identical + */ + + res = 0; + break; + } + if (*s2 != 0) { + s2++; + } + thisIsMajor = 0; + } + + if (isMajorPtr != NULL) { + *isMajorPtr = thisIsMajor; + } + + return res; +} + +/* + *---------------------------------------------------------------------- + * + * CheckAllRequirements -- + * + * This function checks to see whether all requirements in a set have + * valid syntax. + * + * Results: + * TCL_OK is returned if all requirements are valid. Otherwise TCL_ERROR + * is returned and an error message is left in the interp's result. + * + * Side effects: + * May modify the interpreter result. + * + *---------------------------------------------------------------------- + */ + +static int +CheckAllRequirements( + Tcl_Interp *interp, + int reqc, /* Requirements to check. */ + Tcl_Obj *const reqv[]) +{ + int i; + + for (i = 0; i < reqc; i++) { + if ((CheckRequirement(interp, TclGetString(reqv[i])) != TCL_OK)) { + return TCL_ERROR; + } + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * CheckRequirement -- + * + * This function checks to see whether a requirement has valid syntax. + * + * Results: + * If string is a properly formed requirement then TCL_OK is returned. + * Otherwise TCL_ERROR is returned and an error message is left in the + * interp's result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +CheckRequirement( + Tcl_Interp *interp, /* Used for error reporting. */ + const char *string) /* Supposedly a requirement. */ +{ + /* + * Syntax of requirement = version + * = version-version + * = version- + */ + + char *dash = NULL, *buf; + + dash = strchr(string, '-'); + if (dash == NULL) { + /* + * No dash found, has to be a simple version. + */ + + return CheckVersionAndConvert(interp, string, NULL, NULL); + } + + if (strchr(dash+1, '-') != NULL) { + /* + * 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", NULL); + return TCL_ERROR; + } + + /* + * Exactly one dash is present. Copy the string, split at the location of + * dash and check that both parts are versions. Note that the max part can + * be empty. Also note that the string allocated with strdup() must be + * freed with free() and not ckfree(). + */ + + DupString(buf, string); + dash = buf + (dash - string); + *dash = '\0'; /* buf now <=> min part */ + dash++; /* dash now <=> max part */ + + if ((CheckVersionAndConvert(interp, buf, NULL, NULL) != TCL_OK) || + ((*dash != '\0') && + (CheckVersionAndConvert(interp, dash, NULL, NULL) != TCL_OK))) { + ckfree(buf); + return TCL_ERROR; + } + + ckfree(buf); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * AddRequirementsToResult -- + * + * This function accumulates requirements in the interpreter result. + * + * Results: + * None. + * + * Side effects: + * The interpreter result is extended. + * + *---------------------------------------------------------------------- + */ + +static void +AddRequirementsToResult( + Tcl_Interp *interp, + int reqc, /* Requirements constraining the desired + * version. */ + Tcl_Obj *const reqv[]) /* 0 means to use the latest version + * available. */ +{ + Tcl_Obj *result = Tcl_GetObjResult(interp); + int i, length; + + for (i = 0; i < reqc; i++) { + const 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); + } + } +} + +/* + *---------------------------------------------------------------------- + * + * AddRequirementsToDString -- + * + * This function accumulates requirements in a DString. + * + * Results: + * None. + * + * Side effects: + * The DString argument is extended. + * + *---------------------------------------------------------------------- + */ + +static void +AddRequirementsToDString( + Tcl_DString *dsPtr, + int reqc, /* Requirements constraining the desired + * version. */ + Tcl_Obj *const reqv[]) /* 0 means to use the latest version + * available. */ +{ + int i; + + if (reqc > 0) { + for (i = 0; i < reqc; i++) { + TclDStringAppendLiteral(dsPtr, " "); + TclDStringAppendObj(dsPtr, reqv[i]); + } + } else { + TclDStringAppendLiteral(dsPtr, " 0-"); + } +} + +/* + *---------------------------------------------------------------------- + * + * SomeRequirementSatisfied -- + * + * This function checks to see whether a version satisfies at least one + * of a set of requirements. + * + * Results: + * If the requirements are satisfied 1 is returned. Otherwise 0 is + * returned. The function assumes that all pieces have valid syntax. And + * is allowed to make that assumption. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +SomeRequirementSatisfied( + char *availVersionI, /* Candidate version to check against the + * requirements. */ + int reqc, /* Requirements constraining the desired + * version. */ + Tcl_Obj *const reqv[]) /* 0 means to use the latest version + * available. */ +{ + int i; + + for (i = 0; i < reqc; i++) { + if (RequirementSatisfied(availVersionI, TclGetString(reqv[i]))) { + return 1; + } + } + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * RequirementSatisfied -- + * + * This function checks to see whether a version satisfies a requirement. + * + * Results: + * If the requirement is satisfied 1 is returned. Otherwise 0 is + * returned. The function assumes that all pieces have valid syntax, and + * is allowed to make that assumption. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +RequirementSatisfied( + char *havei, /* Version string, of candidate package we + * have. */ + const char *req) /* Requirement string the candidate has to + * satisfy. */ +{ + /* + * The have candidate is already in internal rep. + */ + + int satisfied, res; + char *dash = NULL, *buf, *min, *max; + + dash = strchr(req, '-'); + if (dash == NULL) { + /* + * No dash found, is a simple version, fallback to regular check. The + * 'CheckVersionAndConvert' cannot fail. We pad the requirement with + * 'a0', i.e '-2' before doing the comparison to properly accept + * unstables as well. + */ + + char *reqi = NULL; + int thisIsMajor; + + CheckVersionAndConvert(NULL, req, &reqi, NULL); + strcat(reqi, " -2"); + res = CompareVersions(havei, reqi, &thisIsMajor); + satisfied = (res == 0) || ((res == 1) && !thisIsMajor); + ckfree(reqi); + return satisfied; + } + + /* + * Exactly one dash is present (Assumption of valid syntax). Copy the req, + * split at the location of dash and check that both parts are versions. + * Note that the max part can be empty. + */ + + DupString(buf, req); + dash = buf + (dash - req); + *dash = '\0'; /* buf now <=> min part */ + dash++; /* dash now <=> max part */ + + if (*dash == '\0') { + /* + * We have a min, but no max. For the comparison we generate the + * internal rep, padded with 'a0' i.e. '-2'. + */ + + CheckVersionAndConvert(NULL, buf, &min, NULL); + strcat(min, " -2"); + satisfied = (CompareVersions(havei, min, NULL) >= 0); + ckfree(min); + ckfree(buf); + return satisfied; + } + + /* + * We have both min and max, and generate their internal reps. When + * identical we compare as is, otherwise we pad with 'a0' to ove the range + * a bit. + */ + + CheckVersionAndConvert(NULL, buf, &min, NULL); + CheckVersionAndConvert(NULL, dash, &max, NULL); + + if (CompareVersions(min, max, NULL) == 0) { + satisfied = (CompareVersions(min, havei, NULL) == 0); + } else { + strcat(min, " -2"); + strcat(max, " -2"); + satisfied = ((CompareVersions(min, havei, NULL) <= 0) && + (CompareVersions(havei, max, NULL) < 0)); + } + + ckfree(min); + ckfree(max); + ckfree(buf); + return satisfied; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_PkgInitStubsCheck -- + * + * This is a replacement routine for Tcl_InitStubs() that is called + * from code where -DUSE_TCL_STUBS has not been enabled. + * + * Results: + * Returns the version of a conforming stubs table, or NULL, if + * the table version doesn't satisfy the requested requirements, + * according to historical practice. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +const char * +Tcl_PkgInitStubsCheck( + Tcl_Interp *interp, + const char * version, + int exact) +{ + const char *actualVersion = Tcl_PkgPresent(interp, "Tcl", version, 0); + + if (exact && actualVersion) { + const char *p = version; + int count = 0; + + while (*p) { + count += !isdigit(UCHAR(*p++)); + } + if (count == 1) { + if (0 != strncmp(version, actualVersion, strlen(version))) { + /* Construct error message */ + Tcl_PkgPresent(interp, "Tcl", version, 1); + return NULL; + } + } else { + return Tcl_PkgPresent(interp, "Tcl", version, 1); + } + } + return actualVersion; +} +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ |