source: downloads/tcl8.5.2/generic/tclPkg.c @ 45

/*
 * 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.
 *
 * RCS: @(#) $Id: tclPkg.c,v 1.34 2007/12/13 15:23:20 dgp Exp $
 *
 * 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. */
    ClientData 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[],
                            ClientData *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.
 *
 *----------------------------------------------------------------------
 */

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. */
    ClientData 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_AppendResult(interp, "conflicting versions provided for package \"",
            name, "\": ", pkgPtr->version, ", then ", version, 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.
 *
 *----------------------------------------------------------------------
 */

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. */
    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. */
{
    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_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.
     */

    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. */
    ClientData *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. */
    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;
    Tcl_DString command;

    /*
     * 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_AppendResult(interp, "circular package dependency: "
                    "attempt to provide ", name, " ",
                    (char *) pkgPtr->clientData, " requires ", name, NULL);
            AddRequirementsToResult(interp, reqc, reqv);
            return NULL;
        }

        /*
         * The package isn't yet present. Search the list of available
         * versions and invoke the script for the best available version. 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.
             */

            const char *versionToProvide = bestPtr->version;
            script = bestPtr->script;

            pkgPtr->clientData = (ClientData) versionToProvide;
            Tcl_Preserve((ClientData) script);
            Tcl_Preserve((ClientData) versionToProvide);
            code = Tcl_EvalEx(interp, script, -1, TCL_EVAL_GLOBAL);
            Tcl_Release((ClientData) script);

            pkgPtr = FindPackage(interp, name);
            if (code == TCL_OK) {
                Tcl_ResetResult(interp);
                if (pkgPtr->version == NULL) {
                    code = TCL_ERROR;
                    Tcl_AppendResult(interp, "attempt to provide package ",
                            name, " ", versionToProvide,
                            " failed: no version of package ", name,
                            " provided", 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_AppendResult(interp,
                                    "attempt to provide package ", name, " ",
                                    versionToProvide, " failed: package ",
                                    name, " ", pkgPtr->version,
                                    " provided instead", NULL);
                        }
                    }
                }
            } 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);
                TclDecrRefCount(codePtr);
                code = TCL_ERROR;
            }

            if (code == TCL_ERROR) {
                Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
                        "\n    (\"package ifneeded %s %s\" script)",
                        name, versionToProvide));
            }
            Tcl_Release((ClientData) versionToProvide);

            if (code != TCL_OK) {
                /*
                 * 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_Obj *codePtr = Tcl_NewIntObj(code);
                Tcl_ResetResult(interp);
                Tcl_AppendResult(interp, "bad return code: ",
                        TclGetString(codePtr), NULL);
                Tcl_DecrRefCount(codePtr);
                code = TCL_ERROR;
            }
            if (code == TCL_ERROR) {
                Tcl_AddErrorInfo(interp,
                        "\n    (\"package unknown\" script)");
                return NULL;
            }
            Tcl_ResetResult(interp);
        }
    }

    if (pkgPtr->version == NULL) {
        Tcl_AppendResult(interp, "can't find package ", name, 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) {
        satisfies = 1;
    } else {
        CheckVersionAndConvert(interp, pkgPtr->version, &pkgVersionI, NULL);
        satisfies = SomeRequirementSatisfied(pkgVersionI, reqc, reqv);

        ckfree(pkgVersionI);
    }

    if (satisfies) {
        if (clientDataPtr) {
            *clientDataPtr = pkgPtr->clientData;
        }
        return pkgPtr->version;
    }

    Tcl_AppendResult(interp, "version conflict for package \"", name,
            "\": have ", pkgPtr->version, ", need", NULL);
    AddRequirementsToResult(interp, reqc, reqv);
    return NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * 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.
 *
 *----------------------------------------------------------------------
 */

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. */
    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;
    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_AppendResult(interp, "package ", name, " ", version,
                " is not present", NULL);
    } else {
        Tcl_AppendResult(interp, "package ", name, " is not present", NULL);
    }
    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 *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;
    char *argv2, *argv3, *argv4, *iva = NULL, *ivb = NULL;

    if (objc < 2) {
        Tcl_WrongNumArgs(interp, 1, objv, "option ?arg 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: {
        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((ClientData)availPtr->version, TCL_DYNAMIC);
                Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC);
                ckfree((char *) availPtr);
            }
            ckfree((char *) 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_SetResult(interp, availPtr->script, TCL_VOLATILE);
                    return TCL_OK;
                }
                Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC);
                break;
            }
        }
        ckfree(argv3i);

        if (objc == 4) {
            return TCL_OK;
        }
        if (availPtr == NULL) {
            availPtr = (PkgAvail *) 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;
        }
        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_AppendElement(interp, Tcl_GetHashKey(tablePtr, hPtr));
            }
        }
        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_PkgPresent(interp, name, version, exact);
        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_SetResult(interp, pkgPtr->version, TCL_VOLATILE);
                }
            }
            return TCL_OK;
        }
        argv3 = TclGetString(objv[3]);
        if (CheckVersionAndConvert(interp, argv3, NULL, NULL) != TCL_OK) {
            return TCL_ERROR;
        }
        return Tcl_PkgProvide(interp, argv2, argv3);
    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_SetResult(interp, iPtr->packageUnknown, TCL_VOLATILE);
            }
        } 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 *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;
        }
        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_AppendElement(interp, availPtr->version);
            }
        }
        break;
    case PKG_VSATISFIES: {
        char *argv2i = NULL;

        if (objc < 4) {
            Tcl_WrongNumArgs(interp, 2, objv,
                    "version requirement 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 = (Package *) 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((ClientData)availPtr->version, TCL_DYNAMIC);
            Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC);
            ckfree((char *) availPtr);
        }
        ckfree((char *) 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_AppendResult(interp, "expected version number but got \"", string,
            "\"", 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_AppendResult(interp, "expected versionMin-versionMax but got \"",
                string, "\"", NULL);
        return TCL_ERROR;
    }

    /*
     * Exactly one dash is present. Copy the string, split at the location of
     * 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. */
{
    if (reqc > 0) {
        int i;

        for (i = 0; i < reqc; i++) {
            int length;
            char *v = Tcl_GetStringFromObj(reqv[i], &length);

            if ((length & 0x1) && (v[length/2] == '-')
                    && (strncmp(v, v+((length+1)/2), length/2) == 0)) {
                Tcl_AppendResult(interp, " exactly ", v+((length+1)/2), NULL);
            } else {
                Tcl_AppendResult(interp, " ", v, NULL);
            }
        }
    }
}

/*
 *----------------------------------------------------------------------
 *
 * 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. */
{
    if (reqc > 0) {
        int i;

        for (i = 0; i < reqc; i++) {
            Tcl_DStringAppend(dsPtr, " ", 1);
            Tcl_DStringAppend(dsPtr, TclGetString(reqv[i]), -1);
        }
    } else {
        Tcl_DStringAppend(dsPtr, " 0-", -1);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * 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(*p++);
        }
        if (count == 1) {
            if (0 != strncmp(version, actualVersion, strlen(version))) {
                return NULL;
            }
        } else {
            return Tcl_PkgPresent(interp, "Tcl", version, 1);
        }
    }
    return actualVersion;
}
/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */