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