diff options
Diffstat (limited to 'tcl8.6/generic/tclPkg.c')
| -rw-r--r-- | tcl8.6/generic/tclPkg.c | 1923 |
1 files changed, 0 insertions, 1923 deletions
diff --git a/tcl8.6/generic/tclPkg.c b/tcl8.6/generic/tclPkg.c deleted file mode 100644 index f6e8b20..0000000 --- a/tcl8.6/generic/tclPkg.c +++ /dev/null @@ -1,1923 +0,0 @@ -/* - * 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: - */ |