diff options
Diffstat (limited to 'generic/tclPkg.c')
| -rw-r--r-- | generic/tclPkg.c | 1589 |
1 files changed, 695 insertions, 894 deletions
diff --git a/generic/tclPkg.c b/generic/tclPkg.c index 940d011..aed80c0 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -1,14 +1,14 @@ -/* +/* * tclPkg.c -- * - * This file implements package and version control for Tcl via - * the "package" command and a few C APIs. + * 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. + * 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 @@ -18,70 +18,60 @@ #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. + * 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. */ + 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). + * 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 + * (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. */ + PkgAvail *availPtr; /* First in list of all available versions of + * this package. */ ClientData clientData; /* Client data. */ } Package; /* - * Prototypes for procedures defined in this file: + * Prototypes for functions defined in this file: */ -#ifndef TCL_TIP268 -static int CheckVersion _ANSI_ARGS_((Tcl_Interp *interp, - CONST char *string)); -static int ComparePkgVersions _ANSI_ARGS_((CONST char *v1, - CONST char *v2, - int *satPtr)); -static Package * FindPackage _ANSI_ARGS_((Tcl_Interp *interp, - CONST char *name)); -#else static int CheckVersionAndConvert(Tcl_Interp *interp, - CONST char *string, char** internal, int* stable); -static int CompareVersions(CONST char *v1i, CONST char *v2i, + 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); + 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 reqx, Tcl_Obj *CONST reqv[], + 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[], ClientData *clientDataPtr); -#endif /* * Helper macros. @@ -94,56 +84,50 @@ static CONST char * PkgRequireCore(Tcl_Interp *interp, CONST char *name, unsigned local__len = (unsigned) (strlen(s) + 1); \ DupBlock((v),(s),local__len); \ } while (0) - /* *---------------------------------------------------------------------- * * Tcl_PkgProvide / Tcl_PkgProvideEx -- * - * This procedure 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. + * 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. + * 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. + * The interpreter remembers that this package is available, so that no + * other version of the package may be provided for the interpreter. * *---------------------------------------------------------------------- */ int -Tcl_PkgProvide(interp, name, version) - Tcl_Interp *interp; /* Interpreter in which package is now +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. */ + const char *name, /* Name of package. */ + const char *version) /* Version string for package. */ { - return Tcl_PkgProvideEx(interp, name, version, (ClientData) NULL); + return Tcl_PkgProvideEx(interp, name, version, NULL); } int -Tcl_PkgProvideEx(interp, name, version, clientData) - Tcl_Interp *interp; /* Interpreter in which package is now +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. */ - ClientData clientData; /* clientdata for this package (normally - * used for C callback function table) */ + const char *name, /* Name of package. */ + const char *version, /* Version string for package. */ + ClientData clientData) /* clientdata for this package (normally used + * for C callback function table) */ { Package *pkgPtr; -#ifdef TCL_TIP268 - char* pvi; - char* vi; + char *pvi, *vi; int res; -#endif pkgPtr = FindPackage(interp, name); if (pkgPtr->version == NULL) { @@ -151,12 +135,11 @@ Tcl_PkgProvideEx(interp, name, version, clientData) pkgPtr->clientData = clientData; return TCL_OK; } -#ifndef TCL_TIP268 - if (ComparePkgVersions(pkgPtr->version, version, (int *) NULL) == 0) { -#else - if (CheckVersionAndConvert (interp, pkgPtr->version, &pvi, NULL) != TCL_OK) { + + if (CheckVersionAndConvert(interp, pkgPtr->version, &pvi, + NULL) != TCL_OK) { return TCL_ERROR; - } else if (CheckVersionAndConvert (interp, version, &vi, NULL) != TCL_OK) { + } else if (CheckVersionAndConvert(interp, version, &vi, NULL) != TCL_OK) { ckfree(pvi); return TCL_ERROR; } @@ -166,14 +149,13 @@ Tcl_PkgProvideEx(interp, name, version, clientData) ckfree(vi); if (res == 0) { -#endif if (clientData != NULL) { pkgPtr->clientData = clientData; } return TCL_OK; } Tcl_AppendResult(interp, "conflicting versions provided for package \"", - name, "\": ", pkgPtr->version, ", then ", version, (char *) NULL); + name, "\": ", pkgPtr->version, ", then ", version, NULL); return TCL_ERROR; } @@ -182,166 +164,134 @@ Tcl_PkgProvideEx(interp, name, version, clientData) * * Tcl_PkgRequire / Tcl_PkgRequireEx / Tcl_PkgRequireProc -- * - * This procedure 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 procedure invokes a Tcl script - * to provide it. If the package is already provided, this - * procedure makes sure that the caller's needs don't conflict with - * the version that is present. + * 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. + * 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. + * The script from some previous "package ifneeded" command may be + * invoked to provide the package. * *---------------------------------------------------------------------- */ -#ifndef TCL_TIP268 -/* - * Empty definition for Stubs when TIP 268 is not activated. - */ -int -Tcl_PkgRequireProc(interp,name,reqc,reqv,clientDataPtr) - Tcl_Interp *interp; /* Interpreter in which package is now - * available. */ - CONST char *name; /* Name of desired package. */ - int reqc; /* Requirements constraining the desired version. */ - Tcl_Obj *CONST reqv[]; /* 0 means to use the latest version available. */ - ClientData *clientDataPtr; -{ - return TCL_ERROR; -} -#endif - -CONST char * -Tcl_PkgRequire(interp, name, version, exact) - Tcl_Interp *interp; /* Interpreter in which package is now +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 + 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 + 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, (ClientData *) NULL); + return Tcl_PkgRequireEx(interp, name, version, exact, NULL); } -CONST char * -Tcl_PkgRequireEx(interp, name, version, exact, clientDataPtr) - 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 +const char * +Tcl_PkgRequireEx( + Tcl_Interp *interp, /* Interpreter in which package is now * available. */ - int exact; /* Non-zero means that only the particular - * version given is acceptable. Zero means - * use the latest compatible version. */ - ClientData *clientDataPtr; /* Used to return the client data for this - * package. If it is NULL then the client - * data is not returned. This is unchanged - * if this call fails for any reason. */ + 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. */ + ClientData *clientDataPtr) /* Used to return the client data for this + * package. If it is NULL then the client data + * is not returned. This is unchanged if this + * call fails for any reason. */ { -#ifndef TCL_TIP268 - Package *pkgPtr; - PkgAvail *availPtr, *bestPtr; - char *script; - int code, satisfies, result, pass; - Tcl_DString command; -#else Tcl_Obj *ov; - CONST char *result = NULL; -#endif + 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 + * 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) { + 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. + * 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. + * 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.) + * 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. + * 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. + * 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_AppendResult(interp, "Cannot load package \"", name, - "\" in standalone executable: This package is not ", - "compiled with stub support", NULL); - return NULL; + Tcl_AppendResult(interp, "Cannot load package \"", name, + "\" in standalone executable: This package is not " + "compiled with stub support", NULL); + return NULL; } -#ifdef TCL_TIP268 - /* Translate between old and new API, and defer to the new function. */ + /* + * Translate between old and new API, and defer to the new function. + */ if (version == NULL) { result = PkgRequireCore(interp, name, 0, NULL, clientDataPtr); @@ -354,9 +304,9 @@ Tcl_PkgRequireEx(interp, name, version, exact, clientDataPtr) if (exact) { Tcl_AppendStringsToObj(ov, "-", version, NULL); } - Tcl_IncrRefCount (ov); + Tcl_IncrRefCount(ov); result = PkgRequireCore(interp, name, 1, &ov, clientDataPtr); - Tcl_DecrRefCount (ov); + TclDecrRefCount(ov); } return result; @@ -364,16 +314,16 @@ Tcl_PkgRequireEx(interp, name, version, exact, clientDataPtr) int Tcl_PkgRequireProc( - Tcl_Interp *interp, /* Interpreter in which package is now + Tcl_Interp *interp, /* Interpreter in which package is now * available. */ - CONST char *name, /* Name of desired package. */ - int reqc, /* Requirements constraining the desired + 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 + Tcl_Obj *const reqv[], /* 0 means to use the latest version * available. */ - ClientData *clientDataPtr) + ClientData *clientDataPtr) { - CONST char *result = + const char *result = PkgRequireCore(interp, name, reqc, reqv, clientDataPtr); if (result == NULL) { @@ -383,28 +333,26 @@ Tcl_PkgRequireProc( return TCL_OK; } -static CONST char * +static const char * PkgRequireCore( - Tcl_Interp *interp, /* Interpreter in which package is now + Tcl_Interp *interp, /* Interpreter in which package is now * available. */ - CONST char *name, /* Name of desired package. */ - int reqc, /* Requirements constraining the desired + 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 + Tcl_Obj *const reqv[], /* 0 means to use the latest version * available. */ - ClientData *clientDataPtr) + ClientData *clientDataPtr) { Interp *iPtr = (Interp *) interp; Package *pkgPtr; PkgAvail *availPtr, *bestPtr, *bestStablePtr; - char *availVersion, *bestVersion; /* Internal rep. of versions */ - int availStable; - char *script; - int code, satisfies, pass; + char *availVersion, *bestVersion; + /* Internal rep. of versions */ + int availStable, code, satisfies, pass; + char *script, *pkgVersionI; Tcl_DString command; - char* pkgVersionI; -#endif /* * 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 @@ -412,45 +360,32 @@ PkgRequireCore( * the "package ifneeded" script. */ - for (pass = 1; ; pass++) { + 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). + /* + * Check whether we're already attempting to load some version of this + * package (circular dependency detection). */ if (pkgPtr->clientData != NULL) { - Tcl_AppendResult(interp, "circular package dependency: ", + Tcl_AppendResult(interp, "circular package dependency: " "attempt to provide ", name, " ", - (char *)(pkgPtr->clientData), " requires ", name, NULL); -#ifndef TCL_TIP268 - if (version != NULL) { - Tcl_AppendResult(interp, " ", version, NULL); - } -#else - AddRequirementsToResult (interp, reqc, reqv); -#endif + (char *) pkgPtr->clientData, " requires ", name, NULL); + AddRequirementsToResult(interp, reqc, reqv); return NULL; } /* * The package isn't yet present. Search the list of available - * versions and invoke the script for the best available version. - * - * For TIP 268 we are actually locating the best, and the best stable - * version. One of them is then chosen based on the selection mode. + * 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. */ -#ifndef TCL_TIP268 - bestPtr = NULL; - for (availPtr = pkgPtr->availPtr; availPtr != NULL; - availPtr = availPtr->nextPtr) { - if ((bestPtr != NULL) && (ComparePkgVersions(availPtr->version, - bestPtr->version, (int *) NULL) <= 0)) { -#else + bestPtr = NULL; bestStablePtr = NULL; bestVersion = NULL; @@ -459,34 +394,32 @@ PkgRequireCore( availPtr = availPtr->nextPtr) { if (CheckVersionAndConvert(interp, availPtr->version, &availVersion, &availStable) != TCL_OK) { - /* The provided version number has invalid syntax. This + /* + * The provided version number has invalid syntax. This * should not happen. This should have been caught by the * 'package ifneeded' registering the package. */ -#endif + continue; } -#ifndef TCL_TIP268 - if (version != NULL) { - result = ComparePkgVersions(availPtr->version, version, - &satisfies); - if ((result != 0) && exact) { -#else + if (bestPtr != NULL) { - int res = CompareVersions (availVersion, bestVersion, NULL); + int res = CompareVersions(availVersion, bestVersion, NULL); + + /* + * Note: Use internal reps! + */ - /* 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; -#endif continue; } -#ifdef TCL_TIP268 } /* We have found a version which is better than our max. */ @@ -495,24 +428,19 @@ PkgRequireCore( /* Check satisfaction of requirements. */ satisfies = SomeRequirementSatisfied(availVersion, reqc, reqv); -#endif if (!satisfies) { -#ifdef TCL_TIP268 ckfree(availVersion); availVersion = NULL; -#endif continue; } } bestPtr = availPtr; -#ifdef TCL_TIP268 if (bestVersion != NULL) { ckfree(bestVersion); } bestVersion = availVersion; - availVersion = NULL; /* * If this new best version is stable then it also has to be @@ -525,10 +453,11 @@ PkgRequireCore( } if (bestVersion != NULL) { - ckfree(bestVersion); + ckfree(bestVersion); } - /* Now choose a version among the two best. For 'latest' we simply + /* + * 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. */ @@ -536,8 +465,8 @@ PkgRequireCore( if ((iPtr->packagePrefer == PKG_PREFER_STABLE) && (bestStablePtr != NULL)) { bestPtr = bestStablePtr; -#endif } + if (bestPtr != NULL) { /* * We found an ifneeded script for the package. Be careful while @@ -546,7 +475,7 @@ PkgRequireCore( * will still exist when the script completes. */ - CONST char *versionToProvide = bestPtr->version; + const char *versionToProvide = bestPtr->version; script = bestPtr->script; pkgPtr->clientData = (ClientData) versionToProvide; @@ -557,60 +486,15 @@ PkgRequireCore( pkgPtr = FindPackage(interp, name); if (code == TCL_OK) { -#ifdef TCL_TIP268 Tcl_ResetResult(interp); -#endif if (pkgPtr->version == NULL) { -#ifndef TCL_TIP268 - Tcl_ResetResult(interp); -#endif code = TCL_ERROR; Tcl_AppendResult(interp, "attempt to provide package ", name, " ", versionToProvide, " failed: no version of package ", name, " provided", NULL); -#ifndef TCL_TIP268 - } else if (0 != ComparePkgVersions( - pkgPtr->version, versionToProvide, NULL)) { - /* At this point, it is clear that a prior - * [package ifneeded] command lied to us. It said - * that to get a particular version of a particular - * package, we needed to evaluate a particular script. - * However, we evaluated that script and got a different - * version than we were told. This is an error, and we - * ought to report it. - * - * However, we've been letting this type of error slide - * for a long time, and as a result, a lot of packages - * suffer from them. - * - * It's a bit too harsh to make a large number of - * existing packages start failing by releasing a - * new patch release, so we forgive this type of error - * for the rest of the Tcl 8.4 series. - * - * We considered reporting a warning, but in practice - * even that appears too harsh a change for a patch release. - * - * We limit the error reporting to only - * the situation where a broken ifneeded script leads - * to a failure to satisfy the requirement. - */ - if (version) { - result = ComparePkgVersions( - pkgPtr->version, version, &satisfies); - if (result && (exact || !satisfies)) { - Tcl_ResetResult(interp); - code = TCL_ERROR; - Tcl_AppendResult(interp, - "attempt to provide package ", name, " ", - versionToProvide, " failed: package ", - name, " ", pkgPtr->version, - " provided instead", NULL); -#else } else { char *pvi, *vi; - int res; if (CheckVersionAndConvert(interp, pkgPtr->version, &pvi, NULL) != TCL_OK) { @@ -620,66 +504,36 @@ PkgRequireCore( ckfree(pvi); code = TCL_ERROR; } else { - res = CompareVersions(pvi, vi, NULL); - ckfree(vi); + int res = CompareVersions(pvi, vi, NULL); + ckfree(pvi); + ckfree(vi); if (res != 0) { - /* At this point, it is clear that a prior - * [package ifneeded] command lied to us. It said - * that to get a particular version of a particular - * package, we needed to evaluate a particular - * script. However, we evaluated that script and - * got a different version than we were told. - * This is an error, and we ought to report it. - * - * However, we've been letting this type of error - * slide for a long time, and as a result, a lot - * of packages suffer from them. - * - * It's a bit too harsh to make a large number of - * existing packages start failing by releasing a - * new patch release, so we forgive this type of - * error for the rest of the Tcl 8.4 series. - * - * We considered reporting a warning, but in - * practice even that appears too harsh a change - * for a patch release. - * - * We limit the error reporting to only the - * situation where a broken ifneeded script leads - * to a failure to satisfy the requirement. - */ - - if (reqc > 0) { - satisfies = SomeRequirementSatisfied(pvi, - reqc, reqv); - if (!satisfies) { - code = TCL_ERROR; - Tcl_AppendResult(interp, - "attempt to provide package ", - name, " ", versionToProvide, - " failed: package ", name, " ", - pkgPtr->version, - " provided instead", NULL); - } - } -#endif + code = TCL_ERROR; + Tcl_AppendResult(interp, + "attempt to provide package ", name, " ", + versionToProvide, " failed: package ", + name, " ", pkgPtr->version, + " provided instead", NULL); } -#ifdef TCL_TIP268 - ckfree(pvi); -#endif } } } else if (code != TCL_ERROR) { Tcl_Obj *codePtr = Tcl_NewIntObj(code); + Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "attempt to provide package ", - name, " ", versionToProvide, " failed: ", - "bad return code: ", Tcl_GetString(codePtr), NULL); - Tcl_DecrRefCount(codePtr); + Tcl_AppendResult(interp, "attempt to provide package ", name, + " ", versionToProvide, " failed: bad return code: ", + TclGetString(codePtr), 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((ClientData) versionToProvide); if (code != TCL_OK) { @@ -688,12 +542,12 @@ PkgRequireCore( * 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 + * 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. */ - Tcl_AddErrorInfo(interp, "\n (\"package ifneeded\" script)"); + if (pkgPtr->version != NULL) { ckfree(pkgPtr->version); pkgPtr->version = NULL; @@ -720,30 +574,23 @@ PkgRequireCore( Tcl_DStringInit(&command); Tcl_DStringAppend(&command, script, -1); Tcl_DStringAppendElement(&command, name); -#ifndef TCL_TIP268 - Tcl_DStringAppend(&command, " ", 1); - Tcl_DStringAppend(&command, (version != NULL) ? version : "{}", - -1); - if (exact) { - Tcl_DStringAppend(&command, " -exact", 7); - } -#else AddRequirementsToDString(&command, reqc, reqv); -#endif + code = Tcl_EvalEx(interp, Tcl_DStringValue(&command), - Tcl_DStringLength(&command), TCL_EVAL_GLOBAL); + Tcl_DStringLength(&command), TCL_EVAL_GLOBAL); Tcl_DStringFree(&command); if ((code != TCL_OK) && (code != TCL_ERROR)) { Tcl_Obj *codePtr = Tcl_NewIntObj(code); Tcl_ResetResult(interp); Tcl_AppendResult(interp, "bad return code: ", - Tcl_GetString(codePtr), NULL); + TclGetString(codePtr), NULL); Tcl_DecrRefCount(codePtr); code = TCL_ERROR; } if (code == TCL_ERROR) { - Tcl_AddErrorInfo(interp, "\n (\"package unknown\" script)"); + Tcl_AddErrorInfo(interp, + "\n (\"package unknown\" script)"); return NULL; } Tcl_ResetResult(interp); @@ -751,14 +598,8 @@ PkgRequireCore( } if (pkgPtr->version == NULL) { - Tcl_AppendResult(interp, "can't find package ", name, (char *) NULL); -#ifndef TCL_TIP268 - if (version != NULL) { - Tcl_AppendResult(interp, " ", version, (char *) NULL); - } -#else + Tcl_AppendResult(interp, "can't find package ", name, NULL); AddRequirementsToResult(interp, reqc, reqv); -#endif return NULL; } @@ -767,13 +608,6 @@ PkgRequireCore( * provided version meets the current requirements. */ -#ifndef TCL_TIP268 - if (version == NULL) { - if (clientDataPtr) { - *clientDataPtr = pkgPtr->clientData; - } - return pkgPtr->version; -#else if (reqc == 0) { satisfies = 1; } else { @@ -781,27 +615,18 @@ PkgRequireCore( satisfies = SomeRequirementSatisfied(pkgVersionI, reqc, reqv); ckfree(pkgVersionI); -#endif } -#ifndef TCL_TIP268 - result = ComparePkgVersions(pkgPtr->version, version, &satisfies); - if ((satisfies && !exact) || (result == 0)) { -#else + if (satisfies) { -#endif if (clientDataPtr) { *clientDataPtr = pkgPtr->clientData; } return pkgPtr->version; } + Tcl_AppendResult(interp, "version conflict for package \"", name, - "\": have ", pkgPtr->version, -#ifndef TCL_TIP268 - ", need ", version, (char *) NULL); -#else - ", need", (char*) NULL); - AddRequirementsToResult (interp, reqc, reqv); -#endif + "\": have ", pkgPtr->version, ", need", NULL); + AddRequirementsToResult(interp, reqc, reqv); return NULL; } @@ -810,16 +635,15 @@ PkgRequireCore( * * Tcl_PkgPresent / Tcl_PkgPresentEx -- * - * Checks to see whether the specified package is present. If it - * is not then no additional action is taken. + * 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. + * 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. @@ -827,36 +651,34 @@ PkgRequireCore( *---------------------------------------------------------------------- */ -CONST char * -Tcl_PkgPresent(interp, name, version, exact) - Tcl_Interp *interp; /* Interpreter in which package is now +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. */ + 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, (ClientData *) NULL); + return Tcl_PkgPresentEx(interp, name, version, exact, NULL); } -CONST char * -Tcl_PkgPresentEx(interp, name, version, exact, clientDataPtr) - 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 +const char * +Tcl_PkgPresentEx( + Tcl_Interp *interp, /* Interpreter in which package is now * available. */ - int exact; /* Non-zero means that only the particular - * version given is acceptable. Zero means - * use the latest compatible version. */ - ClientData *clientDataPtr; /* Used to return the client data for this - * package. If it is NULL then the client - * data is not returned. This is unchanged - * if this call fails for any reason. */ + 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. */ + ClientData *clientDataPtr) /* Used to return the client data for this + * package. If it is NULL then the client data + * is not returned. This is unchanged if this + * call fails for any reason. */ { Interp *iPtr = (Interp *) interp; Tcl_HashEntry *hPtr; @@ -864,17 +686,22 @@ Tcl_PkgPresentEx(interp, name, version, exact, clientDataPtr) hPtr = Tcl_FindHashEntry(&iPtr->packageTable, name); if (hPtr) { - pkgPtr = (Package *) Tcl_GetHashValue(hPtr); + pkgPtr = Tcl_GetHashValue(hPtr); if (pkgPtr->version != NULL) { - /* - * At this point we know that the package is present. Make sure + * 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. */ - return Tcl_PkgRequireEx(interp, name, version, exact, - clientDataPtr); + const char *foundVersion = Tcl_PkgRequireEx(interp, name, version, + exact, clientDataPtr); + + if (foundVersion == NULL) { + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PACKAGE", name, + NULL); + } + return foundVersion; } } @@ -884,6 +711,7 @@ Tcl_PkgPresentEx(interp, name, version, exact, clientDataPtr) } else { Tcl_AppendResult(interp, "package ", name, " is not present", NULL); } + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PACKAGE", name, NULL); return NULL; } @@ -892,8 +720,8 @@ Tcl_PkgPresentEx(interp, name, version, exact, clientDataPtr) * * Tcl_PackageObjCmd -- * - * This procedure is invoked to process the "package" Tcl command. - * See the user documentation for details on what it does. + * 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. @@ -904,29 +732,23 @@ Tcl_PkgPresentEx(interp, name, version, exact, clientDataPtr) *---------------------------------------------------------------------- */ -/* ARGSUSED */ + /* ARGSUSED */ int -Tcl_PackageObjCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +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 *pkgOptions[] = { - "forget", "ifneeded", "names", -#ifdef TCL_TIP268 - "prefer", -#endif - "present", "provide", "require", "unknown", "vcompare", - "versions", "vsatisfies", (char *) NULL + static const char *pkgOptions[] = { + "forget", "ifneeded", "names", "prefer", "present", + "provide", "require", "unknown", "vcompare", "versions", + "vsatisfies", NULL }; enum pkgOptions { - PKG_FORGET, PKG_IFNEEDED, PKG_NAMES, -#ifdef TCL_TIP268 - PKG_PREFER, -#endif - PKG_PRESENT, PKG_PROVIDE, PKG_REQUIRE, PKG_UNKNOWN, PKG_VCOMPARE, - PKG_VERSIONS, PKG_VSATISFIES + 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; @@ -935,32 +757,29 @@ Tcl_PackageObjCmd(dummy, interp, objc, objv) Tcl_HashEntry *hPtr; Tcl_HashSearch search; Tcl_HashTable *tablePtr; - CONST char *version; - char *argv2, *argv3, *argv4; -#ifdef TCL_TIP268 - char* iva = NULL; - char* ivb = NULL; -#endif + const char *version; + char *argv2, *argv3, *argv4, *iva = NULL, *ivb = NULL; if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?"); + Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?"); return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[1], pkgOptions, "option", 0, - &optionIndex) != TCL_OK) { + &optionIndex) != TCL_OK) { return TCL_ERROR; } switch ((enum pkgOptions) optionIndex) { case PKG_FORGET: { char *keyString; + for (i = 2; i < objc; i++) { - keyString = Tcl_GetString(objv[i]); + keyString = TclGetString(objv[i]); hPtr = Tcl_FindHashEntry(&iPtr->packageTable, keyString); if (hPtr == NULL) { - continue; + continue; } - pkgPtr = (Package *) Tcl_GetHashValue(hPtr); + pkgPtr = Tcl_GetHashValue(hPtr); Tcl_DeleteHashEntry(hPtr); if (pkgPtr->version != NULL) { ckfree(pkgPtr->version); @@ -977,43 +796,32 @@ Tcl_PackageObjCmd(dummy, interp, objc, objv) break; } case PKG_IFNEEDED: { - int length; -#ifdef TCL_TIP268 - int res; + int length, res; char *argv3i, *avi; -#endif if ((objc != 4) && (objc != 5)) { Tcl_WrongNumArgs(interp, 2, objv, "package version ?script?"); return TCL_ERROR; } - argv3 = Tcl_GetString(objv[3]); -#ifdef TCL_TIP268 + argv3 = TclGetString(objv[3]); if (CheckVersionAndConvert(interp, argv3, &argv3i, NULL) != TCL_OK) { -#else - if (CheckVersion(interp, argv3) != TCL_OK) { -#endif return TCL_ERROR; } - argv2 = Tcl_GetString(objv[2]); + argv2 = TclGetString(objv[2]); if (objc == 4) { hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2); if (hPtr == NULL) { -#ifdef TCL_TIP268 ckfree(argv3i); -#endif return TCL_OK; } - pkgPtr = (Package *) Tcl_GetHashValue(hPtr); + 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) { - -#ifdef TCL_TIP268 + prevPtr = availPtr, availPtr = availPtr->nextPtr) { if (CheckVersionAndConvert(interp, availPtr->version, &avi, NULL) != TCL_OK) { ckfree(argv3i); @@ -1024,14 +832,8 @@ Tcl_PackageObjCmd(dummy, interp, objc, objv) ckfree(avi); if (res == 0){ -#else - if (ComparePkgVersions(availPtr->version, argv3, (int *) NULL) - == 0) { -#endif if (objc == 4) { -#ifdef TCL_TIP268 ckfree(argv3i); -#endif Tcl_SetResult(interp, availPtr->script, TCL_VOLATILE); return TCL_OK; } @@ -1039,9 +841,8 @@ Tcl_PackageObjCmd(dummy, interp, objc, objv) break; } } -#ifdef TCL_TIP268 ckfree(argv3i); -#endif + if (objc == 4) { return TCL_OK; } @@ -1061,27 +862,26 @@ Tcl_PackageObjCmd(dummy, interp, objc, objv) DupBlock(availPtr->script, argv4, (unsigned) length + 1); break; } - case PKG_NAMES: { + case PKG_NAMES: if (objc != 2) { Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; } tablePtr = &iPtr->packageTable; for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL; - hPtr = Tcl_NextHashEntry(&search)) { - pkgPtr = (Package *) Tcl_GetHashValue(hPtr); + hPtr = Tcl_NextHashEntry(&search)) { + pkgPtr = Tcl_GetHashValue(hPtr); if ((pkgPtr->version != NULL) || (pkgPtr->availPtr != NULL)) { Tcl_AppendElement(interp, Tcl_GetHashKey(tablePtr, hPtr)); } } break; - } case PKG_PRESENT: { - CONST char *name; + const char *name; if (objc < 3) { goto require; } - argv2 = Tcl_GetString(objv[2]); + argv2 = TclGetString(objv[2]); if ((argv2[0] == '-') && (strcmp(argv2, "-exact") == 0)) { if (objc != 5) { goto requireSyntax; @@ -1100,138 +900,98 @@ Tcl_PackageObjCmd(dummy, interp, objc, objv) goto require; } } -#ifndef TCL_TIP268 - version = NULL; - if (objc == (4 + exact)) { - version = Tcl_GetString(objv[3 + exact]); - if (CheckVersion(interp, version) != TCL_OK) { - return TCL_ERROR; - } - } else if ((objc != 3) || exact) { - goto requireSyntax; - } -#else + version = NULL; if (exact) { - version = Tcl_GetString(objv[4]); - if (CheckVersionAndConvert(interp, version, NULL, NULL) != TCL_OK) { + 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]); } } -#endif Tcl_PkgPresent(interp, name, version, exact); return TCL_ERROR; break; } - case PKG_PROVIDE: { + case PKG_PROVIDE: if ((objc != 3) && (objc != 4)) { Tcl_WrongNumArgs(interp, 2, objv, "package ?version?"); return TCL_ERROR; } - argv2 = Tcl_GetString(objv[2]); + argv2 = TclGetString(objv[2]); if (objc == 3) { hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2); if (hPtr != NULL) { - pkgPtr = (Package *) Tcl_GetHashValue(hPtr); + pkgPtr = Tcl_GetHashValue(hPtr); if (pkgPtr->version != NULL) { Tcl_SetResult(interp, pkgPtr->version, TCL_VOLATILE); } } return TCL_OK; } - argv3 = Tcl_GetString(objv[3]); -#ifndef TCL_TIP268 - if (CheckVersion(interp, argv3) != TCL_OK) { -#else + argv3 = TclGetString(objv[3]); if (CheckVersionAndConvert(interp, argv3, NULL, NULL) != TCL_OK) { -#endif return TCL_ERROR; } return Tcl_PkgProvide(interp, argv2, argv3); - } - case PKG_REQUIRE: { + case PKG_REQUIRE: require: if (objc < 3) { requireSyntax: -#ifndef TCL_TIP268 - Tcl_WrongNumArgs(interp, 2, objv, "?-exact? package ?version?"); -#else Tcl_WrongNumArgs(interp, 2, objv, "?-exact? package ?requirement...?"); -#endif return TCL_ERROR; } -#ifndef TCL_TIP268 - argv2 = Tcl_GetString(objv[2]); - if ((argv2[0] == '-') && (strcmp(argv2, "-exact") == 0)) { - exact = 1; - } else { - exact = 0; - } - version = NULL; - if (objc == (4 + exact)) { - version = Tcl_GetString(objv[3 + exact]); - if (CheckVersion(interp, version) != TCL_OK) { - return TCL_ERROR; - } - } else if ((objc != 3) || exact) { - goto requireSyntax; - } - if (exact) { - argv3 = Tcl_GetString(objv[3]); - version = Tcl_PkgRequire(interp, argv3, version, exact); - } else { - version = Tcl_PkgRequire(interp, argv2, version, exact); - } - if (version == NULL) { - return TCL_ERROR; - } - Tcl_SetObjResult( interp, Tcl_NewStringObj( version, -1 ) ); -#else + version = NULL; - argv2 = Tcl_GetString(objv[2]); + + argv2 = TclGetString(objv[2]); if ((argv2[0] == '-') && (strcmp(argv2, "-exact") == 0)) { - Tcl_Obj* ov; + Tcl_Obj *ov; int res; if (objc != 5) { goto requireSyntax; } - version = Tcl_GetString(objv[4]); - if (CheckVersionAndConvert(interp, version, NULL, NULL) != TCL_OK) { + + version = TclGetString(objv[4]); + if (CheckVersionAndConvert(interp, version, NULL, + NULL) != TCL_OK) { return TCL_ERROR; } - /* Create a new-style requirement for the exact version. */ + /* + * Create a new-style requirement for the exact version. + */ ov = Tcl_NewStringObj(version, -1); Tcl_AppendStringsToObj(ov, "-", version, NULL); version = NULL; - argv3 = Tcl_GetString(objv[3]); + argv3 = TclGetString(objv[3]); - Tcl_IncrRefCount (ov); + Tcl_IncrRefCount(ov); res = Tcl_PkgRequireProc(interp, argv3, 1, &ov, NULL); - Tcl_DecrRefCount (ov); + TclDecrRefCount(ov); return res; } else { - if (CheckAllRequirements (interp, objc-3, objv+3) != TCL_OK) { + if (CheckAllRequirements(interp, objc-3, objv+3) != TCL_OK) { return TCL_ERROR; } + return Tcl_PkgRequireProc(interp, argv2, objc-3, objv+3, NULL); } -#endif break; - } case PKG_UNKNOWN: { int length; + if (objc == 2) { if (iPtr->packageUnknown != NULL) { Tcl_SetResult(interp, iPtr->packageUnknown, TCL_VOLATILE); @@ -1244,7 +1004,7 @@ Tcl_PackageObjCmd(dummy, interp, objc, objv) if (argv2[0] == 0) { iPtr->packageUnknown = NULL; } else { - DupBlock(iPtr->packageUnknown, argv2, (unsigned) length + 1); + DupBlock(iPtr->packageUnknown, argv2, (unsigned) length+1); } } else { Tcl_WrongNumArgs(interp, 2, objv, "?command?"); @@ -1252,85 +1012,89 @@ Tcl_PackageObjCmd(dummy, interp, objc, objv) } break; } -#ifdef TCL_TIP268 case PKG_PREFER: { - /* See tclInt.h for the enum, just before Interp */ - static CONST char *pkgPreferOptions[] = { + static const char *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) { - /* Set value. */ - int new; + /* + * Seting the value. + */ + + int newPref; + if (Tcl_GetIndexFromObj(interp, objv[2], pkgPreferOptions, - "preference", 0, &new) != TCL_OK) { + "preference", 0, &newPref) != TCL_OK) { return TCL_ERROR; } - if (new < iPtr->packagePrefer) { - iPtr->packagePrefer = new; + + if (newPref < iPtr->packagePrefer) { + iPtr->packagePrefer = newPref; } } - /* Always return current value. */ + + /* + * Always return current value. + */ + Tcl_SetObjResult(interp, Tcl_NewStringObj(pkgPreferOptions[iPtr->packagePrefer], -1)); break; } -#endif - case PKG_VCOMPARE: { + case PKG_VCOMPARE: if (objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "version1 version2"); return TCL_ERROR; } - argv3 = Tcl_GetString(objv[3]); - argv2 = Tcl_GetString(objv[2]); -#ifndef TCL_TIP268 - if ((CheckVersion(interp, argv2) != TCL_OK) - || (CheckVersion(interp, argv3) != TCL_OK)) { - return TCL_ERROR; - } - Tcl_SetObjResult(interp, Tcl_NewIntObj( - ComparePkgVersions(argv2, argv3, (int *) NULL))); -#else - if ((CheckVersionAndConvert (interp, argv2, &iva, NULL) != TCL_OK) - || (CheckVersionAndConvert (interp, argv3, &ivb, NULL) - != TCL_OK)) { + 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 */ + + /* + * ivb cannot be set in this branch. + */ + return TCL_ERROR; } - /* Comparison is done on the internal representation */ + /* + * Comparison is done on the internal representation. + */ + Tcl_SetObjResult(interp, Tcl_NewIntObj(CompareVersions(iva, ivb, NULL))); ckfree(iva); ckfree(ivb); -#endif break; - } - case PKG_VERSIONS: { + case PKG_VERSIONS: if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "package"); return TCL_ERROR; } - argv2 = Tcl_GetString(objv[2]); + argv2 = TclGetString(objv[2]); hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2); if (hPtr != NULL) { - pkgPtr = (Package *) Tcl_GetHashValue(hPtr); + pkgPtr = Tcl_GetHashValue(hPtr); for (availPtr = pkgPtr->availPtr; availPtr != NULL; - availPtr = availPtr->nextPtr) { + availPtr = availPtr->nextPtr) { Tcl_AppendElement(interp, availPtr->version); } } break; - } case PKG_VSATISFIES: { -#ifdef TCL_TIP268 - char* argv2i = NULL; + char *argv2i = NULL; if (objc < 4) { Tcl_WrongNumArgs(interp, 2, objv, @@ -1338,8 +1102,8 @@ Tcl_PackageObjCmd(dummy, interp, objc, objv) return TCL_ERROR; } - argv2 = Tcl_GetString(objv[2]); - if ((CheckVersionAndConvert(interp, argv2, &argv2i, NULL) != TCL_OK)) { + 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); @@ -1347,27 +1111,13 @@ Tcl_PackageObjCmd(dummy, interp, objc, objv) } satisfies = SomeRequirementSatisfied(argv2i, objc-3, objv+3); - ckfree (argv2i); -#else - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "version1 version2"); - return TCL_ERROR; - } - argv3 = Tcl_GetString(objv[3]); - argv2 = Tcl_GetString(objv[2]); - if ((CheckVersion(interp, argv2) != TCL_OK) - || (CheckVersion(interp, argv3) != TCL_OK)) { - return TCL_ERROR; - } - ComparePkgVersions(argv2, argv3, &satisfies); -#endif + ckfree(argv2i); - Tcl_SetObjResult(interp, Tcl_NewIntObj(satisfies)); + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(satisfies)); break; } - default: { - panic("Tcl_PackageObjCmd: bad option index to pkgOptions"); - } + default: + Tcl_Panic("Tcl_PackageObjCmd: bad option index to pkgOptions"); } return TCL_OK; } @@ -1377,13 +1127,12 @@ Tcl_PackageObjCmd(dummy, interp, objc, objv) * * FindPackage -- * - * This procedure finds the Package record for a particular package - * in a particular interpreter, creating a record if one doesn't - * already exist. + * 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. + * The return value is a pointer to the Package record for the package. * * Side effects: * A new Package record may be created. @@ -1392,24 +1141,24 @@ Tcl_PackageObjCmd(dummy, interp, objc, objv) */ static Package * -FindPackage(interp, name) - Tcl_Interp *interp; /* Interpreter to use for package lookup. */ - CONST char *name; /* Name of package to fine. */ +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 new; + int isNew; Package *pkgPtr; - hPtr = Tcl_CreateHashEntry(&iPtr->packageTable, name, &new); - if (new) { + hPtr = Tcl_CreateHashEntry(&iPtr->packageTable, name, &isNew); + if (isNew) { pkgPtr = (Package *) ckalloc(sizeof(Package)); pkgPtr->version = NULL; pkgPtr->availPtr = NULL; pkgPtr->clientData = NULL; Tcl_SetHashValue(hPtr, pkgPtr); } else { - pkgPtr = (Package *) Tcl_GetHashValue(hPtr); + pkgPtr = Tcl_GetHashValue(hPtr); } return pkgPtr; } @@ -1419,9 +1168,8 @@ FindPackage(interp, name) * * TclFreePackageInfo -- * - * This procedure is called during interpreter deletion to - * free all of the package-related information for the - * interpreter. + * This function is called during interpreter deletion to free all of the + * package-related information for the interpreter. * * Results: * None. @@ -1433,8 +1181,8 @@ FindPackage(interp, name) */ void -TclFreePackageInfo(iPtr) - Interp *iPtr; /* Interpreter that is being deleted. */ +TclFreePackageInfo( + Interp *iPtr) /* Interpereter that is being deleted. */ { Package *pkgPtr; Tcl_HashSearch search; @@ -1442,8 +1190,8 @@ TclFreePackageInfo(iPtr) PkgAvail *availPtr; for (hPtr = Tcl_FirstHashEntry(&iPtr->packageTable, &search); - hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { - pkgPtr = (Package *) Tcl_GetHashValue(hPtr); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + pkgPtr = Tcl_GetHashValue(hPtr); if (pkgPtr->version != NULL) { ckfree(pkgPtr->version); } @@ -1465,15 +1213,16 @@ TclFreePackageInfo(iPtr) /* *---------------------------------------------------------------------- * - * CheckVersion / CheckVersionAndConvert -- + * CheckVersionAndConvert -- * - * This procedure checks to see whether a version number has - * valid syntax. + * 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. + * 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. @@ -1481,60 +1230,31 @@ TclFreePackageInfo(iPtr) *---------------------------------------------------------------------- */ -#ifndef TCL_TIP268 static int -CheckVersion(interp, string) - Tcl_Interp *interp; /* Used for error reporting. */ - CONST char *string; /* Supposedly a version number, which is - * groups of decimal digits separated - * by dots. */ -{ - CONST char *p = string; - char prevChar; - if (!isdigit(UCHAR(*p))) { /* INTL: digit */ - goto error; - } - for (prevChar = *p, p++; *p != 0; p++) { - if (!isdigit(UCHAR(*p)) && - ((*p != '.') || (prevChar == '.'))) { /* INTL: digit */ - goto error; - } - prevChar = *p; - } - if (prevChar != '.') { - return TCL_OK; - } - - error: - Tcl_AppendResult(interp, "expected version number but got \"", - string, "\"", (char *) NULL); - return TCL_ERROR; -} -#else -static int -CheckVersionAndConvert(interp, string, internal, stable) - Tcl_Interp *interp; /* Used for error reporting. */ - CONST char *string; /* Supposedly a version number, which is +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. */ + char **internal, /* Internal normalized representation */ + int *stable) /* Flag: Version is (un)stable. */ { - CONST char *p = string; + 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; + char *ibuf = ckalloc(4 + 4*strlen(string)); + char *ip = ibuf; - /* Basic rules + /* + * 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 '.' @@ -1543,20 +1263,23 @@ CheckVersionAndConvert(interp, string, internal, stable) * (5) Neither 'a', nor 'b' may occur before or after a '.' */ - if (!isdigit(UCHAR(*p))) { /* INTL: digit */ + if (!isdigit(UCHAR(*p))) { /* INTL: digit */ goto error; } + *ip++ = *p; + for (prevChar = *p, p++; *p != 0; p++) { - if ((!isdigit(UCHAR(*p))) && (((*p != '.') && (*p != 'a') - && (*p != 'b')) || ((hasunstable && ((*p == 'a') - || (*p == 'b'))) || (((prevChar == 'a') || (prevChar == 'b') - || (prevChar == '.')) && (*p == '.')) || (((*p == 'a') - || (*p == 'b') || (*p == '.')) && (prevChar == '.'))))) { - /* INTL: digit */ + 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')) { + + if (*p == 'a' || *p == 'b') { hasunstable = 1; } @@ -1583,9 +1306,10 @@ CheckVersionAndConvert(interp, string, internal, stable) } else { *ip++ = *p; } + prevChar = *p; } - if ((prevChar != '.') && (prevChar != 'a') && (prevChar != 'b')) { + if (prevChar!='.' && prevChar!='a' && prevChar!='b') { *ip = '\0'; if (internal != NULL) { *internal = ibuf; @@ -1598,27 +1322,25 @@ CheckVersionAndConvert(interp, string, internal, stable) return TCL_OK; } - error: + error: ckfree(ibuf); - Tcl_AppendResult(interp, "expected version number but got \"", - string, "\"", (char *) NULL); + Tcl_AppendResult(interp, "expected version number but got \"", string, + "\"", NULL); return TCL_ERROR; } -#endif /* *---------------------------------------------------------------------- * - * ComparePkgVersions / CompareVersions -- + * CompareVersions -- * - * This procedure compares two version numbers. (268: in internal rep). + * 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. + * 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. @@ -1626,142 +1348,157 @@ CheckVersionAndConvert(interp, string, internal, stable) *---------------------------------------------------------------------- */ -#ifndef TCL_TIP268 static int -ComparePkgVersions(v1, v2, satPtr) - CONST char *v1; - CONST char *v2; /* Versions strings, of form 2.1.3 (any - * number of version numbers). */ - int *satPtr; /* If non-null, the word pointed to is - * filled in with a 0/1 value. 1 means - * v1 "satisfies" v2: v1 is greater than - * or equal to v2 and both version numbers - * have the same major number. */ +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, n1, n2; + 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. */ + /* + * Parse one decimal number from the front of each string. Skip + * leading zeros. Terminate found number for upcoming string-wise + * comparison, if needed. + */ - n1 = n2 = 0; - while ((*v1 != 0) && (*v1 != '.')) { - n1 = 10*n1 + (*v1 - '0'); - v1++; + while ((*s1 != 0) && (*s1 == '0')) { + s1++; } - while ((*v2 != 0) && (*v2 != '.')) { - n2 = 10*n2 + (*v2 - '0'); - v2++; + while ((*s2 != 0) && (*s2 == '0')) { + s2++; } /* - * Compare and go on to the next version number if the current numbers - * match. + * 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 (n1 != n2) { + if ((*s1 == '-') && (*s2 != '-')) { + /* s1 < 0, s2 >= 0 => s1 < s2 */ + res = -1; break; } - if (*v1 != 0) { - v1++; - } else if (*v2 == 0) { + if ((*s1 != '-') && (*s2 == '-')) { + /* s1 >= 0, s2 < 0 => s1 > s2 */ + res = 1; break; } - if (*v2 != 0) { - v2++; + + if ((*s1 == '-') && (*s2 == '-')) { + /* a < b => -a > -b, etc. */ + s1++; + s2++; + flip = 1; + } else { + flip = 0; } - thisIsMajor = 0; - } - if (satPtr != NULL) { - *satPtr = (n1 == n2) || ((n1 > n2) && !thisIsMajor); - } - if (n1 > n2) { - return 1; - } else if (n1 == n2) { - return 0; - } else { - return -1; - } -} -#else -static int -CompareVersions(v1, v2, isMajorPtr) - CONST char *v1; /* Versions strings, of form 2.1.3 (any number */ - CONST char *v2; /* 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, n1, n2; - int res, flip; - /* - * 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. - */ + /* + * The string comparison is needed, so now we determine where the + * numbers end. + */ - thisIsMajor = 1; - while (1) { - /* Parse one decimal number from the front of each string. */ - - n1 = n2 = 0; - flip = 0; - while ((*v1 != 0) && (*v1 != ' ')) { - if (*v1 == '-') {flip = 1 ; v1++ ; continue;} - n1 = 10*n1 + (*v1 - '0'); - v1++; + e1 = s1; + while ((*e1 != 0) && (*e1 != ' ')) { + e1++; + } + e2 = s2; + while ((*e2 != 0) && (*e2 != ' ')) { + e2++; } - if (flip) n1 = -n1; - flip = 0; - while ((*v2 != 0) && (*v2 != ' ')) { - if (*v2 == '-') {flip = 1; v2++ ; continue;} - n2 = 10*n2 + (*v2 - '0'); - v2++; + + /* + * 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; } - if (flip) n2 = -n2; /* - * Compare and go on to the next version number if the current numbers - * match. + * Stop comparing segments when a difference has been found. Here we + * may have to flip the result to account for signs. */ - if (n1 != n2) { + if (res != 0) { + if (flip) { + res = -res; + } break; } - if (*v1 != 0) { - v1++; - } else if (*v2 == 0) { + + /* + * 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 (*v2 != 0) { - v2++; + if (*s2 != 0) { + s2++; } thisIsMajor = 0; } - if (n1 > n2) { - res = 1; - } else if (n1 == n2) { - res = 0; - } else { - res = -1; - } if (isMajorPtr != NULL) { *isMajorPtr = thisIsMajor; @@ -1775,13 +1512,12 @@ CompareVersions(v1, v2, isMajorPtr) * * CheckAllRequirements -- * - * This function checks to see whether all requirements in a set - * have valid syntax. + * 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. + * 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. @@ -1790,14 +1526,15 @@ CompareVersions(v1, v2, isMajorPtr) */ static int -CheckAllRequirements(interp, reqc, reqv) - Tcl_Interp* interp; - int reqc; /* Requirements to check. */ - Tcl_Obj *CONST reqv[]; +CheckAllRequirements( + Tcl_Interp *interp, + int reqc, /* Requirements to check. */ + Tcl_Obj *const reqv[]) { int i; + for (i = 0; i < reqc; i++) { - if ((CheckRequirement(interp, Tcl_GetString(reqv[i])) != TCL_OK)) { + if ((CheckRequirement(interp, TclGetString(reqv[i])) != TCL_OK)) { return TCL_ERROR; } } @@ -1823,43 +1560,52 @@ CheckAllRequirements(interp, reqc, reqv) */ static int -CheckRequirement(interp, string) - Tcl_Interp *interp; /* Used for error reporting. */ - CONST char *string; /* Supposedly a requirement. */ +CheckRequirement( + Tcl_Interp *interp, /* Used for error reporting. */ + const char *string) /* Supposedly a requirement. */ { - /* Syntax of requirement = version - * = version-version - * = version- + /* + * Syntax of requirement = version + * = version-version + * = version- */ - char* dash = NULL; - char* buf; + char *dash = NULL, *buf; - dash = strchr (string, '-'); + dash = strchr(string, '-'); if (dash == NULL) { - /* no dash found, has to be a simple version */ - return CheckVersionAndConvert (interp, string, NULL, 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. */ + + if (strchr(dash+1, '-') != NULL) { + /* + * More dashes found after the first. This is wrong. + */ + Tcl_AppendResult(interp, "expected versionMin-versionMax but got \"", string, "\"", NULL); return TCL_ERROR; } - /* Exactly one dash is present. Copy the string, split at the location of + /* + * 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. + * 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 */ + 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))) { + if ((CheckVersionAndConvert(interp, buf, NULL, NULL) != TCL_OK) || + ((*dash != '\0') && + (CheckVersionAndConvert(interp, dash, NULL, NULL) != TCL_OK))) { ckfree(buf); return TCL_ERROR; } @@ -1885,20 +1631,23 @@ CheckRequirement(interp, string) */ static void -AddRequirementsToResult(interp, reqc, reqv) - Tcl_Interp* interp; - int reqc; /* Requirements constraining the desired version. */ - Tcl_Obj *CONST reqv[]; /* 0 means use the latest version available. */ +AddRequirementsToResult( + Tcl_Interp *interp, + int reqc, /* Requirements constraining the desired + * version. */ + Tcl_Obj *const reqv[]) /* 0 means to use the latest version + * available. */ { if (reqc > 0) { int i; + for (i = 0; i < reqc; i++) { int length; char *v = Tcl_GetStringFromObj(reqv[i], &length); if ((length & 0x1) && (v[length/2] == '-') && (strncmp(v, v+((length+1)/2), length/2) == 0)) { - Tcl_AppendResult(interp, " ", v+((length+1)/2), NULL); + Tcl_AppendResult(interp, " exactly ", v+((length+1)/2), NULL); } else { Tcl_AppendResult(interp, " ", v, NULL); } @@ -1923,19 +1672,22 @@ AddRequirementsToResult(interp, reqc, reqv) */ static void -AddRequirementsToDString(dstring, reqc, reqv) - Tcl_DString* dstring; - int reqc; /* Requirements constraining the desired version. */ - Tcl_Obj *CONST reqv[]; /* 0 means use the latest version available. */ +AddRequirementsToDString( + Tcl_DString *dsPtr, + int reqc, /* Requirements constraining the desired + * version. */ + Tcl_Obj *const reqv[]) /* 0 means to use the latest version + * available. */ { if (reqc > 0) { int i; + for (i = 0; i < reqc; i++) { - Tcl_DStringAppend(dstring, " ", 1); - Tcl_DStringAppend(dstring, TclGetString(reqv[i]), -1); + Tcl_DStringAppend(dsPtr, " ", 1); + Tcl_DStringAppend(dsPtr, TclGetString(reqv[i]), -1); } } else { - Tcl_DStringAppend(dstring, " 0-", -1); + Tcl_DStringAppend(dsPtr, " 0-", -1); } } @@ -1944,14 +1696,13 @@ AddRequirementsToDString(dstring, reqc, reqv) * * SomeRequirementSatisfied -- * - * This function checks to see whether a version satisfies at - * least one of a set of requirements. + * 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. + * 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. @@ -1960,17 +1711,18 @@ AddRequirementsToDString(dstring, reqc, reqv) */ static int -SomeRequirementSatisfied(availVersionI, reqc, reqv) - char *availVersionI; /* Candidate version to check against the +SomeRequirementSatisfied( + char *availVersionI, /* Candidate version to check against the * requirements. */ - int reqc; /* Requirements constraining the desired + int reqc, /* Requirements constraining the desired * version. */ - Tcl_Obj *CONST reqv[]; /* 0 means use the latest version available. */ + Tcl_Obj *const reqv[]) /* 0 means to use the latest version + * available. */ { int i; for (i = 0; i < reqc; i++) { - if (RequirementSatisfied(availVersionI, Tcl_GetString(reqv[i]))) { + if (RequirementSatisfied(availVersionI, TclGetString(reqv[i]))) { return 1; } } @@ -1985,10 +1737,9 @@ SomeRequirementSatisfied(availVersionI, reqc, reqv) * 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. + * 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. @@ -1997,75 +1748,80 @@ SomeRequirementSatisfied(availVersionI, reqc, reqv) */ static int -RequirementSatisfied(havei, req) - char *havei; /* Version string, of candidate package we have */ - CONST char *req; /* Requirement string the candidate has to satisfy */ +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. */ + /* + * The have candidate is already in internal rep. + */ int satisfied, res; - char* dash = NULL; - char* buf, *min, *max; + char *dash = NULL, *buf, *min, *max; - dash = strchr (req, '-'); + 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 + /* + * 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; + char *reqi = NULL; int thisIsMajor; - CheckVersionAndConvert (NULL, req, &reqi, NULL); - strcat (reqi, " -2"); + 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. + /* + * 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 */ + 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 + /* + * We have a min, but no max. For the comparison we generate the * internal rep, padded with 'a0' i.e. '-2'. */ - /* No max part, unbound */ - - CheckVersionAndConvert (NULL, buf, &min, NULL); - strcat (min, " -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. + /* + * 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); + 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"); + strcat(min, " -2"); + strcat(max, " -2"); satisfied = ((CompareVersions(min, havei, NULL) <= 0) && - (CompareVersions(havei, max, NULL) < 0)); + (CompareVersions(havei, max, NULL) < 0)); } ckfree(min); @@ -2075,10 +1831,55 @@ RequirementSatisfied(havei, req) } /* + *---------------------------------------------------------------------- + * + * 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: */ -#endif |