sl@0: /* sl@0: * tclPkg.c -- sl@0: * sl@0: * This file implements package and version control for Tcl via sl@0: * the "package" command and a few C APIs. sl@0: * sl@0: * Copyright (c) 1996 Sun Microsystems, Inc. sl@0: * Copyright (c) 2006 Andreas Kupries sl@0: * Portions Copyright (c) 2007-2008 Nokia Corporation and/or its subsidiaries. All rights reserved. sl@0: * sl@0: * See the file "license.terms" for information on usage and redistribution sl@0: * of this file, and for a DISCLAIMER OF ALL WARRANTIES. sl@0: * sl@0: * RCS: @(#) $Id: tclPkg.c,v 1.9.2.9 2007/03/19 17:06:26 dgp Exp $ sl@0: * sl@0: * TIP #268. sl@0: * Heavily rewritten to handle the extend version numbers, and extended sl@0: * package requirements. sl@0: */ sl@0: sl@0: #include "tclInt.h" sl@0: sl@0: /* sl@0: * Each invocation of the "package ifneeded" command creates a structure sl@0: * of the following type, which is used to load the package into the sl@0: * interpreter if it is requested with a "package require" command. sl@0: */ sl@0: sl@0: typedef struct PkgAvail { sl@0: char *version; /* Version string; malloc'ed. */ sl@0: char *script; /* Script to invoke to provide this version sl@0: * of the package. Malloc'ed and protected sl@0: * by Tcl_Preserve and Tcl_Release. */ sl@0: struct PkgAvail *nextPtr; /* Next in list of available versions of sl@0: * the same package. */ sl@0: } PkgAvail; sl@0: sl@0: /* sl@0: * For each package that is known in any way to an interpreter, there sl@0: * is one record of the following type. These records are stored in sl@0: * the "packageTable" hash table in the interpreter, keyed by sl@0: * package name such as "Tk" (no version number). sl@0: */ sl@0: sl@0: typedef struct Package { sl@0: char *version; /* Version that has been supplied in this sl@0: * interpreter via "package provide" sl@0: * (malloc'ed). NULL means the package doesn't sl@0: * exist in this interpreter yet. */ sl@0: PkgAvail *availPtr; /* First in list of all available versions sl@0: * of this package. */ sl@0: ClientData clientData; /* Client data. */ sl@0: } Package; sl@0: sl@0: /* sl@0: * Prototypes for procedures defined in this file: sl@0: */ sl@0: sl@0: #ifndef TCL_TIP268 sl@0: static int CheckVersion _ANSI_ARGS_((Tcl_Interp *interp, sl@0: CONST char *string)); sl@0: static int ComparePkgVersions _ANSI_ARGS_((CONST char *v1, sl@0: CONST char *v2, sl@0: int *satPtr)); sl@0: static Package * FindPackage _ANSI_ARGS_((Tcl_Interp *interp, sl@0: CONST char *name)); sl@0: #else sl@0: static int CheckVersionAndConvert(Tcl_Interp *interp, CONST char *string, sl@0: char** internal, int* stable); sl@0: static int CompareVersions(CONST char *v1i, CONST char *v2i, sl@0: int *isMajorPtr); sl@0: static int CheckRequirement(Tcl_Interp *interp, CONST char *string); sl@0: static int CheckAllRequirements(Tcl_Interp* interp, sl@0: int reqc, Tcl_Obj *CONST reqv[]); sl@0: static int RequirementSatisfied(CONST char *havei, CONST char *req); sl@0: static int AllRequirementsSatisfied(CONST char *havei, sl@0: int reqc, Tcl_Obj *CONST reqv[]); sl@0: static void AddRequirementsToResult(Tcl_Interp* interp, sl@0: int reqc, Tcl_Obj *CONST reqv[]); sl@0: static void AddRequirementsToDString(Tcl_DString* dstring, sl@0: int reqc, Tcl_Obj *CONST reqv[]); sl@0: static Package * FindPackage(Tcl_Interp *interp, CONST char *name); sl@0: static Tcl_Obj* ExactRequirement(CONST char* version); sl@0: static void VersionCleanupProc(ClientData clientData, sl@0: Tcl_Interp *interp); sl@0: #endif sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_PkgProvide / Tcl_PkgProvideEx -- sl@0: * sl@0: * This procedure is invoked to declare that a particular version sl@0: * of a particular package is now present in an interpreter. There sl@0: * must not be any other version of this package already sl@0: * provided in the interpreter. sl@0: * sl@0: * Results: sl@0: * Normally returns TCL_OK; if there is already another version sl@0: * of the package loaded then TCL_ERROR is returned and an error sl@0: * message is left in the interp's result. sl@0: * sl@0: * Side effects: sl@0: * The interpreter remembers that this package is available, sl@0: * so that no other version of the package may be provided for sl@0: * the interpreter. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C int sl@0: Tcl_PkgProvide(interp, name, version) sl@0: Tcl_Interp *interp; /* Interpreter in which package is now sl@0: * available. */ sl@0: CONST char *name; /* Name of package. */ sl@0: CONST char *version; /* Version string for package. */ sl@0: { sl@0: return Tcl_PkgProvideEx(interp, name, version, (ClientData) NULL); sl@0: } sl@0: sl@0: EXPORT_C int sl@0: Tcl_PkgProvideEx(interp, name, version, clientData) sl@0: Tcl_Interp *interp; /* Interpreter in which package is now sl@0: * available. */ sl@0: CONST char *name; /* Name of package. */ sl@0: CONST char *version; /* Version string for package. */ sl@0: ClientData clientData; /* clientdata for this package (normally sl@0: * used for C callback function table) */ sl@0: { sl@0: Package *pkgPtr; sl@0: #ifdef TCL_TIP268 sl@0: char* pvi; sl@0: char* vi; sl@0: int res; sl@0: #endif sl@0: sl@0: pkgPtr = FindPackage(interp, name); sl@0: if (pkgPtr->version == NULL) { sl@0: pkgPtr->version = ckalloc((unsigned) (strlen(version) + 1)); sl@0: strcpy(pkgPtr->version, version); sl@0: pkgPtr->clientData = clientData; sl@0: return TCL_OK; sl@0: } sl@0: #ifndef TCL_TIP268 sl@0: if (ComparePkgVersions(pkgPtr->version, version, (int *) NULL) == 0) { sl@0: #else sl@0: if (CheckVersionAndConvert (interp, pkgPtr->version, &pvi, NULL) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } else if (CheckVersionAndConvert (interp, version, &vi, NULL) != TCL_OK) { sl@0: Tcl_Free (pvi); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: res = CompareVersions(pvi, vi, NULL); sl@0: Tcl_Free (pvi); sl@0: Tcl_Free (vi); sl@0: sl@0: if (res == 0) { sl@0: #endif sl@0: if (clientData != NULL) { sl@0: pkgPtr->clientData = clientData; sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: Tcl_AppendResult(interp, "conflicting versions provided for package \"", sl@0: name, "\": ", pkgPtr->version, ", then ", version, (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_PkgRequire / Tcl_PkgRequireEx / Tcl_PkgRequireProc -- sl@0: * sl@0: * This procedure is called by code that depends on a particular sl@0: * version of a particular package. If the package is not already sl@0: * provided in the interpreter, this procedure invokes a Tcl script sl@0: * to provide it. If the package is already provided, this sl@0: * procedure makes sure that the caller's needs don't conflict with sl@0: * the version that is present. sl@0: * sl@0: * Results: sl@0: * If successful, returns the version string for the currently sl@0: * provided version of the package, which may be different from sl@0: * the "version" argument. If the caller's requirements sl@0: * cannot be met (e.g. the version requested conflicts with sl@0: * a currently provided version, or the required version cannot sl@0: * be found, or the script to provide the required version sl@0: * generates an error), NULL is returned and an error sl@0: * message is left in the interp's result. sl@0: * sl@0: * Side effects: sl@0: * The script from some previous "package ifneeded" command may sl@0: * be invoked to provide the package. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: #ifndef TCL_TIP268 sl@0: /* sl@0: * Empty definition for Stubs when TIP 268 is not activated. sl@0: */ sl@0: EXPORT_C int sl@0: Tcl_PkgRequireProc(interp,name,reqc,reqv,clientDataPtr) sl@0: Tcl_Interp *interp; /* Interpreter in which package is now sl@0: * available. */ sl@0: CONST char *name; /* Name of desired package. */ sl@0: int reqc; /* Requirements constraining the desired version. */ sl@0: Tcl_Obj *CONST reqv[]; /* 0 means to use the latest version available. */ sl@0: ClientData *clientDataPtr; sl@0: { sl@0: return TCL_ERROR; sl@0: } sl@0: #endif sl@0: sl@0: EXPORT_C CONST char * sl@0: Tcl_PkgRequire(interp, name, version, exact) sl@0: Tcl_Interp *interp; /* Interpreter in which package is now sl@0: * available. */ sl@0: CONST char *name; /* Name of desired package. */ sl@0: CONST char *version; /* Version string for desired version; NULL sl@0: * means use the latest version available. */ sl@0: int exact; /* Non-zero means that only the particular sl@0: * version given is acceptable. Zero means use sl@0: * the latest compatible version. */ sl@0: { sl@0: return Tcl_PkgRequireEx(interp, name, version, exact, (ClientData *) NULL); sl@0: } sl@0: sl@0: EXPORT_C CONST char * sl@0: Tcl_PkgRequireEx(interp, name, version, exact, clientDataPtr) sl@0: Tcl_Interp *interp; /* Interpreter in which package is now sl@0: * available. */ sl@0: CONST char *name; /* Name of desired package. */ sl@0: CONST char *version; /* Version string for desired version; sl@0: * NULL means use the latest version sl@0: * available. */ sl@0: int exact; /* Non-zero means that only the particular sl@0: * version given is acceptable. Zero means sl@0: * use the latest compatible version. */ sl@0: ClientData *clientDataPtr; /* Used to return the client data for this sl@0: * package. If it is NULL then the client sl@0: * data is not returned. This is unchanged sl@0: * if this call fails for any reason. */ sl@0: { sl@0: #ifndef TCL_TIP268 sl@0: Package *pkgPtr; sl@0: PkgAvail *availPtr, *bestPtr; sl@0: char *script; sl@0: int code, satisfies, result, pass; sl@0: Tcl_DString command; sl@0: #else sl@0: Tcl_Obj *ov; sl@0: int res; sl@0: #endif sl@0: sl@0: /* sl@0: * If an attempt is being made to load this into a standalone executable sl@0: * on a platform where backlinking is not supported then this must be sl@0: * a shared version of Tcl (Otherwise the load would have failed). sl@0: * Detect this situation by checking that this library has been correctly sl@0: * initialised. If it has not been then return immediately as nothing will sl@0: * work. sl@0: */ sl@0: sl@0: if (tclEmptyStringRep == NULL) { sl@0: sl@0: /* sl@0: * OK, so what's going on here? sl@0: * sl@0: * First, what are we doing? We are performing a check on behalf of sl@0: * one particular caller, Tcl_InitStubs(). When a package is sl@0: * stub-enabled, it is statically linked to libtclstub.a, which sl@0: * contains a copy of Tcl_InitStubs(). When a stub-enabled package sl@0: * is loaded, its *_Init() function is supposed to call sl@0: * Tcl_InitStubs() before calling any other functions in the Tcl sl@0: * library. The first Tcl function called by Tcl_InitStubs() through sl@0: * the stub table is Tcl_PkgRequireEx(), so this code right here is sl@0: * the first code that is part of the original Tcl library in the sl@0: * executable that gets executed on behalf of a newly loaded sl@0: * stub-enabled package. sl@0: * sl@0: * One easy error for the developer/builder of a stub-enabled package sl@0: * to make is to forget to define USE_TCL_STUBS when compiling the sl@0: * package. When that happens, the package will contain symbols sl@0: * that are references to the Tcl library, rather than function sl@0: * pointers referencing the stub table. On platforms that lack sl@0: * backlinking, those unresolved references may cause the loading sl@0: * of the package to also load a second copy of the Tcl library, sl@0: * leading to all kinds of trouble. We would like to catch that sl@0: * error and report a useful message back to the user. That's sl@0: * what we're doing. sl@0: * sl@0: * Second, how does this work? If we reach this point, then the sl@0: * global variable tclEmptyStringRep has the value NULL. Compare sl@0: * that with the definition of tclEmptyStringRep near the top of sl@0: * the file generic/tclObj.c. It clearly should not have the value sl@0: * NULL; it should point to the char tclEmptyString. If we see it sl@0: * having the value NULL, then somehow we are seeing a Tcl library sl@0: * that isn't completely initialized, and that's an indicator for the sl@0: * error condition described above. (Further explanation is welcome.) sl@0: * sl@0: * Third, so what do we do about it? This situation indicates sl@0: * the package we just loaded wasn't properly compiled to be sl@0: * stub-enabled, yet it thinks it is stub-enabled (it called sl@0: * Tcl_InitStubs()). We want to report that the package just sl@0: * loaded is broken, so we want to place an error message in sl@0: * the interpreter result and return NULL to indicate failure sl@0: * to Tcl_InitStubs() so that it will also fail. (Further sl@0: * explanation why we don't want to Tcl_Panic() is welcome. sl@0: * After all, two Tcl libraries can't be a good thing!) sl@0: * sl@0: * Trouble is that's going to be tricky. We're now using a Tcl sl@0: * library that's not fully initialized. In particular, it sl@0: * doesn't have a proper value for tclEmptyStringRep. The sl@0: * Tcl_Obj system heavily depends on the value of tclEmptyStringRep sl@0: * and all of Tcl depends (increasingly) on the Tcl_Obj system, we sl@0: * need to correct that flaw before making the calls to set the sl@0: * interpreter result to the error message. That's the only flaw sl@0: * corrected; other problems with initialization of the Tcl library sl@0: * are not remedied, so be very careful about adding any other calls sl@0: * here without checking how they behave when initialization is sl@0: * incomplete. sl@0: */ sl@0: sl@0: tclEmptyStringRep = &tclEmptyString; sl@0: Tcl_AppendResult(interp, "Cannot load package \"", name, sl@0: "\" in standalone executable: This package is not ", sl@0: "compiled with stub support", NULL); sl@0: return NULL; sl@0: } sl@0: sl@0: #ifdef TCL_TIP268 sl@0: /* Translate between old and new API, and defer to the new function. */ sl@0: sl@0: if (version == NULL) { sl@0: res = Tcl_PkgRequireProc(interp, name, 0, NULL, clientDataPtr); sl@0: } else { sl@0: if (exact) { sl@0: ov = ExactRequirement (version); sl@0: } else { sl@0: ov = Tcl_NewStringObj (version,-1); sl@0: } sl@0: sl@0: Tcl_IncrRefCount (ov); sl@0: res = Tcl_PkgRequireProc(interp, name, 1, &ov, clientDataPtr); sl@0: Tcl_DecrRefCount (ov); sl@0: } sl@0: sl@0: if (res != TCL_OK) { sl@0: return NULL; sl@0: } sl@0: sl@0: /* This function returns the version string explictly, and leaves the sl@0: * interpreter result empty. However "Tcl_PkgRequireProc" above returned sl@0: * the version through the interpreter result. Simply resetting the result sl@0: * now potentially deletes the string (obj), and the pointer to its string sl@0: * rep we have, as our result, may be dangling due to this. Our solution sl@0: * is to remember the object in interp associated data, with a proper sl@0: * reference count, and then reset the result. Now pointers will not sl@0: * dangle. It will be a leak however if nothing is done. So the next time sl@0: * we come through here we delete the object remembered by this call, as sl@0: * we can then be sure that there is no pointer to its string around sl@0: * anymore. Beyond that we have a deletion function which cleans up the last sl@0: * remembered object which was not cleaned up directly, here. sl@0: */ sl@0: sl@0: ov = (Tcl_Obj*) Tcl_GetAssocData (interp, "tcl/Tcl_PkgRequireEx", NULL); sl@0: if (ov != NULL) { sl@0: Tcl_DecrRefCount (ov); sl@0: } sl@0: sl@0: ov = Tcl_GetObjResult (interp); sl@0: Tcl_IncrRefCount (ov); sl@0: Tcl_SetAssocData(interp, "tcl/Tcl_PkgRequireEx", VersionCleanupProc, sl@0: (ClientData) ov); sl@0: Tcl_ResetResult (interp); sl@0: sl@0: return Tcl_GetString (ov); sl@0: } sl@0: sl@0: EXPORT_C int sl@0: Tcl_PkgRequireProc(interp,name,reqc,reqv,clientDataPtr) sl@0: Tcl_Interp *interp; /* Interpreter in which package is now sl@0: * available. */ sl@0: CONST char *name; /* Name of desired package. */ sl@0: int reqc; /* Requirements constraining the desired version. */ sl@0: Tcl_Obj *CONST reqv[]; /* 0 means to use the latest version available. */ sl@0: ClientData *clientDataPtr; sl@0: { sl@0: Interp *iPtr = (Interp *) interp; sl@0: Package *pkgPtr; sl@0: PkgAvail *availPtr, *bestPtr, *bestStablePtr; sl@0: char *availVersion, *bestVersion; /* Internal rep. of versions */ sl@0: int availStable; sl@0: char *script; sl@0: int code, satisfies, pass; sl@0: Tcl_DString command; sl@0: char* pkgVersionI; sl@0: sl@0: #endif sl@0: /* sl@0: * It can take up to three passes to find the package: one pass to run the sl@0: * "package unknown" script, one to run the "package ifneeded" script for sl@0: * a specific version, and a final pass to lookup the package loaded by sl@0: * the "package ifneeded" script. sl@0: */ sl@0: sl@0: for (pass = 1; ; pass++) { sl@0: pkgPtr = FindPackage(interp, name); sl@0: if (pkgPtr->version != NULL) { sl@0: break; sl@0: } sl@0: sl@0: /* sl@0: * Check whether we're already attempting to load some version sl@0: * of this package (circular dependency detection). sl@0: */ sl@0: sl@0: if (pkgPtr->clientData != NULL) { sl@0: Tcl_AppendResult(interp, "circular package dependency: ", sl@0: "attempt to provide ", name, " ", sl@0: (char *)(pkgPtr->clientData), " requires ", name, NULL); sl@0: #ifndef TCL_TIP268 sl@0: if (version != NULL) { sl@0: Tcl_AppendResult(interp, " ", version, NULL); sl@0: } sl@0: return NULL; sl@0: #else sl@0: AddRequirementsToResult (interp, reqc, reqv); sl@0: return TCL_ERROR; sl@0: #endif sl@0: } sl@0: sl@0: /* sl@0: * The package isn't yet present. Search the list of available sl@0: * versions and invoke the script for the best available version. sl@0: * sl@0: * For TIP 268 we are actually locating the best, and the best stable sl@0: * version. One of them is then chosen based on the selection mode. sl@0: */ sl@0: #ifndef TCL_TIP268 sl@0: bestPtr = NULL; sl@0: for (availPtr = pkgPtr->availPtr; availPtr != NULL; sl@0: availPtr = availPtr->nextPtr) { sl@0: if ((bestPtr != NULL) && (ComparePkgVersions(availPtr->version, sl@0: bestPtr->version, (int *) NULL) <= 0)) { sl@0: #else sl@0: bestPtr = NULL; sl@0: bestStablePtr = NULL; sl@0: bestVersion = NULL; sl@0: sl@0: for (availPtr = pkgPtr->availPtr; sl@0: availPtr != NULL; sl@0: availPtr = availPtr->nextPtr) { sl@0: if (CheckVersionAndConvert (interp, availPtr->version, sl@0: &availVersion, &availStable) != TCL_OK) { sl@0: /* The provided version number is has invalid syntax. This sl@0: * should not happen. This should have been caught by the sl@0: * 'package ifneeded' registering the package. sl@0: */ sl@0: #endif sl@0: continue; sl@0: } sl@0: #ifndef TCL_TIP268 sl@0: if (version != NULL) { sl@0: result = ComparePkgVersions(availPtr->version, version, sl@0: &satisfies); sl@0: if ((result != 0) && exact) { sl@0: #else sl@0: if (bestPtr != NULL) { sl@0: int res = CompareVersions (availVersion, bestVersion, NULL); sl@0: /* Note: Use internal reps! */ sl@0: if (res <= 0) { sl@0: /* The version of the package sought is not as good as the sl@0: * currently selected version. Ignore it. */ sl@0: Tcl_Free (availVersion); sl@0: availVersion = NULL; sl@0: #endif sl@0: continue; sl@0: } sl@0: #ifdef TCL_TIP268 sl@0: } sl@0: sl@0: /* We have found a version which is better than our max. */ sl@0: sl@0: if (reqc > 0) { sl@0: /* Check satisfaction of requirements */ sl@0: satisfies = AllRequirementsSatisfied (availVersion, reqc, reqv); sl@0: #endif sl@0: if (!satisfies) { sl@0: #ifdef TCL_TIP268 sl@0: Tcl_Free (availVersion); sl@0: availVersion = NULL; sl@0: #endif sl@0: continue; sl@0: } sl@0: } sl@0: bestPtr = availPtr; sl@0: #ifdef TCL_TIP268 sl@0: if (bestVersion != NULL) Tcl_Free (bestVersion); sl@0: bestVersion = availVersion; sl@0: availVersion = NULL; sl@0: sl@0: /* If this new best version is stable then it also has to be sl@0: * better than the max stable version found so far. sl@0: */ sl@0: sl@0: if (availStable) { sl@0: bestStablePtr = availPtr; sl@0: } sl@0: } sl@0: sl@0: if (bestVersion != NULL) { sl@0: Tcl_Free (bestVersion); sl@0: } sl@0: sl@0: /* Now choose a version among the two best. For 'latest' we simply sl@0: * take (actually keep) the best. For 'stable' we take the best sl@0: * stable, if there is any, or the best if there is nothing stable. sl@0: */ sl@0: sl@0: if ((iPtr->packagePrefer == PKG_PREFER_STABLE) && (bestStablePtr != NULL)) { sl@0: bestPtr = bestStablePtr; sl@0: #endif sl@0: } sl@0: if (bestPtr != NULL) { sl@0: /* sl@0: * We found an ifneeded script for the package. Be careful while sl@0: * executing it: this could cause reentrancy, so (a) protect the sl@0: * script itself from deletion and (b) don't assume that bestPtr sl@0: * will still exist when the script completes. sl@0: */ sl@0: sl@0: CONST char *versionToProvide = bestPtr->version; sl@0: script = bestPtr->script; sl@0: pkgPtr->clientData = (ClientData) versionToProvide; sl@0: Tcl_Preserve((ClientData) script); sl@0: Tcl_Preserve((ClientData) versionToProvide); sl@0: code = Tcl_EvalEx(interp, script, -1, TCL_EVAL_GLOBAL); sl@0: Tcl_Release((ClientData) script); sl@0: pkgPtr = FindPackage(interp, name); sl@0: if (code == TCL_OK) { sl@0: #ifdef TCL_TIP268 sl@0: Tcl_ResetResult(interp); sl@0: #endif sl@0: if (pkgPtr->version == NULL) { sl@0: #ifndef TCL_TIP268 sl@0: Tcl_ResetResult(interp); sl@0: #endif sl@0: code = TCL_ERROR; sl@0: Tcl_AppendResult(interp, "attempt to provide package ", sl@0: name, " ", versionToProvide, sl@0: " failed: no version of package ", name, sl@0: " provided", NULL); sl@0: #ifndef TCL_TIP268 sl@0: } else if (0 != ComparePkgVersions( sl@0: pkgPtr->version, versionToProvide, NULL)) { sl@0: /* At this point, it is clear that a prior sl@0: * [package ifneeded] command lied to us. It said sl@0: * that to get a particular version of a particular sl@0: * package, we needed to evaluate a particular script. sl@0: * However, we evaluated that script and got a different sl@0: * version than we were told. This is an error, and we sl@0: * ought to report it. sl@0: * sl@0: * However, we've been letting this type of error slide sl@0: * for a long time, and as a result, a lot of packages sl@0: * suffer from them. sl@0: * sl@0: * It's a bit too harsh to make a large number of sl@0: * existing packages start failing by releasing a sl@0: * new patch release, so we forgive this type of error sl@0: * for the rest of the Tcl 8.4 series. sl@0: * sl@0: * We considered reporting a warning, but in practice sl@0: * even that appears too harsh a change for a patch release. sl@0: * sl@0: * We limit the error reporting to only sl@0: * the situation where a broken ifneeded script leads sl@0: * to a failure to satisfy the requirement. sl@0: */ sl@0: if (version) { sl@0: result = ComparePkgVersions( sl@0: pkgPtr->version, version, &satisfies); sl@0: if (result && (exact || !satisfies)) { sl@0: Tcl_ResetResult(interp); sl@0: code = TCL_ERROR; sl@0: Tcl_AppendResult(interp, sl@0: "attempt to provide package ", name, " ", sl@0: versionToProvide, " failed: package ", sl@0: name, " ", pkgPtr->version, sl@0: " provided instead", NULL); sl@0: #else sl@0: } else { sl@0: char* pvi; sl@0: char* vi; sl@0: int res; sl@0: sl@0: if (CheckVersionAndConvert (interp, pkgPtr->version, &pvi, NULL) != TCL_OK) { sl@0: code = TCL_ERROR; sl@0: } else if (CheckVersionAndConvert (interp, versionToProvide, &vi, NULL) != TCL_OK) { sl@0: Tcl_Free (pvi); sl@0: code = TCL_ERROR; sl@0: } else { sl@0: res = CompareVersions(pvi, vi, NULL); sl@0: Tcl_Free (vi); sl@0: sl@0: if (res != 0) { sl@0: /* At this point, it is clear that a prior sl@0: * [package ifneeded] command lied to us. It said sl@0: * that to get a particular version of a particular sl@0: * package, we needed to evaluate a particular script. sl@0: * However, we evaluated that script and got a different sl@0: * version than we were told. This is an error, and we sl@0: * ought to report it. sl@0: * sl@0: * However, we've been letting this type of error slide sl@0: * for a long time, and as a result, a lot of packages sl@0: * suffer from them. sl@0: * sl@0: * It's a bit too harsh to make a large number of sl@0: * existing packages start failing by releasing a sl@0: * new patch release, so we forgive this type of error sl@0: * for the rest of the Tcl 8.4 series. sl@0: * sl@0: * We considered reporting a warning, but in practice sl@0: * even that appears too harsh a change for a patch release. sl@0: * sl@0: * We limit the error reporting to only sl@0: * the situation where a broken ifneeded script leads sl@0: * to a failure to satisfy the requirement. sl@0: */ sl@0: sl@0: if (reqc > 0) { sl@0: satisfies = AllRequirementsSatisfied (pvi, reqc, reqv); sl@0: if (!satisfies) { sl@0: Tcl_ResetResult(interp); sl@0: code = TCL_ERROR; sl@0: Tcl_AppendResult(interp, sl@0: "attempt to provide package ", name, " ", sl@0: versionToProvide, " failed: package ", sl@0: name, " ", pkgPtr->version, sl@0: " provided instead", NULL); sl@0: } sl@0: } sl@0: /* sl@0: * Warning generation now disabled sl@0: if (code == TCL_OK) { sl@0: Tcl_Obj *msg = Tcl_NewStringObj( sl@0: "attempt to provide package ", -1); sl@0: Tcl_Obj *cmdPtr = Tcl_NewListObj(0, NULL); sl@0: Tcl_ListObjAppendElement(NULL, cmdPtr, sl@0: Tcl_NewStringObj("tclLog", -1)); sl@0: Tcl_AppendStringsToObj(msg, name, " ", versionToProvide, sl@0: " failed: package ", name, " ", sl@0: pkgPtr->version, " provided instead", NULL); sl@0: Tcl_ListObjAppendElement(NULL, cmdPtr, msg); sl@0: Tcl_IncrRefCount(cmdPtr); sl@0: Tcl_EvalObjEx(interp, cmdPtr, TCL_EVAL_GLOBAL); sl@0: Tcl_DecrRefCount(cmdPtr); sl@0: Tcl_ResetResult(interp); sl@0: } sl@0: */ sl@0: #endif sl@0: } sl@0: #ifdef TCL_TIP268 sl@0: Tcl_Free (pvi); sl@0: #endif sl@0: } sl@0: #ifndef TCL_TIP268 sl@0: /* sl@0: * Warning generation now disabled sl@0: if (code == TCL_OK) { sl@0: Tcl_Obj *msg = Tcl_NewStringObj( sl@0: "attempt to provide package ", -1); sl@0: Tcl_Obj *cmdPtr = Tcl_NewListObj(0, NULL); sl@0: Tcl_ListObjAppendElement(NULL, cmdPtr, sl@0: Tcl_NewStringObj("tclLog", -1)); sl@0: Tcl_AppendStringsToObj(msg, name, " ", versionToProvide, sl@0: " failed: package ", name, " ", sl@0: pkgPtr->version, " provided instead", NULL); sl@0: Tcl_ListObjAppendElement(NULL, cmdPtr, msg); sl@0: Tcl_IncrRefCount(cmdPtr); sl@0: Tcl_EvalObjEx(interp, cmdPtr, TCL_EVAL_GLOBAL); sl@0: Tcl_DecrRefCount(cmdPtr); sl@0: Tcl_ResetResult(interp); sl@0: } sl@0: */ sl@0: #endif sl@0: } sl@0: } else if (code != TCL_ERROR) { sl@0: Tcl_Obj *codePtr = Tcl_NewIntObj(code); sl@0: Tcl_ResetResult(interp); sl@0: Tcl_AppendResult(interp, "attempt to provide package ", sl@0: name, " ", versionToProvide, " failed: ", sl@0: "bad return code: ", Tcl_GetString(codePtr), NULL); sl@0: Tcl_DecrRefCount(codePtr); sl@0: code = TCL_ERROR; sl@0: } sl@0: Tcl_Release((ClientData) versionToProvide); sl@0: sl@0: if (code != TCL_OK) { sl@0: /* sl@0: * Take a non-TCL_OK code from the script as an sl@0: * indication the package wasn't loaded properly, sl@0: * so the package system should not remember an sl@0: * improper load. sl@0: * sl@0: * This is consistent with our returning NULL. sl@0: * If we're not willing to tell our caller we sl@0: * got a particular version, we shouldn't store sl@0: * that version for telling future callers either. sl@0: */ sl@0: Tcl_AddErrorInfo(interp, "\n (\"package ifneeded\" script)"); sl@0: if (pkgPtr->version != NULL) { sl@0: ckfree(pkgPtr->version); sl@0: pkgPtr->version = NULL; sl@0: } sl@0: pkgPtr->clientData = NULL; sl@0: #ifndef TCL_TIP268 sl@0: return NULL; sl@0: #else sl@0: return TCL_ERROR; sl@0: #endif sl@0: } sl@0: break; sl@0: } sl@0: sl@0: /* sl@0: * The package is not in the database. If there is a "package unknown" sl@0: * command, invoke it (but only on the first pass; after that, we sl@0: * should not get here in the first place). sl@0: */ sl@0: sl@0: if (pass > 1) { sl@0: break; sl@0: } sl@0: script = ((Interp *) interp)->packageUnknown; sl@0: if (script != NULL) { sl@0: Tcl_DStringInit(&command); sl@0: Tcl_DStringAppend(&command, script, -1); sl@0: Tcl_DStringAppendElement(&command, name); sl@0: #ifndef TCL_TIP268 sl@0: Tcl_DStringAppend(&command, " ", 1); sl@0: Tcl_DStringAppend(&command, (version != NULL) ? version : "{}", sl@0: -1); sl@0: if (exact) { sl@0: Tcl_DStringAppend(&command, " -exact", 7); sl@0: } sl@0: #else sl@0: AddRequirementsToDString(&command, reqc, reqv); sl@0: #endif sl@0: code = Tcl_EvalEx(interp, Tcl_DStringValue(&command), sl@0: Tcl_DStringLength(&command), TCL_EVAL_GLOBAL); sl@0: Tcl_DStringFree(&command); sl@0: if ((code != TCL_OK) && (code != TCL_ERROR)) { sl@0: Tcl_Obj *codePtr = Tcl_NewIntObj(code); sl@0: Tcl_ResetResult(interp); sl@0: Tcl_AppendResult(interp, "bad return code: ", sl@0: Tcl_GetString(codePtr), NULL); sl@0: Tcl_DecrRefCount(codePtr); sl@0: code = TCL_ERROR; sl@0: } sl@0: if (code == TCL_ERROR) { sl@0: Tcl_AddErrorInfo(interp, "\n (\"package unknown\" script)"); sl@0: #ifndef TCL_TIP268 sl@0: return NULL; sl@0: #else sl@0: return TCL_ERROR; sl@0: #endif sl@0: } sl@0: Tcl_ResetResult(interp); sl@0: } sl@0: } sl@0: sl@0: if (pkgPtr->version == NULL) { sl@0: Tcl_AppendResult(interp, "can't find package ", name, (char *) NULL); sl@0: #ifndef TCL_TIP268 sl@0: if (version != NULL) { sl@0: Tcl_AppendResult(interp, " ", version, (char *) NULL); sl@0: } sl@0: return NULL; sl@0: #else sl@0: AddRequirementsToResult(interp, reqc, reqv); sl@0: return TCL_ERROR; sl@0: #endif sl@0: } sl@0: sl@0: /* sl@0: * At this point we know that the package is present. Make sure that the sl@0: * provided version meets the current requirements. sl@0: */ sl@0: sl@0: #ifndef TCL_TIP268 sl@0: if (version == NULL) { sl@0: if (clientDataPtr) { sl@0: *clientDataPtr = pkgPtr->clientData; sl@0: } sl@0: return pkgPtr->version; sl@0: #else sl@0: if (reqc == 0) { sl@0: satisfies = 1; sl@0: } else { sl@0: CheckVersionAndConvert (interp, pkgPtr->version, &pkgVersionI, NULL); sl@0: satisfies = AllRequirementsSatisfied (pkgVersionI, reqc, reqv); sl@0: sl@0: Tcl_Free (pkgVersionI); sl@0: #endif sl@0: } sl@0: #ifndef TCL_TIP268 sl@0: result = ComparePkgVersions(pkgPtr->version, version, &satisfies); sl@0: if ((satisfies && !exact) || (result == 0)) { sl@0: #else sl@0: if (satisfies) { sl@0: #endif sl@0: if (clientDataPtr) { sl@0: *clientDataPtr = pkgPtr->clientData; sl@0: } sl@0: #ifndef TCL_TIP268 sl@0: return pkgPtr->version; sl@0: #else sl@0: Tcl_SetObjResult (interp, Tcl_NewStringObj (pkgPtr->version, -1)); sl@0: return TCL_OK; sl@0: #endif sl@0: } sl@0: Tcl_AppendResult(interp, "version conflict for package \"", sl@0: name, "\": have ", pkgPtr->version, sl@0: #ifndef TCL_TIP268 sl@0: ", need ", version, (char *) NULL); sl@0: return NULL; sl@0: #else sl@0: ", need", (char*) NULL); sl@0: AddRequirementsToResult (interp, reqc, reqv); sl@0: return TCL_ERROR; sl@0: #endif sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_PkgPresent / Tcl_PkgPresentEx -- sl@0: * sl@0: * Checks to see whether the specified package is present. If it sl@0: * is not then no additional action is taken. sl@0: * sl@0: * Results: sl@0: * If successful, returns the version string for the currently sl@0: * provided version of the package, which may be different from sl@0: * the "version" argument. If the caller's requirements sl@0: * cannot be met (e.g. the version requested conflicts with sl@0: * a currently provided version), NULL is returned and an error sl@0: * message is left in interp->result. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C CONST char * sl@0: Tcl_PkgPresent(interp, name, version, exact) sl@0: Tcl_Interp *interp; /* Interpreter in which package is now sl@0: * available. */ sl@0: CONST char *name; /* Name of desired package. */ sl@0: CONST char *version; /* Version string for desired version; sl@0: * NULL means use the latest version sl@0: * available. */ sl@0: int exact; /* Non-zero means that only the particular sl@0: * version given is acceptable. Zero means sl@0: * use the latest compatible version. */ sl@0: { sl@0: return Tcl_PkgPresentEx(interp, name, version, exact, (ClientData *) NULL); sl@0: } sl@0: sl@0: EXPORT_C CONST char * sl@0: Tcl_PkgPresentEx(interp, name, version, exact, clientDataPtr) sl@0: Tcl_Interp *interp; /* Interpreter in which package is now sl@0: * available. */ sl@0: CONST char *name; /* Name of desired package. */ sl@0: CONST char *version; /* Version string for desired version; sl@0: * NULL means use the latest version sl@0: * available. */ sl@0: int exact; /* Non-zero means that only the particular sl@0: * version given is acceptable. Zero means sl@0: * use the latest compatible version. */ sl@0: ClientData *clientDataPtr; /* Used to return the client data for this sl@0: * package. If it is NULL then the client sl@0: * data is not returned. This is unchanged sl@0: * if this call fails for any reason. */ sl@0: { sl@0: Interp *iPtr = (Interp *) interp; sl@0: Tcl_HashEntry *hPtr; sl@0: Package *pkgPtr; sl@0: int satisfies, result; sl@0: sl@0: hPtr = Tcl_FindHashEntry(&iPtr->packageTable, name); sl@0: if (hPtr) { sl@0: pkgPtr = (Package *) Tcl_GetHashValue(hPtr); sl@0: if (pkgPtr->version != NULL) { sl@0: #ifdef TCL_TIP268 sl@0: char* pvi; sl@0: char* vi; sl@0: int thisIsMajor; sl@0: #endif sl@0: sl@0: /* sl@0: * At this point we know that the package is present. Make sure sl@0: * that the provided version meets the current requirement. sl@0: */ sl@0: sl@0: if (version == NULL) { sl@0: if (clientDataPtr) { sl@0: *clientDataPtr = pkgPtr->clientData; sl@0: } sl@0: sl@0: return pkgPtr->version; sl@0: } sl@0: #ifndef TCL_TIP268 sl@0: result = ComparePkgVersions(pkgPtr->version, version, &satisfies); sl@0: #else sl@0: if (CheckVersionAndConvert (interp, pkgPtr->version, &pvi, NULL) != TCL_OK) { sl@0: return NULL; sl@0: } else if (CheckVersionAndConvert (interp, version, &vi, NULL) != TCL_OK) { sl@0: Tcl_Free (pvi); sl@0: return NULL; sl@0: } sl@0: result = CompareVersions(pvi, vi, &thisIsMajor); sl@0: Tcl_Free (pvi); sl@0: Tcl_Free (vi); sl@0: satisfies = (result == 0) || ((result == 1) && !thisIsMajor); sl@0: #endif sl@0: if ((satisfies && !exact) || (result == 0)) { sl@0: if (clientDataPtr) { sl@0: *clientDataPtr = pkgPtr->clientData; sl@0: } sl@0: sl@0: return pkgPtr->version; sl@0: } sl@0: Tcl_AppendResult(interp, "version conflict for package \"", sl@0: name, "\": have ", pkgPtr->version, sl@0: ", need ", version, (char *) NULL); sl@0: return NULL; sl@0: } sl@0: } sl@0: sl@0: if (version != NULL) { sl@0: Tcl_AppendResult(interp, "package ", name, " ", version, sl@0: " is not present", (char *) NULL); sl@0: } else { sl@0: Tcl_AppendResult(interp, "package ", name, " is not present", sl@0: (char *) NULL); sl@0: } sl@0: return NULL; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_PackageObjCmd -- sl@0: * sl@0: * This procedure is invoked to process the "package" Tcl command. sl@0: * See the user documentation for details on what it does. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * See the user documentation. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: /* ARGSUSED */ sl@0: int sl@0: Tcl_PackageObjCmd(dummy, interp, objc, objv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: static CONST char *pkgOptions[] = { sl@0: "forget", "ifneeded", "names", sl@0: #ifdef TCL_TIP268 sl@0: "prefer", sl@0: #endif sl@0: "present", "provide", "require", "unknown", "vcompare", sl@0: "versions", "vsatisfies", (char *) NULL sl@0: }; sl@0: enum pkgOptions { sl@0: PKG_FORGET, PKG_IFNEEDED, PKG_NAMES, sl@0: #ifdef TCL_TIP268 sl@0: PKG_PREFER, sl@0: #endif sl@0: PKG_PRESENT, PKG_PROVIDE, PKG_REQUIRE, PKG_UNKNOWN, PKG_VCOMPARE, sl@0: PKG_VERSIONS, PKG_VSATISFIES sl@0: }; sl@0: Interp *iPtr = (Interp *) interp; sl@0: int optionIndex, exact, i, satisfies; sl@0: PkgAvail *availPtr, *prevPtr; sl@0: Package *pkgPtr; sl@0: Tcl_HashEntry *hPtr; sl@0: Tcl_HashSearch search; sl@0: Tcl_HashTable *tablePtr; sl@0: CONST char *version; sl@0: char *argv2, *argv3, *argv4; sl@0: #ifdef TCL_TIP268 sl@0: char* iva = NULL; sl@0: char* ivb = NULL; sl@0: #endif sl@0: sl@0: if (objc < 2) { sl@0: Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: if (Tcl_GetIndexFromObj(interp, objv[1], pkgOptions, "option", 0, sl@0: &optionIndex) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: switch ((enum pkgOptions) optionIndex) { sl@0: #ifndef TCL_TIP268 sl@0: case PKG_FORGET: { sl@0: char *keyString; sl@0: for (i = 2; i < objc; i++) { sl@0: keyString = Tcl_GetString(objv[i]); sl@0: hPtr = Tcl_FindHashEntry(&iPtr->packageTable, keyString); sl@0: if (hPtr == NULL) { sl@0: continue; sl@0: } sl@0: pkgPtr = (Package *) Tcl_GetHashValue(hPtr); sl@0: Tcl_DeleteHashEntry(hPtr); sl@0: if (pkgPtr->version != NULL) { sl@0: ckfree(pkgPtr->version); sl@0: } sl@0: while (pkgPtr->availPtr != NULL) { sl@0: availPtr = pkgPtr->availPtr; sl@0: pkgPtr->availPtr = availPtr->nextPtr; sl@0: Tcl_EventuallyFree((ClientData)availPtr->version, TCL_DYNAMIC); sl@0: Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC); sl@0: ckfree((char *) availPtr); sl@0: } sl@0: ckfree((char *) pkgPtr); sl@0: } sl@0: break; sl@0: #else sl@0: case PKG_FORGET: { sl@0: char *keyString; sl@0: for (i = 2; i < objc; i++) { sl@0: keyString = Tcl_GetString(objv[i]); sl@0: hPtr = Tcl_FindHashEntry(&iPtr->packageTable, keyString); sl@0: if (hPtr == NULL) { sl@0: continue; sl@0: } sl@0: pkgPtr = (Package *) Tcl_GetHashValue(hPtr); sl@0: Tcl_DeleteHashEntry(hPtr); sl@0: if (pkgPtr->version != NULL) { sl@0: ckfree(pkgPtr->version); sl@0: } sl@0: while (pkgPtr->availPtr != NULL) { sl@0: availPtr = pkgPtr->availPtr; sl@0: pkgPtr->availPtr = availPtr->nextPtr; sl@0: Tcl_EventuallyFree((ClientData)availPtr->version, TCL_DYNAMIC); sl@0: Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC); sl@0: ckfree((char *) availPtr); sl@0: } sl@0: ckfree((char *) pkgPtr); sl@0: } sl@0: break; sl@0: } sl@0: case PKG_IFNEEDED: { sl@0: int length; sl@0: char* argv3i; sl@0: char* avi; sl@0: int res; sl@0: sl@0: if ((objc != 4) && (objc != 5)) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, "package version ?script?"); sl@0: return TCL_ERROR; sl@0: } sl@0: argv3 = Tcl_GetString(objv[3]); sl@0: if (CheckVersionAndConvert(interp, argv3, &argv3i, NULL) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: #endif sl@0: } sl@0: #ifndef TCL_TIP268 sl@0: case PKG_IFNEEDED: { sl@0: int length; sl@0: if ((objc != 4) && (objc != 5)) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, "package version ?script?"); sl@0: return TCL_ERROR; sl@0: #else sl@0: argv2 = Tcl_GetString(objv[2]); sl@0: if (objc == 4) { sl@0: hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2); sl@0: if (hPtr == NULL) { sl@0: Tcl_Free (argv3i); sl@0: return TCL_OK; sl@0: #endif sl@0: } sl@0: #ifndef TCL_TIP268 sl@0: argv3 = Tcl_GetString(objv[3]); sl@0: if (CheckVersion(interp, argv3) != TCL_OK) { sl@0: #else sl@0: pkgPtr = (Package *) Tcl_GetHashValue(hPtr); sl@0: } else { sl@0: pkgPtr = FindPackage(interp, argv2); sl@0: } sl@0: argv3 = Tcl_GetStringFromObj(objv[3], &length); sl@0: sl@0: for (availPtr = pkgPtr->availPtr, prevPtr = NULL; sl@0: availPtr != NULL; sl@0: prevPtr = availPtr, availPtr = availPtr->nextPtr) { sl@0: sl@0: if (CheckVersionAndConvert (interp, availPtr->version, &avi, NULL) != TCL_OK) { sl@0: Tcl_Free (argv3i); sl@0: #endif sl@0: return TCL_ERROR; sl@0: } sl@0: #ifndef TCL_TIP268 sl@0: argv2 = Tcl_GetString(objv[2]); sl@0: if (objc == 4) { sl@0: hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2); sl@0: if (hPtr == NULL) { sl@0: #else sl@0: sl@0: res = CompareVersions(avi, argv3i, NULL); sl@0: Tcl_Free (avi); sl@0: sl@0: if (res == 0){ sl@0: if (objc == 4) { sl@0: Tcl_Free (argv3i); sl@0: Tcl_SetResult(interp, availPtr->script, TCL_VOLATILE); sl@0: #endif sl@0: return TCL_OK; sl@0: } sl@0: #ifndef TCL_TIP268 sl@0: pkgPtr = (Package *) Tcl_GetHashValue(hPtr); sl@0: } else { sl@0: pkgPtr = FindPackage(interp, argv2); sl@0: } sl@0: argv3 = Tcl_GetStringFromObj(objv[3], &length); sl@0: for (availPtr = pkgPtr->availPtr, prevPtr = NULL; availPtr != NULL; sl@0: prevPtr = availPtr, availPtr = availPtr->nextPtr) { sl@0: if (ComparePkgVersions(availPtr->version, argv3, (int *) NULL) sl@0: == 0) { sl@0: if (objc == 4) { sl@0: Tcl_SetResult(interp, availPtr->script, TCL_VOLATILE); sl@0: return TCL_OK; sl@0: } sl@0: Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC); sl@0: break; sl@0: } sl@0: } sl@0: if (objc == 4) { sl@0: return TCL_OK; sl@0: #else sl@0: Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC); sl@0: break; sl@0: #endif sl@0: } sl@0: #ifndef TCL_TIP268 sl@0: if (availPtr == NULL) { sl@0: availPtr = (PkgAvail *) ckalloc(sizeof(PkgAvail)); sl@0: availPtr->version = ckalloc((unsigned) (length + 1)); sl@0: strcpy(availPtr->version, argv3); sl@0: if (prevPtr == NULL) { sl@0: availPtr->nextPtr = pkgPtr->availPtr; sl@0: pkgPtr->availPtr = availPtr; sl@0: } else { sl@0: availPtr->nextPtr = prevPtr->nextPtr; sl@0: prevPtr->nextPtr = availPtr; sl@0: } sl@0: #else sl@0: } sl@0: Tcl_Free (argv3i); sl@0: if (objc == 4) { sl@0: return TCL_OK; sl@0: } sl@0: if (availPtr == NULL) { sl@0: availPtr = (PkgAvail *) ckalloc(sizeof(PkgAvail)); sl@0: availPtr->version = ckalloc((unsigned) (length + 1)); sl@0: strcpy(availPtr->version, argv3); sl@0: if (prevPtr == NULL) { sl@0: availPtr->nextPtr = pkgPtr->availPtr; sl@0: pkgPtr->availPtr = availPtr; sl@0: } else { sl@0: availPtr->nextPtr = prevPtr->nextPtr; sl@0: prevPtr->nextPtr = availPtr; sl@0: #endif sl@0: } sl@0: #ifndef TCL_TIP268 sl@0: argv4 = Tcl_GetStringFromObj(objv[4], &length); sl@0: availPtr->script = ckalloc((unsigned) (length + 1)); sl@0: strcpy(availPtr->script, argv4); sl@0: break; sl@0: #endif sl@0: } sl@0: #ifndef TCL_TIP268 sl@0: case PKG_NAMES: { sl@0: if (objc != 2) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, NULL); sl@0: #else sl@0: argv4 = Tcl_GetStringFromObj(objv[4], &length); sl@0: availPtr->script = ckalloc((unsigned) (length + 1)); sl@0: strcpy(availPtr->script, argv4); sl@0: break; sl@0: } sl@0: case PKG_NAMES: { sl@0: if (objc != 2) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: tablePtr = &iPtr->packageTable; sl@0: for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL; sl@0: hPtr = Tcl_NextHashEntry(&search)) { sl@0: pkgPtr = (Package *) Tcl_GetHashValue(hPtr); sl@0: if ((pkgPtr->version != NULL) || (pkgPtr->availPtr != NULL)) { sl@0: Tcl_AppendElement(interp, Tcl_GetHashKey(tablePtr, hPtr)); sl@0: } sl@0: } sl@0: break; sl@0: } sl@0: case PKG_PRESENT: { sl@0: if (objc < 3) { sl@0: presentSyntax: sl@0: Tcl_WrongNumArgs(interp, 2, objv, "?-exact? package ?version?"); sl@0: return TCL_ERROR; sl@0: } sl@0: argv2 = Tcl_GetString(objv[2]); sl@0: if ((argv2[0] == '-') && (strcmp(argv2, "-exact") == 0)) { sl@0: exact = 1; sl@0: } else { sl@0: exact = 0; sl@0: } sl@0: version = NULL; sl@0: if (objc == (4 + exact)) { sl@0: version = Tcl_GetString(objv[3 + exact]); sl@0: if (CheckVersionAndConvert(interp, version, NULL, NULL) != TCL_OK) { sl@0: #endif sl@0: return TCL_ERROR; sl@0: } sl@0: #ifndef TCL_TIP268 sl@0: tablePtr = &iPtr->packageTable; sl@0: for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL; sl@0: hPtr = Tcl_NextHashEntry(&search)) { sl@0: #else sl@0: } else if ((objc != 3) || exact) { sl@0: goto presentSyntax; sl@0: } sl@0: if (exact) { sl@0: argv3 = Tcl_GetString(objv[3]); sl@0: version = Tcl_PkgPresent(interp, argv3, version, exact); sl@0: } else { sl@0: version = Tcl_PkgPresent(interp, argv2, version, exact); sl@0: } sl@0: if (version == NULL) { sl@0: return TCL_ERROR; sl@0: } sl@0: Tcl_SetObjResult( interp, Tcl_NewStringObj( version, -1 ) ); sl@0: break; sl@0: } sl@0: case PKG_PROVIDE: { sl@0: if ((objc != 3) && (objc != 4)) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, "package ?version?"); sl@0: return TCL_ERROR; sl@0: } sl@0: argv2 = Tcl_GetString(objv[2]); sl@0: if (objc == 3) { sl@0: hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2); sl@0: if (hPtr != NULL) { sl@0: #endif sl@0: pkgPtr = (Package *) Tcl_GetHashValue(hPtr); sl@0: #ifndef TCL_TIP268 sl@0: if ((pkgPtr->version != NULL) || (pkgPtr->availPtr != NULL)) { sl@0: Tcl_AppendElement(interp, Tcl_GetHashKey(tablePtr, hPtr)); sl@0: #else sl@0: if (pkgPtr->version != NULL) { sl@0: Tcl_SetResult(interp, pkgPtr->version, TCL_VOLATILE); sl@0: #endif sl@0: } sl@0: } sl@0: #ifndef TCL_TIP268 sl@0: break; sl@0: #else sl@0: return TCL_OK; sl@0: #endif sl@0: } sl@0: #ifndef TCL_TIP268 sl@0: case PKG_PRESENT: { sl@0: if (objc < 3) { sl@0: presentSyntax: sl@0: Tcl_WrongNumArgs(interp, 2, objv, "?-exact? package ?version?"); sl@0: return TCL_ERROR; sl@0: #else sl@0: argv3 = Tcl_GetString(objv[3]); sl@0: if (CheckVersionAndConvert(interp, argv3, NULL, NULL) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: return Tcl_PkgProvide(interp, argv2, argv3); sl@0: } sl@0: case PKG_REQUIRE: { sl@0: if (objc < 3) { sl@0: requireSyntax: sl@0: Tcl_WrongNumArgs(interp, 2, objv, "?-exact? package ?requirement...?"); sl@0: return TCL_ERROR; sl@0: } sl@0: version = NULL; sl@0: argv2 = Tcl_GetString(objv[2]); sl@0: if ((argv2[0] == '-') && (strcmp(argv2, "-exact") == 0)) { sl@0: Tcl_Obj* ov; sl@0: int res; sl@0: sl@0: if (objc != 5) { sl@0: goto requireSyntax; sl@0: #endif sl@0: } sl@0: #ifndef TCL_TIP268 sl@0: argv2 = Tcl_GetString(objv[2]); sl@0: if ((argv2[0] == '-') && (strcmp(argv2, "-exact") == 0)) { sl@0: exact = 1; sl@0: } else { sl@0: exact = 0; sl@0: #else sl@0: version = Tcl_GetString(objv[4]); sl@0: if (CheckVersionAndConvert(interp, version, NULL, NULL) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: #endif sl@0: } sl@0: #ifdef TCL_TIP268 sl@0: /* Create a new-style requirement for the exact version. */ sl@0: sl@0: ov = ExactRequirement (version); sl@0: #endif sl@0: version = NULL; sl@0: #ifndef TCL_TIP268 sl@0: if (objc == (4 + exact)) { sl@0: version = Tcl_GetString(objv[3 + exact]); sl@0: if (CheckVersion(interp, version) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: } else if ((objc != 3) || exact) { sl@0: goto presentSyntax; sl@0: } sl@0: if (exact) { sl@0: argv3 = Tcl_GetString(objv[3]); sl@0: version = Tcl_PkgPresent(interp, argv3, version, exact); sl@0: } else { sl@0: version = Tcl_PkgPresent(interp, argv2, version, exact); sl@0: } sl@0: if (version == NULL) { sl@0: #else sl@0: argv3 = Tcl_GetString(objv[3]); sl@0: sl@0: Tcl_IncrRefCount (ov); sl@0: res = Tcl_PkgRequireProc(interp, argv3, 1, &ov, NULL); sl@0: Tcl_DecrRefCount (ov); sl@0: return res; sl@0: } else { sl@0: if (CheckAllRequirements (interp, objc-3, objv+3) != TCL_OK) { sl@0: #endif sl@0: return TCL_ERROR; sl@0: } sl@0: #ifndef TCL_TIP268 sl@0: Tcl_SetObjResult( interp, Tcl_NewStringObj( version, -1 ) ); sl@0: break; sl@0: #else sl@0: return Tcl_PkgRequireProc(interp, argv2, objc-3, objv+3, NULL); sl@0: #endif sl@0: } sl@0: #ifndef TCL_TIP268 sl@0: case PKG_PROVIDE: { sl@0: if ((objc != 3) && (objc != 4)) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, "package ?version?"); sl@0: #else sl@0: break; sl@0: } sl@0: case PKG_UNKNOWN: { sl@0: int length; sl@0: if (objc == 2) { sl@0: if (iPtr->packageUnknown != NULL) { sl@0: Tcl_SetResult(interp, iPtr->packageUnknown, TCL_VOLATILE); sl@0: } sl@0: } else if (objc == 3) { sl@0: if (iPtr->packageUnknown != NULL) { sl@0: ckfree(iPtr->packageUnknown); sl@0: } sl@0: argv2 = Tcl_GetStringFromObj(objv[2], &length); sl@0: if (argv2[0] == 0) { sl@0: iPtr->packageUnknown = NULL; sl@0: } else { sl@0: iPtr->packageUnknown = (char *) ckalloc((unsigned) sl@0: (length + 1)); sl@0: strcpy(iPtr->packageUnknown, argv2); sl@0: } sl@0: } else { sl@0: Tcl_WrongNumArgs(interp, 2, objv, "?command?"); sl@0: return TCL_ERROR; sl@0: } sl@0: break; sl@0: } sl@0: case PKG_PREFER: { sl@0: /* See tclInt.h for the enum, just before Interp */ sl@0: static CONST char *pkgPreferOptions[] = { sl@0: "latest", "stable", NULL sl@0: }; sl@0: sl@0: if (objc > 3) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, "?latest|stable?"); sl@0: return TCL_ERROR; sl@0: } else if (objc == 3) { sl@0: /* Set value. */ sl@0: int new; sl@0: if (Tcl_GetIndexFromObj(interp, objv[2], pkgPreferOptions, "preference", 0, sl@0: &new) != TCL_OK) { sl@0: #endif sl@0: return TCL_ERROR; sl@0: } sl@0: #ifndef TCL_TIP268 sl@0: argv2 = Tcl_GetString(objv[2]); sl@0: if (objc == 3) { sl@0: hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2); sl@0: if (hPtr != NULL) { sl@0: pkgPtr = (Package *) Tcl_GetHashValue(hPtr); sl@0: if (pkgPtr->version != NULL) { sl@0: Tcl_SetResult(interp, pkgPtr->version, TCL_VOLATILE); sl@0: } sl@0: } sl@0: return TCL_OK; sl@0: #else sl@0: if (new < iPtr->packagePrefer) { sl@0: iPtr->packagePrefer = new; sl@0: #endif sl@0: } sl@0: #ifndef TCL_TIP268 sl@0: argv3 = Tcl_GetString(objv[3]); sl@0: if (CheckVersion(interp, argv3) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: return Tcl_PkgProvide(interp, argv2, argv3); sl@0: #endif sl@0: } sl@0: #ifndef TCL_TIP268 sl@0: case PKG_REQUIRE: { sl@0: if (objc < 3) { sl@0: requireSyntax: sl@0: Tcl_WrongNumArgs(interp, 2, objv, "?-exact? package ?version?"); sl@0: return TCL_ERROR; sl@0: } sl@0: argv2 = Tcl_GetString(objv[2]); sl@0: if ((argv2[0] == '-') && (strcmp(argv2, "-exact") == 0)) { sl@0: exact = 1; sl@0: } else { sl@0: exact = 0; sl@0: } sl@0: version = NULL; sl@0: if (objc == (4 + exact)) { sl@0: version = Tcl_GetString(objv[3 + exact]); sl@0: if (CheckVersion(interp, version) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: } else if ((objc != 3) || exact) { sl@0: goto requireSyntax; sl@0: } sl@0: if (exact) { sl@0: argv3 = Tcl_GetString(objv[3]); sl@0: version = Tcl_PkgRequire(interp, argv3, version, exact); sl@0: } else { sl@0: version = Tcl_PkgRequire(interp, argv2, version, exact); sl@0: } sl@0: if (version == NULL) { sl@0: return TCL_ERROR; sl@0: } sl@0: Tcl_SetObjResult( interp, Tcl_NewStringObj( version, -1 ) ); sl@0: break; sl@0: #else sl@0: /* Always return current value. */ sl@0: Tcl_SetObjResult(interp, Tcl_NewStringObj (pkgPreferOptions [iPtr->packagePrefer], -1)); sl@0: break; sl@0: } sl@0: case PKG_VCOMPARE: { sl@0: if (objc != 4) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, "version1 version2"); sl@0: return TCL_ERROR; sl@0: #endif sl@0: } sl@0: #ifndef TCL_TIP268 sl@0: case PKG_UNKNOWN: { sl@0: int length; sl@0: if (objc == 2) { sl@0: if (iPtr->packageUnknown != NULL) { sl@0: Tcl_SetResult(interp, iPtr->packageUnknown, TCL_VOLATILE); sl@0: } sl@0: } else if (objc == 3) { sl@0: if (iPtr->packageUnknown != NULL) { sl@0: ckfree(iPtr->packageUnknown); sl@0: } sl@0: argv2 = Tcl_GetStringFromObj(objv[2], &length); sl@0: if (argv2[0] == 0) { sl@0: iPtr->packageUnknown = NULL; sl@0: } else { sl@0: iPtr->packageUnknown = (char *) ckalloc((unsigned) sl@0: (length + 1)); sl@0: strcpy(iPtr->packageUnknown, argv2); sl@0: } sl@0: } else { sl@0: Tcl_WrongNumArgs(interp, 2, objv, "?command?"); sl@0: return TCL_ERROR; sl@0: } sl@0: break; sl@0: #else sl@0: argv3 = Tcl_GetString(objv[3]); sl@0: argv2 = Tcl_GetString(objv[2]); sl@0: if ((CheckVersionAndConvert (interp, argv2, &iva, NULL) != TCL_OK) || sl@0: (CheckVersionAndConvert (interp, argv3, &ivb, NULL) != TCL_OK)) { sl@0: if (iva != NULL) { Tcl_Free (iva); } sl@0: /* ivb cannot be set in this branch */ sl@0: return TCL_ERROR; sl@0: #endif sl@0: } sl@0: #ifndef TCL_TIP268 sl@0: case PKG_VCOMPARE: { sl@0: if (objc != 4) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, "version1 version2"); sl@0: return TCL_ERROR; sl@0: } sl@0: argv3 = Tcl_GetString(objv[3]); sl@0: argv2 = Tcl_GetString(objv[2]); sl@0: if ((CheckVersion(interp, argv2) != TCL_OK) sl@0: || (CheckVersion(interp, argv3) != TCL_OK)) { sl@0: return TCL_ERROR; sl@0: } sl@0: Tcl_SetIntObj(Tcl_GetObjResult(interp), sl@0: ComparePkgVersions(argv2, argv3, (int *) NULL)); sl@0: break; sl@0: #else sl@0: sl@0: /* Comparison is done on the internal representation */ sl@0: Tcl_SetObjResult(interp,Tcl_NewIntObj(CompareVersions(iva, ivb, NULL))); sl@0: Tcl_Free (iva); sl@0: Tcl_Free (ivb); sl@0: break; sl@0: } sl@0: case PKG_VERSIONS: { sl@0: if (objc != 3) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, "package"); sl@0: return TCL_ERROR; sl@0: #endif sl@0: } sl@0: #ifndef TCL_TIP268 sl@0: case PKG_VERSIONS: { sl@0: if (objc != 3) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, "package"); sl@0: return TCL_ERROR; sl@0: #else sl@0: argv2 = Tcl_GetString(objv[2]); sl@0: hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2); sl@0: if (hPtr != NULL) { sl@0: pkgPtr = (Package *) Tcl_GetHashValue(hPtr); sl@0: for (availPtr = pkgPtr->availPtr; availPtr != NULL; sl@0: availPtr = availPtr->nextPtr) { sl@0: Tcl_AppendElement(interp, availPtr->version); sl@0: #endif sl@0: } sl@0: #ifndef TCL_TIP268 sl@0: argv2 = Tcl_GetString(objv[2]); sl@0: hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2); sl@0: if (hPtr != NULL) { sl@0: pkgPtr = (Package *) Tcl_GetHashValue(hPtr); sl@0: for (availPtr = pkgPtr->availPtr; availPtr != NULL; sl@0: availPtr = availPtr->nextPtr) { sl@0: Tcl_AppendElement(interp, availPtr->version); sl@0: } sl@0: } sl@0: break; sl@0: #endif sl@0: } sl@0: #ifndef TCL_TIP268 sl@0: case PKG_VSATISFIES: { sl@0: if (objc != 4) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, "version1 version2"); sl@0: return TCL_ERROR; sl@0: } sl@0: argv3 = Tcl_GetString(objv[3]); sl@0: argv2 = Tcl_GetString(objv[2]); sl@0: if ((CheckVersion(interp, argv2) != TCL_OK) sl@0: || (CheckVersion(interp, argv3) != TCL_OK)) { sl@0: return TCL_ERROR; sl@0: } sl@0: ComparePkgVersions(argv2, argv3, &satisfies); sl@0: Tcl_SetIntObj(Tcl_GetObjResult(interp), satisfies); sl@0: break; sl@0: #else sl@0: break; sl@0: } sl@0: case PKG_VSATISFIES: { sl@0: char* argv2i = NULL; sl@0: sl@0: if (objc < 4) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, "version requirement requirement..."); sl@0: return TCL_ERROR; sl@0: #endif sl@0: } sl@0: #ifndef TCL_TIP268 sl@0: default: { sl@0: panic("Tcl_PackageObjCmd: bad option index to pkgOptions"); sl@0: #else sl@0: sl@0: argv2 = Tcl_GetString(objv[2]); sl@0: if ((CheckVersionAndConvert(interp, argv2, &argv2i, NULL) != TCL_OK)) { sl@0: return TCL_ERROR; sl@0: } else if (CheckAllRequirements (interp, objc-3, objv+3) != TCL_OK) { sl@0: Tcl_Free (argv2i); sl@0: return TCL_ERROR; sl@0: #endif sl@0: } sl@0: #ifdef TCL_TIP268 sl@0: sl@0: satisfies = AllRequirementsSatisfied (argv2i, objc-3, objv+3); sl@0: Tcl_Free (argv2i); sl@0: sl@0: Tcl_SetIntObj(Tcl_GetObjResult(interp), satisfies); sl@0: break; sl@0: } sl@0: default: { sl@0: panic("Tcl_PackageObjCmd: bad option index to pkgOptions"); sl@0: } sl@0: #endif sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * FindPackage -- sl@0: * sl@0: * This procedure finds the Package record for a particular package sl@0: * in a particular interpreter, creating a record if one doesn't sl@0: * already exist. sl@0: * sl@0: * Results: sl@0: * The return value is a pointer to the Package record for the sl@0: * package. sl@0: * sl@0: * Side effects: sl@0: * A new Package record may be created. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static Package * sl@0: FindPackage(interp, name) sl@0: Tcl_Interp *interp; /* Interpreter to use for package lookup. */ sl@0: CONST char *name; /* Name of package to fine. */ sl@0: { sl@0: Interp *iPtr = (Interp *) interp; sl@0: Tcl_HashEntry *hPtr; sl@0: int new; sl@0: Package *pkgPtr; sl@0: sl@0: hPtr = Tcl_CreateHashEntry(&iPtr->packageTable, name, &new); sl@0: if (new) { sl@0: pkgPtr = (Package *) ckalloc(sizeof(Package)); sl@0: pkgPtr->version = NULL; sl@0: pkgPtr->availPtr = NULL; sl@0: pkgPtr->clientData = NULL; sl@0: Tcl_SetHashValue(hPtr, pkgPtr); sl@0: } else { sl@0: pkgPtr = (Package *) Tcl_GetHashValue(hPtr); sl@0: } sl@0: return pkgPtr; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TclFreePackageInfo -- sl@0: * sl@0: * This procedure is called during interpreter deletion to sl@0: * free all of the package-related information for the sl@0: * interpreter. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * Memory is freed. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: void sl@0: TclFreePackageInfo(iPtr) sl@0: Interp *iPtr; /* Interpreter that is being deleted. */ sl@0: { sl@0: Package *pkgPtr; sl@0: Tcl_HashSearch search; sl@0: Tcl_HashEntry *hPtr; sl@0: PkgAvail *availPtr; sl@0: sl@0: for (hPtr = Tcl_FirstHashEntry(&iPtr->packageTable, &search); sl@0: hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { sl@0: pkgPtr = (Package *) Tcl_GetHashValue(hPtr); sl@0: if (pkgPtr->version != NULL) { sl@0: ckfree(pkgPtr->version); sl@0: } sl@0: while (pkgPtr->availPtr != NULL) { sl@0: availPtr = pkgPtr->availPtr; sl@0: pkgPtr->availPtr = availPtr->nextPtr; sl@0: Tcl_EventuallyFree((ClientData)availPtr->version, TCL_DYNAMIC); sl@0: Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC); sl@0: ckfree((char *) availPtr); sl@0: } sl@0: ckfree((char *) pkgPtr); sl@0: } sl@0: Tcl_DeleteHashTable(&iPtr->packageTable); sl@0: if (iPtr->packageUnknown != NULL) { sl@0: ckfree(iPtr->packageUnknown); sl@0: } sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * CheckVersion / CheckVersionAndConvert -- sl@0: * sl@0: * This procedure checks to see whether a version number has sl@0: * valid syntax. sl@0: * sl@0: * Results: sl@0: * If string is a properly formed version number the TCL_OK sl@0: * is returned. Otherwise TCL_ERROR is returned and an error sl@0: * message is left in the interp's result. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: #ifndef TCL_TIP268 sl@0: CheckVersion(interp, string) sl@0: Tcl_Interp *interp; /* Used for error reporting. */ sl@0: CONST char *string; /* Supposedly a version number, which is sl@0: * groups of decimal digits separated sl@0: * by dots. */ sl@0: #else sl@0: CheckVersionAndConvert(interp, string, internal, stable) sl@0: Tcl_Interp *interp; /* Used for error reporting. */ sl@0: CONST char *string; /* Supposedly a version number, which is sl@0: * groups of decimal digits separated by sl@0: * dots. */ sl@0: char** internal; /* Internal normalized representation */ sl@0: int* stable; /* Flag: Version is (un)stable. */ sl@0: #endif sl@0: { sl@0: CONST char *p = string; sl@0: char prevChar; sl@0: #ifdef TCL_TIP268 sl@0: int hasunstable = 0; sl@0: /* 4* assuming that each char is a separator (a,b become ' -x '). sl@0: * 4+ to have spce for an additional -2 at the end sl@0: */ sl@0: char* ibuf = ckalloc (4+4*strlen(string)); sl@0: char* ip = ibuf; sl@0: sl@0: /* Basic rules sl@0: * (1) First character has to be a digit. sl@0: * (2) All other characters have to be a digit or '.' sl@0: * (3) Two '.'s may not follow each other. sl@0: sl@0: * TIP 268, Modified rules sl@0: * (1) s.a. sl@0: * (2) All other characters have to be a digit, 'a', 'b', or '.' sl@0: * (3) s.a. sl@0: * (4) Only one of 'a' or 'b' may occur. sl@0: * (5) Neither 'a', nor 'b' may occur before or after a '.' sl@0: */ sl@0: sl@0: #endif sl@0: if (!isdigit(UCHAR(*p))) { /* INTL: digit */ sl@0: goto error; sl@0: } sl@0: #ifdef TCL_TIP268 sl@0: *ip++ = *p; sl@0: #endif sl@0: for (prevChar = *p, p++; *p != 0; p++) { sl@0: #ifndef TCL_TIP268 sl@0: if (!isdigit(UCHAR(*p)) && sl@0: ((*p != '.') || (prevChar == '.'))) { /* INTL: digit */ sl@0: #else sl@0: if ( sl@0: (!isdigit(UCHAR(*p))) && sl@0: (((*p != '.') && (*p != 'a') && (*p != 'b')) || sl@0: ((hasunstable && ((*p == 'a') || (*p == 'b'))) || sl@0: (((prevChar == 'a') || (prevChar == 'b') || (prevChar == '.')) && (*p == '.')) || sl@0: (((*p == 'a') || (*p == 'b') || (*p == '.')) && (prevChar == '.')))) sl@0: ) { sl@0: /* INTL: digit */ sl@0: #endif sl@0: goto error; sl@0: } sl@0: #ifdef TCL_TIP268 sl@0: if ((*p == 'a') || (*p == 'b')) { hasunstable = 1 ; } sl@0: sl@0: /* Translation to the internal rep. Regular version chars are copied sl@0: * as is. The separators are translated to numerics. The new separator sl@0: * for all parts is space. */ sl@0: sl@0: if (*p == '.') { *ip++ = ' '; *ip++ = '0'; *ip++ = ' '; } sl@0: else if (*p == 'a') { *ip++ = ' '; *ip++ = '-'; *ip++ = '2'; *ip++ = ' '; } sl@0: else if (*p == 'b') { *ip++ = ' '; *ip++ = '-'; *ip++ = '1'; *ip++ = ' '; } sl@0: else { *ip++ = *p; } sl@0: #endif sl@0: prevChar = *p; sl@0: } sl@0: #ifndef TCL_TIP268 sl@0: if (prevChar != '.') { sl@0: #else sl@0: if ((prevChar != '.') && (prevChar != 'a') && (prevChar != 'b')) { sl@0: *ip = '\0'; sl@0: if (internal != NULL) { sl@0: *internal = ibuf; sl@0: } else { sl@0: Tcl_Free (ibuf); sl@0: } sl@0: if (stable != NULL) { sl@0: *stable = !hasunstable; sl@0: } sl@0: #endif sl@0: return TCL_OK; sl@0: } sl@0: sl@0: error: sl@0: #ifdef TCL_TIP268 sl@0: ckfree (ibuf); sl@0: #endif sl@0: Tcl_AppendResult(interp, "expected version number but got \"", sl@0: string, "\"", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * ComparePkgVersions / CompareVersions -- sl@0: * sl@0: * This procedure compares two version numbers. (268: in internal rep). sl@0: * sl@0: * Results: sl@0: * The return value is -1 if v1 is less than v2, 0 if the two sl@0: * version numbers are the same, and 1 if v1 is greater than v2. sl@0: * If *satPtr is non-NULL, the word it points to is filled in sl@0: * with 1 if v2 >= v1 and both numbers have the same major number sl@0: * or 0 otherwise. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: #ifndef TCL_TIP268 sl@0: ComparePkgVersions(v1, v2, satPtr) sl@0: CONST char *v1; sl@0: CONST char *v2; /* Versions strings, of form 2.1.3 (any sl@0: * number of version numbers). */ sl@0: int *satPtr; /* If non-null, the word pointed to is sl@0: * filled in with a 0/1 value. 1 means sl@0: * v1 "satisfies" v2: v1 is greater than sl@0: * or equal to v2 and both version numbers sl@0: * have the same major number. */ sl@0: #else sl@0: CompareVersions(v1, v2, isMajorPtr) sl@0: CONST char *v1; /* Versions strings, of form 2.1.3 (any number */ sl@0: CONST char *v2; /* of version numbers). */ sl@0: int *isMajorPtr; /* If non-null, the word pointed to is filled sl@0: * in with a 0/1 value. 1 means that the difference sl@0: * occured in the first element. */ sl@0: #endif sl@0: { sl@0: int thisIsMajor, n1, n2; sl@0: #ifdef TCL_TIP268 sl@0: int res, flip; sl@0: #endif sl@0: sl@0: /* sl@0: * Each iteration of the following loop processes one number from each sl@0: * string, terminated by a " " (space). If those numbers don't match then the sl@0: * comparison is over; otherwise, we loop back for the next number. sl@0: * sl@0: * TIP 268. sl@0: * This is identical the function 'ComparePkgVersion', but using the new sl@0: * space separator as used by the internal rep of version numbers. The sl@0: * special separators 'a' and 'b' have already been dealt with in sl@0: * 'CheckVersionAndConvert', they were translated into numbers as sl@0: * well. This keeps the comparison sane. Otherwise we would have to sl@0: * compare numerics, the separators, and also deal with the special case sl@0: * of end-of-string compared to separators. The semi-list rep we get here sl@0: * is much easier to handle, as it is still regular. sl@0: */ sl@0: sl@0: thisIsMajor = 1; sl@0: while (1) { sl@0: /* sl@0: * Parse one decimal number from the front of each string. sl@0: */ sl@0: sl@0: n1 = n2 = 0; sl@0: #ifndef TCL_TIP268 sl@0: while ((*v1 != 0) && (*v1 != '.')) { sl@0: #else sl@0: flip = 0; sl@0: while ((*v1 != 0) && (*v1 != ' ')) { sl@0: if (*v1 == '-') {flip = 1 ; v1++ ; continue;} sl@0: #endif sl@0: n1 = 10*n1 + (*v1 - '0'); sl@0: v1++; sl@0: } sl@0: #ifndef TCL_TIP268 sl@0: while ((*v2 != 0) && (*v2 != '.')) { sl@0: #else sl@0: if (flip) n1 = -n1; sl@0: flip = 0; sl@0: while ((*v2 != 0) && (*v2 != ' ')) { sl@0: if (*v2 == '-') {flip = 1; v2++ ; continue;} sl@0: #endif sl@0: n2 = 10*n2 + (*v2 - '0'); sl@0: v2++; sl@0: } sl@0: #ifdef TCL_TIP268 sl@0: if (flip) n2 = -n2; sl@0: #endif sl@0: sl@0: /* sl@0: * Compare and go on to the next version number if the current numbers sl@0: * match. sl@0: */ sl@0: sl@0: if (n1 != n2) { sl@0: break; sl@0: } sl@0: if (*v1 != 0) { sl@0: v1++; sl@0: } else if (*v2 == 0) { sl@0: break; sl@0: } sl@0: if (*v2 != 0) { sl@0: v2++; sl@0: } sl@0: thisIsMajor = 0; sl@0: } sl@0: #ifndef TCL_TIP268 sl@0: if (satPtr != NULL) { sl@0: *satPtr = (n1 == n2) || ((n1 > n2) && !thisIsMajor); sl@0: } sl@0: #endif sl@0: if (n1 > n2) { sl@0: #ifndef TCL_TIP268 sl@0: return 1; sl@0: #else sl@0: res = 1; sl@0: #endif sl@0: } else if (n1 == n2) { sl@0: #ifndef TCL_TIP268 sl@0: return 0; sl@0: #else sl@0: res = 0; sl@0: #endif sl@0: } else { sl@0: #ifndef TCL_TIP268 sl@0: return -1; sl@0: #else sl@0: res = -1; sl@0: } sl@0: sl@0: if (isMajorPtr != NULL) { sl@0: *isMajorPtr = thisIsMajor; sl@0: } sl@0: sl@0: return res; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * CheckAllRequirements -- sl@0: * sl@0: * This function checks to see whether all requirements in a set sl@0: * have valid syntax. sl@0: * sl@0: * Results: sl@0: * TCL_OK is returned if all requirements are valid. sl@0: * Otherwise TCL_ERROR is returned and an error message sl@0: * is left in the interp's result. sl@0: * sl@0: * Side effects: sl@0: * May modify the interpreter result. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: CheckAllRequirements(interp, reqc, reqv) sl@0: Tcl_Interp* interp; sl@0: int reqc; /* Requirements to check. */ sl@0: Tcl_Obj *CONST reqv[]; sl@0: { sl@0: int i; sl@0: for (i = 0; i < reqc; i++) { sl@0: if ((CheckRequirement(interp, Tcl_GetString(reqv[i])) != TCL_OK)) { sl@0: return TCL_ERROR; sl@0: } sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * CheckRequirement -- sl@0: * sl@0: * This function checks to see whether a requirement has valid syntax. sl@0: * sl@0: * Results: sl@0: * If string is a properly formed requirement then TCL_OK is returned. sl@0: * Otherwise TCL_ERROR is returned and an error message is left in the sl@0: * interp's result. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: CheckRequirement(interp, string) sl@0: Tcl_Interp *interp; /* Used for error reporting. */ sl@0: CONST char *string; /* Supposedly a requirement. */ sl@0: { sl@0: /* Syntax of requirement = version sl@0: * = version-version sl@0: * = version- sl@0: */ sl@0: sl@0: char* dash = NULL; sl@0: char* buf; sl@0: sl@0: dash = strchr (string, '-'); sl@0: if (dash == NULL) { sl@0: /* no dash found, has to be a simple version */ sl@0: return CheckVersionAndConvert (interp, string, NULL, NULL); sl@0: } sl@0: if (strchr (dash+1, '-') != NULL) { sl@0: /* More dashes found after the first. This is wrong. */ sl@0: Tcl_AppendResult(interp, "expected versionMin-versionMax but got \"", string, sl@0: "\"", NULL); sl@0: return TCL_ERROR; sl@0: #endif sl@0: } sl@0: #ifdef TCL_TIP268 sl@0: sl@0: /* Exactly one dash is present. Copy the string, split at the location of sl@0: * dash and check that both parts are versions. Note that the max part can sl@0: * be empty. sl@0: */ sl@0: sl@0: buf = strdup (string); sl@0: dash = buf + (dash - string); sl@0: *dash = '\0'; /* buf now <=> min part */ sl@0: dash ++; /* dash now <=> max part */ sl@0: sl@0: if ((CheckVersionAndConvert(interp, buf, NULL, NULL) != TCL_OK) || sl@0: ((*dash != '\0') && sl@0: (CheckVersionAndConvert(interp, dash, NULL, NULL) != TCL_OK))) { sl@0: free (buf); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: free (buf); sl@0: return TCL_OK; sl@0: #endif sl@0: } sl@0: #ifdef TCL_TIP268 sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * AddRequirementsToResult -- sl@0: * sl@0: * This function accumulates requirements in the interpreter result. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * The interpreter result is extended. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static void sl@0: AddRequirementsToResult(interp, reqc, reqv) sl@0: Tcl_Interp* interp; sl@0: int reqc; /* Requirements constraining the desired version. */ sl@0: Tcl_Obj *CONST reqv[]; /* 0 means to use the latest version available. */ sl@0: { sl@0: if (reqc > 0) { sl@0: int i; sl@0: for (i = 0; i < reqc; i++) { sl@0: Tcl_AppendResult(interp, " ", TclGetString(reqv[i]), NULL); sl@0: } sl@0: } sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * AddRequirementsToDString -- sl@0: * sl@0: * This function accumulates requirements in a DString. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * The DString argument is extended. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static void sl@0: AddRequirementsToDString(dstring, reqc, reqv) sl@0: Tcl_DString* dstring; sl@0: int reqc; /* Requirements constraining the desired version. */ sl@0: Tcl_Obj *CONST reqv[]; /* 0 means to use the latest version available. */ sl@0: { sl@0: if (reqc > 0) { sl@0: int i; sl@0: for (i = 0; i < reqc; i++) { sl@0: Tcl_DStringAppend(dstring, " ", 1); sl@0: Tcl_DStringAppend(dstring, TclGetString(reqv[i]), -1); sl@0: } sl@0: } else { sl@0: Tcl_DStringAppend(dstring, " 0-", -1); sl@0: } sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * AllRequirementSatisfied -- sl@0: * sl@0: * This function checks to see whether a version satisfies at sl@0: * least one of a set of requirements. sl@0: * sl@0: * Results: sl@0: * If the requirements are satisfied 1 is returned. sl@0: * Otherwise 0 is returned. The function assumes sl@0: * that all pieces have valid syntax. And is allowed sl@0: * to make that assumption. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: AllRequirementsSatisfied(availVersionI, reqc, reqv) sl@0: CONST char* availVersionI; /* Candidate version to check against the requirements */ sl@0: int reqc; /* Requirements constraining the desired version. */ sl@0: Tcl_Obj *CONST reqv[]; /* 0 means to use the latest version available. */ sl@0: { sl@0: int i, satisfies; sl@0: sl@0: for (satisfies = i = 0; i < reqc; i++) { sl@0: satisfies = RequirementSatisfied(availVersionI, Tcl_GetString(reqv[i])); sl@0: if (satisfies) break; sl@0: } sl@0: return satisfies; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * RequirementSatisfied -- sl@0: * sl@0: * This function checks to see whether a version satisfies a requirement. sl@0: * sl@0: * Results: sl@0: * If the requirement is satisfied 1 is returned. sl@0: * Otherwise 0 is returned. The function assumes sl@0: * that all pieces have valid syntax. And is allowed sl@0: * to make that assumption. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: RequirementSatisfied(havei, req) sl@0: CONST char *havei; /* Version string, of candidate package we have */ sl@0: CONST char *req; /* Requirement string the candidate has to satisfy */ sl@0: { sl@0: /* The have candidate is already in internal rep. */ sl@0: sl@0: int satisfied, res; sl@0: char* dash = NULL; sl@0: char* buf, *min, *max; sl@0: sl@0: dash = strchr (req, '-'); sl@0: if (dash == NULL) { sl@0: /* No dash found, is a simple version, fallback to regular check. sl@0: * The 'CheckVersionAndConvert' cannot fail. We pad the requirement with sl@0: * 'a0', i.e '-2' before doing the comparison to properly accept sl@0: * unstables as well. sl@0: */ sl@0: sl@0: char* reqi = NULL; sl@0: int thisIsMajor; sl@0: sl@0: CheckVersionAndConvert (NULL, req, &reqi, NULL); sl@0: strcat (reqi, " -2"); sl@0: res = CompareVersions(havei, reqi, &thisIsMajor); sl@0: satisfied = (res == 0) || ((res == 1) && !thisIsMajor); sl@0: Tcl_Free (reqi); sl@0: return satisfied; sl@0: } sl@0: sl@0: /* Exactly one dash is present (Assumption of valid syntax). Copy the req, sl@0: * split at the location of dash and check that both parts are sl@0: * versions. Note that the max part can be empty. sl@0: */ sl@0: sl@0: buf = strdup (req); sl@0: dash = buf + (dash - req); sl@0: *dash = '\0'; /* buf now <=> min part */ sl@0: dash ++; /* dash now <=> max part */ sl@0: sl@0: if (*dash == '\0') { sl@0: /* We have a min, but no max. For the comparison we generate the sl@0: * internal rep, padded with 'a0' i.e. '-2'. sl@0: */ sl@0: sl@0: /* No max part, unbound */ sl@0: sl@0: CheckVersionAndConvert (NULL, buf, &min, NULL); sl@0: strcat (min, " -2"); sl@0: satisfied = (CompareVersions(havei, min, NULL) >= 0); sl@0: Tcl_Free (min); sl@0: free (buf); sl@0: return satisfied; sl@0: } sl@0: sl@0: /* We have both min and max, and generate their internal reps. sl@0: * When identical we compare as is, otherwise we pad with 'a0' sl@0: * to ove the range a bit. sl@0: */ sl@0: sl@0: CheckVersionAndConvert (NULL, buf, &min, NULL); sl@0: CheckVersionAndConvert (NULL, dash, &max, NULL); sl@0: sl@0: if (CompareVersions(min, max, NULL) == 0) { sl@0: satisfied = (CompareVersions(min, havei, NULL) == 0); sl@0: } else { sl@0: strcat (min, " -2"); sl@0: strcat (max, " -2"); sl@0: satisfied = ((CompareVersions(min, havei, NULL) <= 0) && sl@0: (CompareVersions(havei, max, NULL) < 0)); sl@0: } sl@0: sl@0: Tcl_Free (min); sl@0: Tcl_Free (max); sl@0: free (buf); sl@0: return satisfied; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * ExactRequirement -- sl@0: * sl@0: * This function is the core for the translation of -exact requests. sl@0: * It translates the request of the version into a range of versions. sl@0: * The translation was chosen for backwards compatibility. sl@0: * sl@0: * Results: sl@0: * A Tcl_Obj containing the version range as string. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static Tcl_Obj* sl@0: ExactRequirement(version) sl@0: CONST char* version; sl@0: { sl@0: /* A -exact request for a version X.y is translated into the range sl@0: * X.y-X.(y+1). For example -exact 8.4 means the range "8.4-8.5". sl@0: * sl@0: * This translation was chosen to prevent packages which currently use a sl@0: * 'package require -exact tclversion' from being affected by the core now sl@0: * registering itself as 8.4.x (patchlevel) instead of 8.4 sl@0: * (version). Examples are tbcload, compiler, and ITcl. sl@0: * sl@0: * Translating -exact 8.4 to the range "8.4-8.4" instead would require us sl@0: * and everyone else to rebuild these packages to require -exact 8.4.14, sl@0: * or whatever the exact current patchlevel is. A backward compatibility sl@0: * issue with effects similar to the bugfix made in 8.5 now requiring sl@0: * ifneeded and provided versions to match. Instead we have chosen to sl@0: * interpret exactness to not be exactly equal, but to be exact only sl@0: * within the specified level, and allowing variation in the deeper sl@0: * level. More examples: sl@0: * sl@0: * -exact 8 => "8-9" sl@0: * -exact 8.4 => "8.4-8.5" sl@0: * -exact 8.4.14 => "8.4.14-8.4.15" sl@0: * -exact 8.0a2 => "8.0a2-8.0a3" sl@0: */ sl@0: sl@0: char* iv; sl@0: int lc, i; sl@0: CONST char** lv; sl@0: char buf [30]; sl@0: Tcl_Obj* o = Tcl_NewStringObj (version,-1); sl@0: Tcl_AppendStringsToObj (o, "-", NULL); sl@0: sl@0: /* Assuming valid syntax here */ sl@0: CheckVersionAndConvert (NULL, version, &iv, NULL); sl@0: sl@0: /* Split the list into components */ sl@0: Tcl_SplitList (NULL, iv, &lc, &lv); sl@0: sl@0: /* Iterate over the components and make them parts of the result. Except sl@0: * for the last, which is handled separately, to allow the sl@0: * incrementation. sl@0: */ sl@0: sl@0: for (i=0; i < (lc-1); i++) { sl@0: /* Regular component */ sl@0: Tcl_AppendStringsToObj (o, lv[i], NULL); sl@0: /* Separator component */ sl@0: i ++; sl@0: if (0 == strcmp ("-1", lv[i])) { sl@0: Tcl_AppendStringsToObj (o, "b", NULL); sl@0: } else if (0 == strcmp ("-2", lv[i])) { sl@0: Tcl_AppendStringsToObj (o, "a", NULL); sl@0: } else { sl@0: Tcl_AppendStringsToObj (o, ".", NULL); sl@0: } sl@0: } sl@0: /* Regular component, last */ sl@0: sprintf (buf, "%d", atoi (lv [lc-1]) + 1); sl@0: Tcl_AppendStringsToObj (o, buf, NULL); sl@0: sl@0: ckfree ((char*) lv); sl@0: return o; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * VersionCleanupProc -- sl@0: * sl@0: * This function is called to delete the last remember package version sl@0: * string for an interpreter when the interpreter is deleted. It gets sl@0: * invoked via the Tcl AssocData mechanism. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * Storage for the version object for interp get deleted. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static void sl@0: VersionCleanupProc ( sl@0: ClientData clientData, /* Pointer to remembered version string object sl@0: * for interp. */ sl@0: Tcl_Interp *interp) /* Interpreter that is being deleted. */ sl@0: { sl@0: Tcl_Obj* ov = (Tcl_Obj*) clientData; sl@0: if (ov != NULL) { sl@0: Tcl_DecrRefCount (ov); sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * Local Variables: sl@0: * mode: c sl@0: * c-basic-offset: 4 sl@0: * fill-column: 78 sl@0: * End: sl@0: */ sl@0: #endif