diff options
Diffstat (limited to 'generic/tclPkg.c')
| -rw-r--r-- | generic/tclPkg.c | 1706 |
1 files changed, 938 insertions, 768 deletions
diff --git a/generic/tclPkg.c b/generic/tclPkg.c index fdaea57..940d011 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,60 +18,70 @@ #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. */ - const void *clientData; /* Client data. */ + PkgAvail *availPtr; /* First in list of all available versions + * of this package. */ + ClientData clientData; /* Client data. */ } Package; /* - * Prototypes for functions defined in this file: + * Prototypes for procedures 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(char *v1i, char *v2i, + CONST char *string, char** internal, int* stable); +static int CompareVersions(CONST char *v1i, CONST 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 reqc, Tcl_Obj *const reqv[], - void *clientDataPtr); + 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[], + ClientData *clientDataPtr); +#endif /* * Helper macros. @@ -84,50 +94,56 @@ 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 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. + * 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. * * 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( - Tcl_Interp *interp, /* Interpreter in which package is now +Tcl_PkgProvide(interp, name, version) + 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, NULL); + return Tcl_PkgProvideEx(interp, name, version, (ClientData) NULL); } int -Tcl_PkgProvideEx( - Tcl_Interp *interp, /* Interpreter in which package is now +Tcl_PkgProvideEx(interp, name, version, clientData) + Tcl_Interp *interp; /* Interpreter in which package is now * available. */ - const char *name, /* Name of package. */ - const char *version, /* Version string for package. */ - const void *clientData) /* clientdata for this package (normally used - * for C callback function table) */ + 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; - char *pvi, *vi; +#ifdef TCL_TIP268 + char* pvi; + char* vi; int res; +#endif pkgPtr = FindPackage(interp, name); if (pkgPtr->version == NULL) { @@ -135,11 +151,12 @@ Tcl_PkgProvideEx( pkgPtr->clientData = clientData; return TCL_OK; } - - if (CheckVersionAndConvert(interp, pkgPtr->version, &pvi, - NULL) != TCL_OK) { +#ifndef TCL_TIP268 + if (ComparePkgVersions(pkgPtr->version, version, (int *) NULL) == 0) { +#else + 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; } @@ -149,14 +166,14 @@ Tcl_PkgProvideEx( 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, NULL); - Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT", NULL); + name, "\": ", pkgPtr->version, ", then ", version, (char *) NULL); return TCL_ERROR; } @@ -165,135 +182,166 @@ Tcl_PkgProvideEx( * * Tcl_PkgRequire / Tcl_PkgRequireEx / Tcl_PkgRequireProc -- * - * This function is called by code that depends on a particular version - * of a particular package. If the package is not already provided in the - * interpreter, this function invokes a Tcl script to provide it. If the - * package is already provided, this function makes sure that the - * caller's needs don't conflict with the version that is present. + * 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. * * 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. * *---------------------------------------------------------------------- */ -const char * -Tcl_PkgRequire( - Tcl_Interp *interp, /* Interpreter in which package is now +#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. */ - 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. */ + int reqc; /* Requirements constraining the desired version. */ + Tcl_Obj *CONST reqv[]; /* 0 means to use the latest version available. */ + ClientData *clientDataPtr; { - return Tcl_PkgRequireEx(interp, name, version, exact, NULL); + return TCL_ERROR; } +#endif -const char * -Tcl_PkgRequireEx( - Tcl_Interp *interp, /* Interpreter in which package is now +CONST char * +Tcl_PkgRequire(interp, name, version, exact) + 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. */ - void *clientDataPtr) /* Used to return the client data for this - * package. If it is NULL then the client data - * is not returned. This is unchanged if this - * call fails for any reason. */ { + return Tcl_PkgRequireEx(interp, name, version, exact, (ClientData *) 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 + * 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; + CONST char *result = NULL; +#endif /* * 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) { + /* * 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); - Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNSTUBBED", NULL); - return NULL; + Tcl_AppendResult(interp, "Cannot load package \"", name, + "\" in standalone executable: This package is not ", + "compiled with stub support", NULL); + return NULL; } - /* - * Translate between old and new API, and defer to the new function. - */ +#ifdef TCL_TIP268 + /* Translate between old and new API, and defer to the new function. */ if (version == NULL) { result = PkgRequireCore(interp, name, 0, NULL, clientDataPtr); @@ -306,9 +354,9 @@ Tcl_PkgRequireEx( if (exact) { Tcl_AppendStringsToObj(ov, "-", version, NULL); } - Tcl_IncrRefCount(ov); + Tcl_IncrRefCount (ov); result = PkgRequireCore(interp, name, 1, &ov, clientDataPtr); - TclDecrRefCount(ov); + Tcl_DecrRefCount (ov); } return result; @@ -316,16 +364,16 @@ Tcl_PkgRequireEx( 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. */ - void *clientDataPtr) + ClientData *clientDataPtr) { - const char *result = + CONST char *result = PkgRequireCore(interp, name, reqc, reqv, clientDataPtr); if (result == NULL) { @@ -335,26 +383,28 @@ 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. */ - void *clientDataPtr) + ClientData *clientDataPtr) { Interp *iPtr = (Interp *) interp; Package *pkgPtr; PkgAvail *availPtr, *bestPtr, *bestStablePtr; - char *availVersion, *bestVersion; - /* Internal rep. of versions */ - int availStable, code, satisfies, pass; - char *script, *pkgVersionI; + char *availVersion, *bestVersion; /* Internal rep. of versions */ + int availStable; + char *script; + int code, satisfies, pass; 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 @@ -362,33 +412,45 @@ 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); - AddRequirementsToResult(interp, reqc, reqv); - Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "CIRCULARITY", NULL); + (char *)(pkgPtr->clientData), " requires ", name, NULL); +#ifndef TCL_TIP268 + if (version != NULL) { + Tcl_AppendResult(interp, " ", version, NULL); + } +#else + AddRequirementsToResult (interp, reqc, reqv); +#endif return NULL; } /* * The package isn't yet present. Search the list of available - * versions and invoke the script for the best available version. We - * are actually locating the best, and the best stable version. One of - * them is then chosen based on the selection mode. + * 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. */ - +#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; @@ -397,55 +459,60 @@ 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); - - /* - * Note: Use internal reps! - */ + int res = CompareVersions (availVersion, bestVersion, NULL); + /* Note: Use internal reps! */ if (res <= 0) { /* * The version of the package sought is not as good as the * currently selected version. Ignore it. */ - ckfree(availVersion); availVersion = NULL; +#endif continue; } +#ifdef TCL_TIP268 } - /* - * We have found a version which is better than our max. - */ + /* We have found a version which is better than our max. */ if (reqc > 0) { /* 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 @@ -458,11 +525,10 @@ 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. */ @@ -470,8 +536,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 @@ -480,28 +546,71 @@ PkgRequireCore( * will still exist when the script completes. */ - char *versionToProvide = bestPtr->version; + CONST char *versionToProvide = bestPtr->version; script = bestPtr->script; - pkgPtr->clientData = versionToProvide; - Tcl_Preserve(script); - Tcl_Preserve(versionToProvide); + pkgPtr->clientData = (ClientData) versionToProvide; + Tcl_Preserve((ClientData) script); + Tcl_Preserve((ClientData) versionToProvide); code = Tcl_EvalEx(interp, script, -1, TCL_EVAL_GLOBAL); - Tcl_Release(script); + Tcl_Release((ClientData) script); 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); - Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNPROVIDED", - 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) { @@ -511,40 +620,67 @@ PkgRequireCore( ckfree(pvi); code = TCL_ERROR; } else { - int res = CompareVersions(pvi, vi, NULL); - - ckfree(pvi); + res = CompareVersions(pvi, vi, NULL); ckfree(vi); + if (res != 0) { - code = TCL_ERROR; - Tcl_AppendResult(interp, - "attempt to provide package ", name, " ", - versionToProvide, " failed: package ", - name, " ", pkgPtr->version, - " provided instead", NULL); - Tcl_SetErrorCode(interp, "TCL", "PACKAGE", - "WRONGPROVIDE", 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 (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 } +#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: ", - TclGetString(codePtr), NULL); - Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL); - TclDecrRefCount(codePtr); + Tcl_AppendResult(interp, "attempt to provide package ", + name, " ", versionToProvide, " failed: ", + "bad return code: ", Tcl_GetString(codePtr), NULL); + Tcl_DecrRefCount(codePtr); code = TCL_ERROR; } - if (code == TCL_ERROR) { - Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (\"package ifneeded %s %s\" script)", - name, versionToProvide)); - } - Tcl_Release(versionToProvide); + Tcl_Release((ClientData) versionToProvide); if (code != TCL_OK) { /* @@ -552,12 +688,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; @@ -584,25 +720,30 @@ 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: ", - TclGetString(codePtr), NULL); - Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL); + Tcl_GetString(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); @@ -610,9 +751,14 @@ PkgRequireCore( } if (pkgPtr->version == NULL) { - Tcl_AppendResult(interp, "can't find package ", name, NULL); - Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNFOUND", NULL); + Tcl_AppendResult(interp, "can't find package ", name, (char *) NULL); +#ifndef TCL_TIP268 + if (version != NULL) { + Tcl_AppendResult(interp, " ", version, (char *) NULL); + } +#else AddRequirementsToResult(interp, reqc, reqv); +#endif return NULL; } @@ -621,28 +767,42 @@ PkgRequireCore( * provided version meets the current requirements. */ - if (reqc != 0) { +#ifndef TCL_TIP268 + if (version == NULL) { + if (clientDataPtr) { + *clientDataPtr = pkgPtr->clientData; + } + return pkgPtr->version; +#else + if (reqc == 0) { + satisfies = 1; + } else { CheckVersionAndConvert(interp, pkgPtr->version, &pkgVersionI, NULL); satisfies = SomeRequirementSatisfied(pkgVersionI, reqc, reqv); ckfree(pkgVersionI); - - if (!satisfies) { - Tcl_AppendResult(interp, "version conflict for package \"", name, - "\": have ", pkgPtr->version, ", need", NULL); - Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT", - NULL); - AddRequirementsToResult(interp, reqc, reqv); - return NULL; - } +#endif } - - if (clientDataPtr) { - const void **ptr = (const void **) clientDataPtr; - - *ptr = pkgPtr->clientData; +#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; } - 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 + return NULL; } /* @@ -650,15 +810,16 @@ 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. @@ -666,34 +827,36 @@ PkgRequireCore( *---------------------------------------------------------------------- */ -const char * -Tcl_PkgPresent( - Tcl_Interp *interp, /* Interpreter in which package is now +CONST char * +Tcl_PkgPresent(interp, name, version, exact) + 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, NULL); + return Tcl_PkgPresentEx(interp, name, version, exact, (ClientData *) NULL); } -const char * -Tcl_PkgPresentEx( - Tcl_Interp *interp, /* Interpreter in which package is now +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 available. */ - int exact, /* Non-zero means that only the particular - * version given is acceptable. Zero means use - * the latest compatible version. */ - void *clientDataPtr) /* Used to return the client data for this - * package. If it is NULL then the client data - * is not returned. This is unchanged if this - * call fails for any reason. */ + 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; @@ -701,22 +864,17 @@ Tcl_PkgPresentEx( hPtr = Tcl_FindHashEntry(&iPtr->packageTable, name); if (hPtr) { - pkgPtr = Tcl_GetHashValue(hPtr); + pkgPtr = (Package *) 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. */ - const char *foundVersion = Tcl_PkgRequireEx(interp, name, version, - exact, clientDataPtr); - - if (foundVersion == NULL) { - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PACKAGE", name, - NULL); - } - return foundVersion; + return Tcl_PkgRequireEx(interp, name, version, exact, + clientDataPtr); } } @@ -726,7 +884,6 @@ Tcl_PkgPresentEx( } else { Tcl_AppendResult(interp, "package ", name, " is not present", NULL); } - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PACKAGE", name, NULL); return NULL; } @@ -735,8 +892,8 @@ Tcl_PkgPresentEx( * * Tcl_PackageObjCmd -- * - * This function is invoked to process the "package" Tcl command. See the - * user documentation for details on what it does. + * This procedure is invoked to process the "package" Tcl command. + * See the user documentation for details on what it does. * * Results: * A standard Tcl result. @@ -747,23 +904,29 @@ Tcl_PkgPresentEx( *---------------------------------------------------------------------- */ - /* ARGSUSED */ +/* ARGSUSED */ int -Tcl_PackageObjCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ +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. */ { - static const char *const pkgOptions[] = { - "forget", "ifneeded", "names", "prefer", "present", - "provide", "require", "unknown", "vcompare", "versions", - "vsatisfies", NULL + static CONST char *pkgOptions[] = { + "forget", "ifneeded", "names", +#ifdef TCL_TIP268 + "prefer", +#endif + "present", "provide", "require", "unknown", "vcompare", + "versions", "vsatisfies", (char *) NULL }; enum pkgOptions { - PKG_FORGET, PKG_IFNEEDED, PKG_NAMES, PKG_PREFER, PKG_PRESENT, - PKG_PROVIDE, PKG_REQUIRE, PKG_UNKNOWN, PKG_VCOMPARE, PKG_VERSIONS, - PKG_VSATISFIES + 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 }; Interp *iPtr = (Interp *) interp; int optionIndex, exact, i, satisfies; @@ -772,30 +935,32 @@ Tcl_PackageObjCmd( Tcl_HashEntry *hPtr; Tcl_HashSearch search; Tcl_HashTable *tablePtr; - const char *version; - const char *argv2, *argv3, *argv4; - char *iva = NULL, *ivb = NULL; + CONST char *version; + char *argv2, *argv3, *argv4; +#ifdef TCL_TIP268 + char* iva = NULL; + char* ivb = NULL; +#endif if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "option ?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: { - const char *keyString; - + char *keyString; for (i = 2; i < objc; i++) { - keyString = TclGetString(objv[i]); + keyString = Tcl_GetString(objv[i]); hPtr = Tcl_FindHashEntry(&iPtr->packageTable, keyString); if (hPtr == NULL) { - continue; + continue; } - pkgPtr = Tcl_GetHashValue(hPtr); + pkgPtr = (Package *) Tcl_GetHashValue(hPtr); Tcl_DeleteHashEntry(hPtr); if (pkgPtr->version != NULL) { ckfree(pkgPtr->version); @@ -803,41 +968,52 @@ Tcl_PackageObjCmd( while (pkgPtr->availPtr != NULL) { availPtr = pkgPtr->availPtr; pkgPtr->availPtr = availPtr->nextPtr; - Tcl_EventuallyFree(availPtr->version, TCL_DYNAMIC); - Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC); - ckfree(availPtr); + Tcl_EventuallyFree((ClientData)availPtr->version, TCL_DYNAMIC); + Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC); + ckfree((char *) availPtr); } - ckfree(pkgPtr); + ckfree((char *) pkgPtr); } break; } case PKG_IFNEEDED: { - int length, res; + int length; +#ifdef TCL_TIP268 + int res; char *argv3i, *avi; +#endif if ((objc != 4) && (objc != 5)) { Tcl_WrongNumArgs(interp, 2, objv, "package version ?script?"); return TCL_ERROR; } - argv3 = TclGetString(objv[3]); + argv3 = Tcl_GetString(objv[3]); +#ifdef TCL_TIP268 if (CheckVersionAndConvert(interp, argv3, &argv3i, NULL) != TCL_OK) { +#else + if (CheckVersion(interp, argv3) != TCL_OK) { +#endif return TCL_ERROR; } - argv2 = TclGetString(objv[2]); + argv2 = Tcl_GetString(objv[2]); if (objc == 4) { hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2); if (hPtr == NULL) { +#ifdef TCL_TIP268 ckfree(argv3i); +#endif return TCL_OK; } - pkgPtr = Tcl_GetHashValue(hPtr); + pkgPtr = (Package *) 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) { + prevPtr = availPtr, availPtr = availPtr->nextPtr) { + +#ifdef TCL_TIP268 if (CheckVersionAndConvert(interp, availPtr->version, &avi, NULL) != TCL_OK) { ckfree(argv3i); @@ -848,22 +1024,29 @@ Tcl_PackageObjCmd( 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; } - Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC); + Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC); break; } } +#ifdef TCL_TIP268 ckfree(argv3i); - +#endif if (objc == 4) { return TCL_OK; } if (availPtr == NULL) { - availPtr = ckalloc(sizeof(PkgAvail)); + availPtr = (PkgAvail *) ckalloc(sizeof(PkgAvail)); DupBlock(availPtr->version, argv3, (unsigned) length + 1); if (prevPtr == NULL) { @@ -878,33 +1061,27 @@ Tcl_PackageObjCmd( 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; - } else { - Tcl_Obj *resultObj; - - resultObj = Tcl_NewObj(); - tablePtr = &iPtr->packageTable; - for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL; - hPtr = Tcl_NextHashEntry(&search)) { - pkgPtr = Tcl_GetHashValue(hPtr); - if ((pkgPtr->version != NULL) || (pkgPtr->availPtr != NULL)) { - Tcl_ListObjAppendElement(NULL,resultObj, Tcl_NewStringObj( - Tcl_GetHashKey(tablePtr, hPtr), -1)); - } + } + tablePtr = &iPtr->packageTable; + for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL; + hPtr = Tcl_NextHashEntry(&search)) { + pkgPtr = (Package *) Tcl_GetHashValue(hPtr); + if ((pkgPtr->version != NULL) || (pkgPtr->availPtr != NULL)) { + Tcl_AppendElement(interp, Tcl_GetHashKey(tablePtr, hPtr)); } - Tcl_SetObjResult(interp, resultObj); } break; + } case PKG_PRESENT: { - const char *name; - + CONST char *name; if (objc < 3) { goto require; } - argv2 = TclGetString(objv[2]); + argv2 = Tcl_GetString(objv[2]); if ((argv2[0] == '-') && (strcmp(argv2, "-exact") == 0)) { if (objc != 5) { goto requireSyntax; @@ -923,98 +1100,138 @@ Tcl_PackageObjCmd( 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 = TclGetString(objv[4]); - if (CheckVersionAndConvert(interp, version, NULL, - NULL) != TCL_OK) { + version = Tcl_GetString(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 = TclGetString(objv[2]); + argv2 = Tcl_GetString(objv[2]); if (objc == 3) { hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2); if (hPtr != NULL) { - pkgPtr = Tcl_GetHashValue(hPtr); + pkgPtr = (Package *) Tcl_GetHashValue(hPtr); if (pkgPtr->version != NULL) { Tcl_SetResult(interp, pkgPtr->version, TCL_VOLATILE); } } return TCL_OK; } - argv3 = TclGetString(objv[3]); + argv3 = Tcl_GetString(objv[3]); +#ifndef TCL_TIP268 + if (CheckVersion(interp, argv3) != TCL_OK) { +#else 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 ...?"); + "?-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; - - argv2 = TclGetString(objv[2]); + 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]); if ((argv2[0] == '-') && (strcmp(argv2, "-exact") == 0)) { - Tcl_Obj *ov; + Tcl_Obj* ov; int res; if (objc != 5) { goto requireSyntax; } - - version = TclGetString(objv[4]); - if (CheckVersionAndConvert(interp, version, NULL, - NULL) != TCL_OK) { + version = Tcl_GetString(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 = TclGetString(objv[3]); + argv3 = Tcl_GetString(objv[3]); - Tcl_IncrRefCount(ov); + Tcl_IncrRefCount (ov); res = Tcl_PkgRequireProc(interp, argv3, 1, &ov, NULL); - TclDecrRefCount(ov); + Tcl_DecrRefCount (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); @@ -1027,7 +1244,7 @@ Tcl_PackageObjCmd( 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?"); @@ -1035,102 +1252,94 @@ Tcl_PackageObjCmd( } break; } +#ifdef TCL_TIP268 case PKG_PREFER: { - static const char *const pkgPreferOptions[] = { + /* See tclInt.h for the enum, just before Interp */ + 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) { - /* - * Seting the value. - */ - - int newPref; - + /* Set value. */ + int new; if (Tcl_GetIndexFromObj(interp, objv[2], pkgPreferOptions, - "preference", 0, &newPref) != TCL_OK) { + "preference", 0, &new) != TCL_OK) { return TCL_ERROR; } - - if (newPref < iPtr->packagePrefer) { - iPtr->packagePrefer = newPref; + if (new < iPtr->packagePrefer) { + iPtr->packagePrefer = new; } } - - /* - * Always return current value. - */ - + /* Always return current value. */ Tcl_SetObjResult(interp, Tcl_NewStringObj(pkgPreferOptions[iPtr->packagePrefer], -1)); break; } - case PKG_VCOMPARE: +#endif + case PKG_VCOMPARE: { if (objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "version1 version2"); return TCL_ERROR; } - argv3 = TclGetString(objv[3]); - argv2 = TclGetString(objv[2]); - if (CheckVersionAndConvert(interp, argv2, &iva, NULL) != TCL_OK || - CheckVersionAndConvert(interp, argv3, &ivb, NULL) != TCL_OK) { + 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)) { 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; - } else { - Tcl_Obj *resultObj = Tcl_NewObj(); - - argv2 = TclGetString(objv[2]); - hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2); - if (hPtr != NULL) { - pkgPtr = Tcl_GetHashValue(hPtr); - for (availPtr = pkgPtr->availPtr; availPtr != NULL; - availPtr = availPtr->nextPtr) { - Tcl_ListObjAppendElement(NULL, resultObj, - Tcl_NewStringObj(availPtr->version, -1)); - } + } + argv2 = Tcl_GetString(objv[2]); + hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2); + if (hPtr != NULL) { + pkgPtr = (Package *) Tcl_GetHashValue(hPtr); + for (availPtr = pkgPtr->availPtr; availPtr != NULL; + availPtr = availPtr->nextPtr) { + Tcl_AppendElement(interp, availPtr->version); } - Tcl_SetObjResult(interp, resultObj); } break; + } case PKG_VSATISFIES: { - char *argv2i = NULL; +#ifdef TCL_TIP268 + char* argv2i = NULL; if (objc < 4) { - Tcl_WrongNumArgs(interp, 2, objv, "version ?requirement ...?"); + Tcl_WrongNumArgs(interp, 2, objv, + "version requirement requirement..."); return TCL_ERROR; } - argv2 = TclGetString(objv[2]); - if (CheckVersionAndConvert(interp, argv2, &argv2i, NULL) != TCL_OK) { + argv2 = Tcl_GetString(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); @@ -1138,13 +1347,27 @@ Tcl_PackageObjCmd( } satisfies = SomeRequirementSatisfied(argv2i, objc-3, objv+3); - ckfree(argv2i); + 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 - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(satisfies)); + Tcl_SetObjResult(interp, Tcl_NewIntObj(satisfies)); break; } - default: - Tcl_Panic("Tcl_PackageObjCmd: bad option index to pkgOptions"); + default: { + panic("Tcl_PackageObjCmd: bad option index to pkgOptions"); + } } return TCL_OK; } @@ -1154,12 +1377,13 @@ Tcl_PackageObjCmd( * * FindPackage -- * - * This function finds the Package record for a particular package in a - * particular interpreter, creating a record if one doesn't already - * exist. + * This procedure 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. @@ -1168,24 +1392,24 @@ Tcl_PackageObjCmd( */ static Package * -FindPackage( - Tcl_Interp *interp, /* Interpreter to use for package lookup. */ - const char *name) /* Name of package to fine. */ +FindPackage(interp, name) + Tcl_Interp *interp; /* Interpreter to use for package lookup. */ + CONST char *name; /* Name of package to fine. */ { Interp *iPtr = (Interp *) interp; Tcl_HashEntry *hPtr; - int isNew; + int new; Package *pkgPtr; - hPtr = Tcl_CreateHashEntry(&iPtr->packageTable, name, &isNew); - if (isNew) { - pkgPtr = ckalloc(sizeof(Package)); + hPtr = Tcl_CreateHashEntry(&iPtr->packageTable, name, &new); + if (new) { + pkgPtr = (Package *) ckalloc(sizeof(Package)); pkgPtr->version = NULL; pkgPtr->availPtr = NULL; pkgPtr->clientData = NULL; Tcl_SetHashValue(hPtr, pkgPtr); } else { - pkgPtr = Tcl_GetHashValue(hPtr); + pkgPtr = (Package *) Tcl_GetHashValue(hPtr); } return pkgPtr; } @@ -1195,8 +1419,9 @@ FindPackage( * * TclFreePackageInfo -- * - * This function is called during interpreter deletion to free all of the - * package-related information for the interpreter. + * This procedure is called during interpreter deletion to + * free all of the package-related information for the + * interpreter. * * Results: * None. @@ -1208,8 +1433,8 @@ FindPackage( */ void -TclFreePackageInfo( - Interp *iPtr) /* Interpereter that is being deleted. */ +TclFreePackageInfo(iPtr) + Interp *iPtr; /* Interpreter that is being deleted. */ { Package *pkgPtr; Tcl_HashSearch search; @@ -1217,19 +1442,19 @@ TclFreePackageInfo( PkgAvail *availPtr; for (hPtr = Tcl_FirstHashEntry(&iPtr->packageTable, &search); - hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { - pkgPtr = Tcl_GetHashValue(hPtr); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + pkgPtr = (Package *) Tcl_GetHashValue(hPtr); if (pkgPtr->version != NULL) { ckfree(pkgPtr->version); } while (pkgPtr->availPtr != NULL) { availPtr = pkgPtr->availPtr; pkgPtr->availPtr = availPtr->nextPtr; - Tcl_EventuallyFree(availPtr->version, TCL_DYNAMIC); - Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC); - ckfree(availPtr); + Tcl_EventuallyFree((ClientData)availPtr->version, TCL_DYNAMIC); + Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC); + ckfree((char *) availPtr); } - ckfree(pkgPtr); + ckfree((char *) pkgPtr); } Tcl_DeleteHashTable(&iPtr->packageTable); if (iPtr->packageUnknown != NULL) { @@ -1240,16 +1465,15 @@ TclFreePackageInfo( /* *---------------------------------------------------------------------- * - * CheckVersionAndConvert -- + * CheckVersion / CheckVersionAndConvert -- * - * This function checks to see whether a version number has valid syntax. - * It also generates a semi-internal representation (string rep of a list - * of numbers). + * This procedure checks to see whether a version number has + * valid syntax. * * 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. @@ -1257,31 +1481,60 @@ TclFreePackageInfo( *---------------------------------------------------------------------- */ +#ifndef TCL_TIP268 static int -CheckVersionAndConvert( - Tcl_Interp *interp, /* Used for error reporting. */ - const char *string, /* Supposedly a version number, which is +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 * 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 '.' @@ -1290,23 +1543,20 @@ CheckVersionAndConvert( * (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)) && /* INTL: digit */ - ((*p!='.' && *p!='a' && *p!='b') || - ((hasunstable && (*p=='a' || *p=='b')) || - ((prevChar=='a' || prevChar=='b' || prevChar=='.') - && (*p=='.')) || - ((*p=='a' || *p=='b' || *p=='.') && prevChar=='.')))) { + 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 */ goto error; } - - if (*p == 'a' || *p == 'b') { + if ((*p == 'a') || (*p == 'b')) { hasunstable = 1; } @@ -1333,10 +1583,9 @@ CheckVersionAndConvert( } else { *ip++ = *p; } - prevChar = *p; } - if (prevChar!='.' && prevChar!='a' && prevChar!='b') { + if ((prevChar != '.') && (prevChar != 'a') && (prevChar != 'b')) { *ip = '\0'; if (internal != NULL) { *internal = ibuf; @@ -1349,26 +1598,27 @@ CheckVersionAndConvert( return TCL_OK; } - error: + error: ckfree(ibuf); - Tcl_AppendResult(interp, "expected version number but got \"", string, - "\"", NULL); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "VERSION", NULL); + Tcl_AppendResult(interp, "expected version number but got \"", + string, "\"", (char *) NULL); return TCL_ERROR; } +#endif /* *---------------------------------------------------------------------- * - * CompareVersions -- + * ComparePkgVersions / CompareVersions -- * - * This function compares two version numbers (in internal rep). + * This procedure compares two version numbers. (268: 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. @@ -1376,157 +1626,142 @@ CheckVersionAndConvert( *---------------------------------------------------------------------- */ +#ifndef TCL_TIP268 static int -CompareVersions( - char *v1, char *v2, /* Versions strings, of form 2.1.3 (any number - * of version numbers). */ - int *isMajorPtr) /* If non-null, the word pointed to is filled - * in with a 0/1 value. 1 means that the - * difference occured in the first element. */ +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. */ { - int thisIsMajor, res, flip; - char *s1, *e1, *s2, *e2, o1, o2; + int thisIsMajor, n1, n2; /* * Each iteration of the following loop processes one number from each * string, terminated by a " " (space). If those numbers don't match then * the comparison is over; otherwise, we loop back for the next number. - * - * TIP 268. - * This is identical the function 'ComparePkgVersion', but using the new - * space separator as used by the internal rep of version numbers. The - * special separators 'a' and 'b' have already been dealt with in - * 'CheckVersionAndConvert', they were translated into numbers as well. - * This keeps the comparison sane. Otherwise we would have to compare - * numerics, the separators, and also deal with the special case of - * end-of-string compared to separators. The semi-list rep we get here is - * much easier to handle, as it is still regular. - * - * Rewritten to not compute a numeric value for the extracted version - * number, but do string comparison. Skip any leading zeros for that to - * work. This change breaks through the 32bit-limit on version numbers. */ thisIsMajor = 1; - s1 = v1; - s2 = v2; - while (1) { - /* - * Parse one decimal number from the front of each string. Skip - * leading zeros. Terminate found number for upcoming string-wise - * comparison, if needed. - */ + /* Parse one decimal number from the front of each string. */ - while ((*s1 != 0) && (*s1 == '0')) { - s1++; + n1 = n2 = 0; + while ((*v1 != 0) && (*v1 != '.')) { + n1 = 10*n1 + (*v1 - '0'); + v1++; } - while ((*s2 != 0) && (*s2 == '0')) { - s2++; + while ((*v2 != 0) && (*v2 != '.')) { + n2 = 10*n2 + (*v2 - '0'); + v2++; } /* - * 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. + * Compare and go on to the next version number if the current numbers + * match. */ - if ((*s1 == '-') && (*s2 != '-')) { - /* s1 < 0, s2 >= 0 => s1 < s2 */ - res = -1; + if (n1 != n2) { break; } - if ((*s1 != '-') && (*s2 == '-')) { - /* s1 >= 0, s2 < 0 => s1 > s2 */ - res = 1; + if (*v1 != 0) { + v1++; + } else if (*v2 == 0) { break; } - - if ((*s1 == '-') && (*s2 == '-')) { - /* a < b => -a > -b, etc. */ - s1++; - s2++; - flip = 1; - } else { - flip = 0; + if (*v2 != 0) { + v2++; } + 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; - /* - * The string comparison is needed, so now we determine where the - * numbers end. - */ + /* + * 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. + */ - e1 = s1; - while ((*e1 != 0) && (*e1 != ' ')) { - e1++; + 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++; } - 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++; } + if (flip) n2 = -n2; /* - * 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. + * Compare and go on to the next version number if the current numbers + * match. */ - if ((e1-s1) < (e2-s2)) { - res = -1; - } else if ((e2-s2) < (e1-s1)) { - res = 1; - } else { - o1 = *e1; - *e1 = '\0'; - o2 = *e2; - *e2 = '\0'; - - res = strcmp(s1, s2); - res = (res < 0) ? -1 : (res ? 1 : 0); - - *e1 = o1; - *e2 = o2; - } - - /* - * Stop comparing segments when a difference has been found. Here we - * may have to flip the result to account for signs. - */ - - if (res != 0) { - if (flip) { - res = -res; - } + if (n1 != n2) { break; } - - /* - * Go on to the next version number if the current numbers match. - * However stop processing if the end of both numbers has been - * reached. - */ - - s1 = e1; - s2 = e2; - - if (*s1 != 0) { - s1++; - } else if (*s2 == 0) { - /* - * s1, s2 both at the end => identical - */ - - res = 0; + if (*v1 != 0) { + v1++; + } else if (*v2 == 0) { break; } - if (*s2 != 0) { - s2++; + if (*v2 != 0) { + v2++; } thisIsMajor = 0; } + if (n1 > n2) { + res = 1; + } else if (n1 == n2) { + res = 0; + } else { + res = -1; + } if (isMajorPtr != NULL) { *isMajorPtr = thisIsMajor; @@ -1540,12 +1775,13 @@ CompareVersions( * * 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. @@ -1554,15 +1790,14 @@ CompareVersions( */ static int -CheckAllRequirements( - Tcl_Interp *interp, - int reqc, /* Requirements to check. */ - Tcl_Obj *const reqv[]) +CheckAllRequirements(interp, reqc, reqv) + Tcl_Interp* interp; + int reqc; /* Requirements to check. */ + Tcl_Obj *CONST reqv[]; { int i; - for (i = 0; i < reqc; i++) { - if ((CheckRequirement(interp, TclGetString(reqv[i])) != TCL_OK)) { + if ((CheckRequirement(interp, Tcl_GetString(reqv[i])) != TCL_OK)) { return TCL_ERROR; } } @@ -1588,53 +1823,43 @@ CheckAllRequirements( */ static int -CheckRequirement( - Tcl_Interp *interp, /* Used for error reporting. */ - const char *string) /* Supposedly a requirement. */ +CheckRequirement(interp, string) + 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, *buf; + char* dash = NULL; + char* 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); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "VERSIONRANGE", 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. Also note that the string allocated with strdup() must be - * freed with free() and not ckfree(). + * be empty. */ 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; } @@ -1660,23 +1885,20 @@ CheckRequirement( */ static void -AddRequirementsToResult( - Tcl_Interp *interp, - int reqc, /* Requirements constraining the desired - * version. */ - Tcl_Obj *const reqv[]) /* 0 means to use the latest version - * available. */ +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. */ { if (reqc > 0) { int i; - for (i = 0; i < reqc; i++) { int length; - const char *v = Tcl_GetStringFromObj(reqv[i], &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, " exactly ", v+((length+1)/2), NULL); + Tcl_AppendResult(interp, " ", v+((length+1)/2), NULL); } else { Tcl_AppendResult(interp, " ", v, NULL); } @@ -1701,22 +1923,19 @@ AddRequirementsToResult( */ static void -AddRequirementsToDString( - Tcl_DString *dsPtr, - int reqc, /* Requirements constraining the desired - * version. */ - Tcl_Obj *const reqv[]) /* 0 means to use the latest version - * available. */ +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. */ { if (reqc > 0) { int i; - for (i = 0; i < reqc; i++) { - Tcl_DStringAppend(dsPtr, " ", 1); - Tcl_DStringAppend(dsPtr, TclGetString(reqv[i]), -1); + Tcl_DStringAppend(dstring, " ", 1); + Tcl_DStringAppend(dstring, TclGetString(reqv[i]), -1); } } else { - Tcl_DStringAppend(dsPtr, " 0-", -1); + Tcl_DStringAppend(dstring, " 0-", -1); } } @@ -1725,13 +1944,14 @@ AddRequirementsToDString( * * 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. @@ -1740,18 +1960,17 @@ AddRequirementsToDString( */ static int -SomeRequirementSatisfied( - char *availVersionI, /* Candidate version to check against the +SomeRequirementSatisfied(availVersionI, reqc, reqv) + 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 to use the latest version - * available. */ + Tcl_Obj *CONST reqv[]; /* 0 means use the latest version available. */ { int i; for (i = 0; i < reqc; i++) { - if (RequirementSatisfied(availVersionI, TclGetString(reqv[i]))) { + if (RequirementSatisfied(availVersionI, Tcl_GetString(reqv[i]))) { return 1; } } @@ -1766,9 +1985,10 @@ SomeRequirementSatisfied( * 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. @@ -1777,80 +1997,75 @@ SomeRequirementSatisfied( */ static int -RequirementSatisfied( - char *havei, /* Version string, of candidate package we - * have. */ - const char *req) /* Requirement string the candidate has to - * satisfy. */ +RequirementSatisfied(havei, req) + 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, *buf, *min, *max; + char* dash = NULL; + char* 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'. */ - CheckVersionAndConvert(NULL, buf, &min, NULL); - strcat(min, " -2"); + /* No max part, unbound */ + + 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); @@ -1860,55 +2075,10 @@ RequirementSatisfied( } /* - *---------------------------------------------------------------------- - * - * 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 |