diff -r 000000000000 -r bde4ae8d615e os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclPkg.c --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclPkg.c Fri Jun 15 03:10:57 2012 +0200 @@ -0,0 +1,2405 @@ +/* + * 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 + * Portions Copyright (c) 2007-2008 Nokia Corporation and/or its subsidiaries. All rights reserved. + * + * 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.9.2.9 2007/03/19 17:06:26 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 procedures defined in this file: + */ + +#ifndef TCL_TIP268 +static int CheckVersion _ANSI_ARGS_((Tcl_Interp *interp, + CONST char *string)); +static int ComparePkgVersions _ANSI_ARGS_((CONST char *v1, + CONST char *v2, + int *satPtr)); +static Package * FindPackage _ANSI_ARGS_((Tcl_Interp *interp, + CONST char *name)); +#else +static int CheckVersionAndConvert(Tcl_Interp *interp, CONST char *string, + char** internal, int* stable); +static int CompareVersions(CONST char *v1i, CONST char *v2i, + int *isMajorPtr); +static int CheckRequirement(Tcl_Interp *interp, CONST char *string); +static int CheckAllRequirements(Tcl_Interp* interp, + int reqc, Tcl_Obj *CONST reqv[]); +static int RequirementSatisfied(CONST char *havei, CONST char *req); +static int AllRequirementsSatisfied(CONST 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 Tcl_Obj* ExactRequirement(CONST char* version); +static void VersionCleanupProc(ClientData clientData, + Tcl_Interp *interp); +#endif + +/* + *---------------------------------------------------------------------- + * + * Tcl_PkgProvide / Tcl_PkgProvideEx -- + * + * This procedure is invoked to declare that a particular version + * of a particular package is now present in an interpreter. There + * must not be any other version of this package already + * provided in the interpreter. + * + * 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. + * + *---------------------------------------------------------------------- + */ + +EXPORT_C int +Tcl_PkgProvide(interp, name, version) + Tcl_Interp *interp; /* Interpreter in which package is now + * available. */ + CONST char *name; /* Name of package. */ + CONST char *version; /* Version string for package. */ +{ + return Tcl_PkgProvideEx(interp, name, version, (ClientData) NULL); +} + +EXPORT_C int +Tcl_PkgProvideEx(interp, name, version, clientData) + Tcl_Interp *interp; /* Interpreter in which package is now + * available. */ + CONST char *name; /* Name of package. */ + CONST char *version; /* Version string for package. */ + ClientData clientData; /* clientdata for this package (normally + * used for C callback function table) */ +{ + Package *pkgPtr; +#ifdef TCL_TIP268 + char* pvi; + char* vi; + int res; +#endif + + pkgPtr = FindPackage(interp, name); + if (pkgPtr->version == NULL) { + pkgPtr->version = ckalloc((unsigned) (strlen(version) + 1)); + strcpy(pkgPtr->version, version); + pkgPtr->clientData = clientData; + return TCL_OK; + } +#ifndef TCL_TIP268 + if (ComparePkgVersions(pkgPtr->version, version, (int *) NULL) == 0) { +#else + if (CheckVersionAndConvert (interp, pkgPtr->version, &pvi, NULL) != TCL_OK) { + return TCL_ERROR; + } else if (CheckVersionAndConvert (interp, version, &vi, NULL) != TCL_OK) { + Tcl_Free (pvi); + return TCL_ERROR; + } + + res = CompareVersions(pvi, vi, NULL); + Tcl_Free (pvi); + Tcl_Free (vi); + + if (res == 0) { +#endif + if (clientData != NULL) { + pkgPtr->clientData = clientData; + } + return TCL_OK; + } + Tcl_AppendResult(interp, "conflicting versions provided for package \"", + name, "\": ", pkgPtr->version, ", then ", version, (char *) NULL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_PkgRequire / Tcl_PkgRequireEx / Tcl_PkgRequireProc -- + * + * This procedure is called by code that depends on a particular + * version of a particular package. If the package is not already + * provided in the interpreter, this procedure invokes a Tcl script + * to provide it. If the package is already provided, this + * procedure makes sure that the caller's needs don't conflict with + * the version that is present. + * + * 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. + * + *---------------------------------------------------------------------- + */ + +#ifndef TCL_TIP268 +/* + * Empty definition for Stubs when TIP 268 is not activated. + */ +EXPORT_C int +Tcl_PkgRequireProc(interp,name,reqc,reqv,clientDataPtr) + Tcl_Interp *interp; /* Interpreter in which package is now + * available. */ + CONST char *name; /* Name of desired package. */ + int reqc; /* Requirements constraining the desired version. */ + Tcl_Obj *CONST reqv[]; /* 0 means to use the latest version available. */ + ClientData *clientDataPtr; +{ + return TCL_ERROR; +} +#endif + +EXPORT_C CONST char * +Tcl_PkgRequire(interp, name, version, exact) + Tcl_Interp *interp; /* Interpreter in which package is now + * available. */ + CONST char *name; /* Name of desired package. */ + CONST char *version; /* Version string for desired version; NULL + * 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, (ClientData *) NULL); +} + +EXPORT_C CONST char * +Tcl_PkgRequireEx(interp, name, version, exact, clientDataPtr) + Tcl_Interp *interp; /* Interpreter in which package is now + * available. */ + CONST char *name; /* Name of desired package. */ + CONST char *version; /* Version string for desired version; + * NULL means use the latest version + * available. */ + int exact; /* Non-zero means that only the particular + * version given is acceptable. Zero means + * use the latest compatible version. */ + ClientData *clientDataPtr; /* Used to return the client data for this + * package. If it is NULL then the client + * data is not returned. This is unchanged + * if this call fails for any reason. */ +{ +#ifndef TCL_TIP268 + Package *pkgPtr; + PkgAvail *availPtr, *bestPtr; + char *script; + int code, satisfies, result, pass; + Tcl_DString command; +#else + Tcl_Obj *ov; + int res; +#endif + + /* + * If an attempt is being made to load this into a standalone executable + * on a platform where backlinking is not supported then this must be + * a shared version of Tcl (Otherwise the load would have failed). + * Detect this situation by checking that this library has been correctly + * 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; + } + +#ifdef TCL_TIP268 + /* Translate between old and new API, and defer to the new function. */ + + if (version == NULL) { + res = Tcl_PkgRequireProc(interp, name, 0, NULL, clientDataPtr); + } else { + if (exact) { + ov = ExactRequirement (version); + } else { + ov = Tcl_NewStringObj (version,-1); + } + + Tcl_IncrRefCount (ov); + res = Tcl_PkgRequireProc(interp, name, 1, &ov, clientDataPtr); + Tcl_DecrRefCount (ov); + } + + if (res != TCL_OK) { + return NULL; + } + + /* This function returns the version string explictly, and leaves the + * interpreter result empty. However "Tcl_PkgRequireProc" above returned + * the version through the interpreter result. Simply resetting the result + * now potentially deletes the string (obj), and the pointer to its string + * rep we have, as our result, may be dangling due to this. Our solution + * is to remember the object in interp associated data, with a proper + * reference count, and then reset the result. Now pointers will not + * dangle. It will be a leak however if nothing is done. So the next time + * we come through here we delete the object remembered by this call, as + * we can then be sure that there is no pointer to its string around + * anymore. Beyond that we have a deletion function which cleans up the last + * remembered object which was not cleaned up directly, here. + */ + + ov = (Tcl_Obj*) Tcl_GetAssocData (interp, "tcl/Tcl_PkgRequireEx", NULL); + if (ov != NULL) { + Tcl_DecrRefCount (ov); + } + + ov = Tcl_GetObjResult (interp); + Tcl_IncrRefCount (ov); + Tcl_SetAssocData(interp, "tcl/Tcl_PkgRequireEx", VersionCleanupProc, + (ClientData) ov); + Tcl_ResetResult (interp); + + return Tcl_GetString (ov); +} + +EXPORT_C int +Tcl_PkgRequireProc(interp,name,reqc,reqv,clientDataPtr) + Tcl_Interp *interp; /* Interpreter in which package is now + * available. */ + CONST char *name; /* Name of desired package. */ + int reqc; /* Requirements constraining the desired version. */ + Tcl_Obj *CONST reqv[]; /* 0 means to use the latest version available. */ + ClientData *clientDataPtr; +{ + Interp *iPtr = (Interp *) interp; + Package *pkgPtr; + PkgAvail *availPtr, *bestPtr, *bestStablePtr; + char *availVersion, *bestVersion; /* Internal rep. of versions */ + int availStable; + char *script; + int code, satisfies, pass; + Tcl_DString command; + char* pkgVersionI; + +#endif + /* + * It can take up to three passes to find the package: one pass to run the + * "package unknown" script, one to run the "package ifneeded" script for + * 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); +#ifndef TCL_TIP268 + if (version != NULL) { + Tcl_AppendResult(interp, " ", version, NULL); + } + return NULL; +#else + AddRequirementsToResult (interp, reqc, reqv); + return TCL_ERROR; +#endif + } + + /* + * The package isn't yet present. Search the list of available + * versions and invoke the script for the best available version. + * + * For TIP 268 we are actually locating the best, and the best stable + * version. One of them is then chosen based on the selection mode. + */ +#ifndef TCL_TIP268 + bestPtr = NULL; + for (availPtr = pkgPtr->availPtr; availPtr != NULL; + availPtr = availPtr->nextPtr) { + if ((bestPtr != NULL) && (ComparePkgVersions(availPtr->version, + bestPtr->version, (int *) NULL) <= 0)) { +#else + bestPtr = NULL; + bestStablePtr = NULL; + bestVersion = NULL; + + for (availPtr = pkgPtr->availPtr; + availPtr != NULL; + availPtr = availPtr->nextPtr) { + if (CheckVersionAndConvert (interp, availPtr->version, + &availVersion, &availStable) != TCL_OK) { + /* The provided version number is has invalid syntax. This + * should not happen. This should have been caught by the + * 'package ifneeded' registering the package. + */ +#endif + continue; + } +#ifndef TCL_TIP268 + if (version != NULL) { + result = ComparePkgVersions(availPtr->version, version, + &satisfies); + if ((result != 0) && exact) { +#else + if (bestPtr != NULL) { + int res = CompareVersions (availVersion, bestVersion, NULL); + /* Note: Use internal reps! */ + if (res <= 0) { + /* The version of the package sought is not as good as the + * currently selected version. Ignore it. */ + Tcl_Free (availVersion); + availVersion = NULL; +#endif + continue; + } +#ifdef TCL_TIP268 + } + + /* We have found a version which is better than our max. */ + + if (reqc > 0) { + /* Check satisfaction of requirements */ + satisfies = AllRequirementsSatisfied (availVersion, reqc, reqv); +#endif + if (!satisfies) { +#ifdef TCL_TIP268 + Tcl_Free (availVersion); + availVersion = NULL; +#endif + continue; + } + } + bestPtr = availPtr; +#ifdef TCL_TIP268 + if (bestVersion != NULL) Tcl_Free (bestVersion); + bestVersion = availVersion; + availVersion = NULL; + + /* 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) { + Tcl_Free (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; +#endif + } + 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) { +#ifdef TCL_TIP268 + Tcl_ResetResult(interp); +#endif + if (pkgPtr->version == NULL) { +#ifndef TCL_TIP268 + Tcl_ResetResult(interp); +#endif + code = TCL_ERROR; + Tcl_AppendResult(interp, "attempt to provide package ", + name, " ", versionToProvide, + " failed: no version of package ", name, + " provided", NULL); +#ifndef TCL_TIP268 + } else if (0 != ComparePkgVersions( + pkgPtr->version, versionToProvide, NULL)) { + /* At this point, it is clear that a prior + * [package ifneeded] command lied to us. It said + * that to get a particular version of a particular + * package, we needed to evaluate a particular script. + * However, we evaluated that script and got a different + * version than we were told. This is an error, and we + * ought to report it. + * + * However, we've been letting this type of error slide + * for a long time, and as a result, a lot of packages + * suffer from them. + * + * It's a bit too harsh to make a large number of + * existing packages start failing by releasing a + * new patch release, so we forgive this type of error + * for the rest of the Tcl 8.4 series. + * + * We considered reporting a warning, but in practice + * even that appears too harsh a change for a patch release. + * + * We limit the error reporting to only + * the situation where a broken ifneeded script leads + * to a failure to satisfy the requirement. + */ + if (version) { + result = ComparePkgVersions( + pkgPtr->version, version, &satisfies); + if (result && (exact || !satisfies)) { + Tcl_ResetResult(interp); + code = TCL_ERROR; + Tcl_AppendResult(interp, + "attempt to provide package ", name, " ", + versionToProvide, " failed: package ", + name, " ", pkgPtr->version, + " provided instead", NULL); +#else + } else { + char* pvi; + char* vi; + int res; + + if (CheckVersionAndConvert (interp, pkgPtr->version, &pvi, NULL) != TCL_OK) { + code = TCL_ERROR; + } else if (CheckVersionAndConvert (interp, versionToProvide, &vi, NULL) != TCL_OK) { + Tcl_Free (pvi); + code = TCL_ERROR; + } else { + res = CompareVersions(pvi, vi, NULL); + Tcl_Free (vi); + + if (res != 0) { + /* At this point, it is clear that a prior + * [package ifneeded] command lied to us. It said + * that to get a particular version of a particular + * package, we needed to evaluate a particular script. + * However, we evaluated that script and got a different + * version than we were told. This is an error, and we + * ought to report it. + * + * However, we've been letting this type of error slide + * for a long time, and as a result, a lot of packages + * suffer from them. + * + * It's a bit too harsh to make a large number of + * existing packages start failing by releasing a + * new patch release, so we forgive this type of error + * for the rest of the Tcl 8.4 series. + * + * We considered reporting a warning, but in practice + * even that appears too harsh a change for a patch release. + * + * We limit the error reporting to only + * the situation where a broken ifneeded script leads + * to a failure to satisfy the requirement. + */ + + if (reqc > 0) { + satisfies = AllRequirementsSatisfied (pvi, reqc, reqv); + if (!satisfies) { + Tcl_ResetResult(interp); + code = TCL_ERROR; + Tcl_AppendResult(interp, + "attempt to provide package ", name, " ", + versionToProvide, " failed: package ", + name, " ", pkgPtr->version, + " provided instead", NULL); + } + } + /* + * Warning generation now disabled + if (code == TCL_OK) { + Tcl_Obj *msg = Tcl_NewStringObj( + "attempt to provide package ", -1); + Tcl_Obj *cmdPtr = Tcl_NewListObj(0, NULL); + Tcl_ListObjAppendElement(NULL, cmdPtr, + Tcl_NewStringObj("tclLog", -1)); + Tcl_AppendStringsToObj(msg, name, " ", versionToProvide, + " failed: package ", name, " ", + pkgPtr->version, " provided instead", NULL); + Tcl_ListObjAppendElement(NULL, cmdPtr, msg); + Tcl_IncrRefCount(cmdPtr); + Tcl_EvalObjEx(interp, cmdPtr, TCL_EVAL_GLOBAL); + Tcl_DecrRefCount(cmdPtr); + Tcl_ResetResult(interp); + } + */ +#endif + } +#ifdef TCL_TIP268 + Tcl_Free (pvi); +#endif + } +#ifndef TCL_TIP268 + /* + * Warning generation now disabled + if (code == TCL_OK) { + Tcl_Obj *msg = Tcl_NewStringObj( + "attempt to provide package ", -1); + Tcl_Obj *cmdPtr = Tcl_NewListObj(0, NULL); + Tcl_ListObjAppendElement(NULL, cmdPtr, + Tcl_NewStringObj("tclLog", -1)); + Tcl_AppendStringsToObj(msg, name, " ", versionToProvide, + " failed: package ", name, " ", + pkgPtr->version, " provided instead", NULL); + Tcl_ListObjAppendElement(NULL, cmdPtr, msg); + Tcl_IncrRefCount(cmdPtr); + Tcl_EvalObjEx(interp, cmdPtr, TCL_EVAL_GLOBAL); + Tcl_DecrRefCount(cmdPtr); + Tcl_ResetResult(interp); + } + */ +#endif + } + } else if (code != TCL_ERROR) { + Tcl_Obj *codePtr = Tcl_NewIntObj(code); + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "attempt to provide package ", + name, " ", versionToProvide, " failed: ", + "bad return code: ", Tcl_GetString(codePtr), NULL); + Tcl_DecrRefCount(codePtr); + code = TCL_ERROR; + } + 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. + */ + Tcl_AddErrorInfo(interp, "\n (\"package ifneeded\" script)"); + if (pkgPtr->version != NULL) { + ckfree(pkgPtr->version); + pkgPtr->version = NULL; + } + pkgPtr->clientData = NULL; +#ifndef TCL_TIP268 + return NULL; +#else + return TCL_ERROR; +#endif + } + 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); +#ifndef TCL_TIP268 + Tcl_DStringAppend(&command, " ", 1); + Tcl_DStringAppend(&command, (version != NULL) ? version : "{}", + -1); + if (exact) { + Tcl_DStringAppend(&command, " -exact", 7); + } +#else + AddRequirementsToDString(&command, reqc, reqv); +#endif + code = Tcl_EvalEx(interp, Tcl_DStringValue(&command), + Tcl_DStringLength(&command), TCL_EVAL_GLOBAL); + Tcl_DStringFree(&command); + if ((code != TCL_OK) && (code != TCL_ERROR)) { + Tcl_Obj *codePtr = Tcl_NewIntObj(code); + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "bad return code: ", + Tcl_GetString(codePtr), NULL); + Tcl_DecrRefCount(codePtr); + code = TCL_ERROR; + } + if (code == TCL_ERROR) { + Tcl_AddErrorInfo(interp, "\n (\"package unknown\" script)"); +#ifndef TCL_TIP268 + return NULL; +#else + return TCL_ERROR; +#endif + } + Tcl_ResetResult(interp); + } + } + + if (pkgPtr->version == NULL) { + Tcl_AppendResult(interp, "can't find package ", name, (char *) NULL); +#ifndef TCL_TIP268 + if (version != NULL) { + Tcl_AppendResult(interp, " ", version, (char *) NULL); + } + return NULL; +#else + AddRequirementsToResult(interp, reqc, reqv); + return TCL_ERROR; +#endif + } + + /* + * At this point we know that the package is present. Make sure that the + * provided version meets the current requirements. + */ + +#ifndef TCL_TIP268 + if (version == NULL) { + if (clientDataPtr) { + *clientDataPtr = pkgPtr->clientData; + } + return pkgPtr->version; +#else + if (reqc == 0) { + satisfies = 1; + } else { + CheckVersionAndConvert (interp, pkgPtr->version, &pkgVersionI, NULL); + satisfies = AllRequirementsSatisfied (pkgVersionI, reqc, reqv); + + Tcl_Free (pkgVersionI); +#endif + } +#ifndef TCL_TIP268 + result = ComparePkgVersions(pkgPtr->version, version, &satisfies); + if ((satisfies && !exact) || (result == 0)) { +#else + if (satisfies) { +#endif + if (clientDataPtr) { + *clientDataPtr = pkgPtr->clientData; + } +#ifndef TCL_TIP268 + return pkgPtr->version; +#else + Tcl_SetObjResult (interp, Tcl_NewStringObj (pkgPtr->version, -1)); + return TCL_OK; +#endif + } + Tcl_AppendResult(interp, "version conflict for package \"", + name, "\": have ", pkgPtr->version, +#ifndef TCL_TIP268 + ", need ", version, (char *) NULL); + return NULL; +#else + ", need", (char*) NULL); + AddRequirementsToResult (interp, reqc, reqv); + return TCL_ERROR; +#endif +} + +/* + *---------------------------------------------------------------------- + * + * 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. + * + *---------------------------------------------------------------------- + */ + +EXPORT_C CONST char * +Tcl_PkgPresent(interp, name, version, exact) + Tcl_Interp *interp; /* Interpreter in which package is now + * available. */ + CONST char *name; /* Name of desired package. */ + CONST char *version; /* Version string for desired version; + * NULL means use the latest version + * available. */ + int exact; /* Non-zero means that only the particular + * version given is acceptable. Zero means + * use the latest compatible version. */ +{ + return Tcl_PkgPresentEx(interp, name, version, exact, (ClientData *) NULL); +} + +EXPORT_C CONST char * +Tcl_PkgPresentEx(interp, name, version, exact, clientDataPtr) + Tcl_Interp *interp; /* Interpreter in which package is now + * available. */ + CONST char *name; /* Name of desired package. */ + CONST char *version; /* Version string for desired version; + * NULL means use the latest version + * available. */ + int exact; /* Non-zero means that only the particular + * version given is acceptable. Zero means + * use the latest compatible version. */ + 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; + int satisfies, result; + + hPtr = Tcl_FindHashEntry(&iPtr->packageTable, name); + if (hPtr) { + pkgPtr = (Package *) Tcl_GetHashValue(hPtr); + if (pkgPtr->version != NULL) { +#ifdef TCL_TIP268 + char* pvi; + char* vi; + int thisIsMajor; +#endif + + /* + * At this point we know that the package is present. Make sure + * that the provided version meets the current requirement. + */ + + if (version == NULL) { + if (clientDataPtr) { + *clientDataPtr = pkgPtr->clientData; + } + + return pkgPtr->version; + } +#ifndef TCL_TIP268 + result = ComparePkgVersions(pkgPtr->version, version, &satisfies); +#else + if (CheckVersionAndConvert (interp, pkgPtr->version, &pvi, NULL) != TCL_OK) { + return NULL; + } else if (CheckVersionAndConvert (interp, version, &vi, NULL) != TCL_OK) { + Tcl_Free (pvi); + return NULL; + } + result = CompareVersions(pvi, vi, &thisIsMajor); + Tcl_Free (pvi); + Tcl_Free (vi); + satisfies = (result == 0) || ((result == 1) && !thisIsMajor); +#endif + if ((satisfies && !exact) || (result == 0)) { + if (clientDataPtr) { + *clientDataPtr = pkgPtr->clientData; + } + + return pkgPtr->version; + } + Tcl_AppendResult(interp, "version conflict for package \"", + name, "\": have ", pkgPtr->version, + ", need ", version, (char *) NULL); + return NULL; + } + } + + if (version != NULL) { + Tcl_AppendResult(interp, "package ", name, " ", version, + " is not present", (char *) NULL); + } else { + Tcl_AppendResult(interp, "package ", name, " is not present", + (char *) NULL); + } + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_PackageObjCmd -- + * + * This procedure is invoked to process the "package" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +/* ARGSUSED */ +int +Tcl_PackageObjCmd(dummy, interp, objc, objv) + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + static CONST char *pkgOptions[] = { + "forget", "ifneeded", "names", +#ifdef TCL_TIP268 + "prefer", +#endif + "present", "provide", "require", "unknown", "vcompare", + "versions", "vsatisfies", (char *) NULL + }; + enum pkgOptions { + PKG_FORGET, PKG_IFNEEDED, PKG_NAMES, +#ifdef TCL_TIP268 + PKG_PREFER, +#endif + PKG_PRESENT, PKG_PROVIDE, PKG_REQUIRE, PKG_UNKNOWN, PKG_VCOMPARE, + PKG_VERSIONS, PKG_VSATISFIES + }; + Interp *iPtr = (Interp *) interp; + int optionIndex, exact, i, satisfies; + PkgAvail *availPtr, *prevPtr; + Package *pkgPtr; + Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + Tcl_HashTable *tablePtr; + CONST char *version; + char *argv2, *argv3, *argv4; +#ifdef TCL_TIP268 + char* iva = NULL; + char* ivb = NULL; +#endif + + 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) { +#ifndef TCL_TIP268 + case PKG_FORGET: { + char *keyString; + for (i = 2; i < objc; i++) { + keyString = Tcl_GetString(objv[i]); + hPtr = Tcl_FindHashEntry(&iPtr->packageTable, keyString); + if (hPtr == NULL) { + continue; + } + pkgPtr = (Package *) 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; +#else + case PKG_FORGET: { + char *keyString; + for (i = 2; i < objc; i++) { + keyString = Tcl_GetString(objv[i]); + hPtr = Tcl_FindHashEntry(&iPtr->packageTable, keyString); + if (hPtr == NULL) { + continue; + } + pkgPtr = (Package *) 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; + char* argv3i; + char* avi; + int res; + + if ((objc != 4) && (objc != 5)) { + Tcl_WrongNumArgs(interp, 2, objv, "package version ?script?"); + return TCL_ERROR; + } + argv3 = Tcl_GetString(objv[3]); + if (CheckVersionAndConvert(interp, argv3, &argv3i, NULL) != TCL_OK) { + return TCL_ERROR; +#endif + } +#ifndef TCL_TIP268 + case PKG_IFNEEDED: { + int length; + if ((objc != 4) && (objc != 5)) { + Tcl_WrongNumArgs(interp, 2, objv, "package version ?script?"); + return TCL_ERROR; +#else + argv2 = Tcl_GetString(objv[2]); + if (objc == 4) { + hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2); + if (hPtr == NULL) { + Tcl_Free (argv3i); + return TCL_OK; +#endif + } +#ifndef TCL_TIP268 + argv3 = Tcl_GetString(objv[3]); + if (CheckVersion(interp, argv3) != TCL_OK) { +#else + pkgPtr = (Package *) Tcl_GetHashValue(hPtr); + } else { + pkgPtr = FindPackage(interp, argv2); + } + argv3 = Tcl_GetStringFromObj(objv[3], &length); + + for (availPtr = pkgPtr->availPtr, prevPtr = NULL; + availPtr != NULL; + prevPtr = availPtr, availPtr = availPtr->nextPtr) { + + if (CheckVersionAndConvert (interp, availPtr->version, &avi, NULL) != TCL_OK) { + Tcl_Free (argv3i); +#endif + return TCL_ERROR; + } +#ifndef TCL_TIP268 + argv2 = Tcl_GetString(objv[2]); + if (objc == 4) { + hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2); + if (hPtr == NULL) { +#else + + res = CompareVersions(avi, argv3i, NULL); + Tcl_Free (avi); + + if (res == 0){ + if (objc == 4) { + Tcl_Free (argv3i); + Tcl_SetResult(interp, availPtr->script, TCL_VOLATILE); +#endif + return TCL_OK; + } +#ifndef TCL_TIP268 + pkgPtr = (Package *) Tcl_GetHashValue(hPtr); + } else { + pkgPtr = FindPackage(interp, argv2); + } + argv3 = Tcl_GetStringFromObj(objv[3], &length); + for (availPtr = pkgPtr->availPtr, prevPtr = NULL; availPtr != NULL; + prevPtr = availPtr, availPtr = availPtr->nextPtr) { + if (ComparePkgVersions(availPtr->version, argv3, (int *) NULL) + == 0) { + if (objc == 4) { + Tcl_SetResult(interp, availPtr->script, TCL_VOLATILE); + return TCL_OK; + } + Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC); + break; + } + } + if (objc == 4) { + return TCL_OK; +#else + Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC); + break; +#endif + } +#ifndef TCL_TIP268 + if (availPtr == NULL) { + availPtr = (PkgAvail *) ckalloc(sizeof(PkgAvail)); + availPtr->version = ckalloc((unsigned) (length + 1)); + strcpy(availPtr->version, argv3); + if (prevPtr == NULL) { + availPtr->nextPtr = pkgPtr->availPtr; + pkgPtr->availPtr = availPtr; + } else { + availPtr->nextPtr = prevPtr->nextPtr; + prevPtr->nextPtr = availPtr; + } +#else + } + Tcl_Free (argv3i); + if (objc == 4) { + return TCL_OK; + } + if (availPtr == NULL) { + availPtr = (PkgAvail *) ckalloc(sizeof(PkgAvail)); + availPtr->version = ckalloc((unsigned) (length + 1)); + strcpy(availPtr->version, argv3); + if (prevPtr == NULL) { + availPtr->nextPtr = pkgPtr->availPtr; + pkgPtr->availPtr = availPtr; + } else { + availPtr->nextPtr = prevPtr->nextPtr; + prevPtr->nextPtr = availPtr; +#endif + } +#ifndef TCL_TIP268 + argv4 = Tcl_GetStringFromObj(objv[4], &length); + availPtr->script = ckalloc((unsigned) (length + 1)); + strcpy(availPtr->script, argv4); + break; +#endif + } +#ifndef TCL_TIP268 + case PKG_NAMES: { + if (objc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); +#else + argv4 = Tcl_GetStringFromObj(objv[4], &length); + availPtr->script = ckalloc((unsigned) (length + 1)); + strcpy(availPtr->script, argv4); + 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 = (Package *) Tcl_GetHashValue(hPtr); + if ((pkgPtr->version != NULL) || (pkgPtr->availPtr != NULL)) { + Tcl_AppendElement(interp, Tcl_GetHashKey(tablePtr, hPtr)); + } + } + break; + } + case PKG_PRESENT: { + if (objc < 3) { + presentSyntax: + Tcl_WrongNumArgs(interp, 2, objv, "?-exact? package ?version?"); + return TCL_ERROR; + } + argv2 = Tcl_GetString(objv[2]); + if ((argv2[0] == '-') && (strcmp(argv2, "-exact") == 0)) { + exact = 1; + } else { + exact = 0; + } + version = NULL; + if (objc == (4 + exact)) { + version = Tcl_GetString(objv[3 + exact]); + if (CheckVersionAndConvert(interp, version, NULL, NULL) != TCL_OK) { +#endif + return TCL_ERROR; + } +#ifndef TCL_TIP268 + tablePtr = &iPtr->packageTable; + for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL; + hPtr = Tcl_NextHashEntry(&search)) { +#else + } else if ((objc != 3) || exact) { + goto presentSyntax; + } + if (exact) { + argv3 = Tcl_GetString(objv[3]); + version = Tcl_PkgPresent(interp, argv3, version, exact); + } else { + version = Tcl_PkgPresent(interp, argv2, version, exact); + } + if (version == NULL) { + return TCL_ERROR; + } + Tcl_SetObjResult( interp, Tcl_NewStringObj( version, -1 ) ); + break; + } + case PKG_PROVIDE: { + if ((objc != 3) && (objc != 4)) { + Tcl_WrongNumArgs(interp, 2, objv, "package ?version?"); + return TCL_ERROR; + } + argv2 = Tcl_GetString(objv[2]); + if (objc == 3) { + hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2); + if (hPtr != NULL) { +#endif + pkgPtr = (Package *) Tcl_GetHashValue(hPtr); +#ifndef TCL_TIP268 + if ((pkgPtr->version != NULL) || (pkgPtr->availPtr != NULL)) { + Tcl_AppendElement(interp, Tcl_GetHashKey(tablePtr, hPtr)); +#else + if (pkgPtr->version != NULL) { + Tcl_SetResult(interp, pkgPtr->version, TCL_VOLATILE); +#endif + } + } +#ifndef TCL_TIP268 + break; +#else + return TCL_OK; +#endif + } +#ifndef TCL_TIP268 + case PKG_PRESENT: { + if (objc < 3) { + presentSyntax: + Tcl_WrongNumArgs(interp, 2, objv, "?-exact? package ?version?"); + return TCL_ERROR; +#else + argv3 = Tcl_GetString(objv[3]); + if (CheckVersionAndConvert(interp, argv3, NULL, NULL) != TCL_OK) { + return TCL_ERROR; + } + return Tcl_PkgProvide(interp, argv2, argv3); + } + case PKG_REQUIRE: { + if (objc < 3) { + requireSyntax: + Tcl_WrongNumArgs(interp, 2, objv, "?-exact? package ?requirement...?"); + return TCL_ERROR; + } + version = NULL; + argv2 = Tcl_GetString(objv[2]); + if ((argv2[0] == '-') && (strcmp(argv2, "-exact") == 0)) { + Tcl_Obj* ov; + int res; + + if (objc != 5) { + goto requireSyntax; +#endif + } +#ifndef TCL_TIP268 + argv2 = Tcl_GetString(objv[2]); + if ((argv2[0] == '-') && (strcmp(argv2, "-exact") == 0)) { + exact = 1; + } else { + exact = 0; +#else + version = Tcl_GetString(objv[4]); + if (CheckVersionAndConvert(interp, version, NULL, NULL) != TCL_OK) { + return TCL_ERROR; +#endif + } +#ifdef TCL_TIP268 + /* Create a new-style requirement for the exact version. */ + + ov = ExactRequirement (version); +#endif + version = NULL; +#ifndef TCL_TIP268 + if (objc == (4 + exact)) { + version = Tcl_GetString(objv[3 + exact]); + if (CheckVersion(interp, version) != TCL_OK) { + return TCL_ERROR; + } + } else if ((objc != 3) || exact) { + goto presentSyntax; + } + if (exact) { + argv3 = Tcl_GetString(objv[3]); + version = Tcl_PkgPresent(interp, argv3, version, exact); + } else { + version = Tcl_PkgPresent(interp, argv2, version, exact); + } + if (version == NULL) { +#else + argv3 = Tcl_GetString(objv[3]); + + Tcl_IncrRefCount (ov); + res = Tcl_PkgRequireProc(interp, argv3, 1, &ov, NULL); + Tcl_DecrRefCount (ov); + return res; + } else { + if (CheckAllRequirements (interp, objc-3, objv+3) != TCL_OK) { +#endif + return TCL_ERROR; + } +#ifndef TCL_TIP268 + Tcl_SetObjResult( interp, Tcl_NewStringObj( version, -1 ) ); + break; +#else + return Tcl_PkgRequireProc(interp, argv2, objc-3, objv+3, NULL); +#endif + } +#ifndef TCL_TIP268 + case PKG_PROVIDE: { + if ((objc != 3) && (objc != 4)) { + Tcl_WrongNumArgs(interp, 2, objv, "package ?version?"); +#else + 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 { + iPtr->packageUnknown = (char *) ckalloc((unsigned) + (length + 1)); + strcpy(iPtr->packageUnknown, argv2); + } + } else { + Tcl_WrongNumArgs(interp, 2, objv, "?command?"); + return TCL_ERROR; + } + break; + } + case PKG_PREFER: { + /* See tclInt.h for the enum, just before Interp */ + static CONST char *pkgPreferOptions[] = { + "latest", "stable", NULL + }; + + if (objc > 3) { + Tcl_WrongNumArgs(interp, 2, objv, "?latest|stable?"); + return TCL_ERROR; + } else if (objc == 3) { + /* Set value. */ + int new; + if (Tcl_GetIndexFromObj(interp, objv[2], pkgPreferOptions, "preference", 0, + &new) != TCL_OK) { +#endif + return TCL_ERROR; + } +#ifndef TCL_TIP268 + argv2 = Tcl_GetString(objv[2]); + if (objc == 3) { + hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2); + if (hPtr != NULL) { + pkgPtr = (Package *) Tcl_GetHashValue(hPtr); + if (pkgPtr->version != NULL) { + Tcl_SetResult(interp, pkgPtr->version, TCL_VOLATILE); + } + } + return TCL_OK; +#else + if (new < iPtr->packagePrefer) { + iPtr->packagePrefer = new; +#endif + } +#ifndef TCL_TIP268 + argv3 = Tcl_GetString(objv[3]); + if (CheckVersion(interp, argv3) != TCL_OK) { + return TCL_ERROR; + } + return Tcl_PkgProvide(interp, argv2, argv3); +#endif + } +#ifndef TCL_TIP268 + case PKG_REQUIRE: { + if (objc < 3) { + requireSyntax: + Tcl_WrongNumArgs(interp, 2, objv, "?-exact? package ?version?"); + return TCL_ERROR; + } + argv2 = Tcl_GetString(objv[2]); + if ((argv2[0] == '-') && (strcmp(argv2, "-exact") == 0)) { + exact = 1; + } else { + exact = 0; + } + version = NULL; + if (objc == (4 + exact)) { + version = Tcl_GetString(objv[3 + exact]); + if (CheckVersion(interp, version) != TCL_OK) { + return TCL_ERROR; + } + } else if ((objc != 3) || exact) { + goto requireSyntax; + } + if (exact) { + argv3 = Tcl_GetString(objv[3]); + version = Tcl_PkgRequire(interp, argv3, version, exact); + } else { + version = Tcl_PkgRequire(interp, argv2, version, exact); + } + if (version == NULL) { + return TCL_ERROR; + } + Tcl_SetObjResult( interp, Tcl_NewStringObj( version, -1 ) ); + break; +#else + /* 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; +#endif + } +#ifndef TCL_TIP268 + 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 { + iPtr->packageUnknown = (char *) ckalloc((unsigned) + (length + 1)); + strcpy(iPtr->packageUnknown, argv2); + } + } else { + Tcl_WrongNumArgs(interp, 2, objv, "?command?"); + return TCL_ERROR; + } + break; +#else + argv3 = Tcl_GetString(objv[3]); + argv2 = Tcl_GetString(objv[2]); + if ((CheckVersionAndConvert (interp, argv2, &iva, NULL) != TCL_OK) || + (CheckVersionAndConvert (interp, argv3, &ivb, NULL) != TCL_OK)) { + if (iva != NULL) { Tcl_Free (iva); } + /* ivb cannot be set in this branch */ + return TCL_ERROR; +#endif + } +#ifndef TCL_TIP268 + case PKG_VCOMPARE: { + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "version1 version2"); + return TCL_ERROR; + } + argv3 = Tcl_GetString(objv[3]); + argv2 = Tcl_GetString(objv[2]); + if ((CheckVersion(interp, argv2) != TCL_OK) + || (CheckVersion(interp, argv3) != TCL_OK)) { + return TCL_ERROR; + } + Tcl_SetIntObj(Tcl_GetObjResult(interp), + ComparePkgVersions(argv2, argv3, (int *) NULL)); + break; +#else + + /* Comparison is done on the internal representation */ + Tcl_SetObjResult(interp,Tcl_NewIntObj(CompareVersions(iva, ivb, NULL))); + Tcl_Free (iva); + Tcl_Free (ivb); + break; + } + case PKG_VERSIONS: { + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "package"); + return TCL_ERROR; +#endif + } +#ifndef TCL_TIP268 + case PKG_VERSIONS: { + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "package"); + return TCL_ERROR; +#else + argv2 = Tcl_GetString(objv[2]); + hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2); + if (hPtr != NULL) { + pkgPtr = (Package *) Tcl_GetHashValue(hPtr); + for (availPtr = pkgPtr->availPtr; availPtr != NULL; + availPtr = availPtr->nextPtr) { + Tcl_AppendElement(interp, availPtr->version); +#endif + } +#ifndef TCL_TIP268 + argv2 = Tcl_GetString(objv[2]); + hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2); + if (hPtr != NULL) { + pkgPtr = (Package *) Tcl_GetHashValue(hPtr); + for (availPtr = pkgPtr->availPtr; availPtr != NULL; + availPtr = availPtr->nextPtr) { + Tcl_AppendElement(interp, availPtr->version); + } + } + break; +#endif + } +#ifndef TCL_TIP268 + case PKG_VSATISFIES: { + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "version1 version2"); + return TCL_ERROR; + } + argv3 = Tcl_GetString(objv[3]); + argv2 = Tcl_GetString(objv[2]); + if ((CheckVersion(interp, argv2) != TCL_OK) + || (CheckVersion(interp, argv3) != TCL_OK)) { + return TCL_ERROR; + } + ComparePkgVersions(argv2, argv3, &satisfies); + Tcl_SetIntObj(Tcl_GetObjResult(interp), satisfies); + break; +#else + break; + } + case PKG_VSATISFIES: { + char* argv2i = NULL; + + if (objc < 4) { + Tcl_WrongNumArgs(interp, 2, objv, "version requirement requirement..."); + return TCL_ERROR; +#endif + } +#ifndef TCL_TIP268 + default: { + panic("Tcl_PackageObjCmd: bad option index to pkgOptions"); +#else + + argv2 = Tcl_GetString(objv[2]); + if ((CheckVersionAndConvert(interp, argv2, &argv2i, NULL) != TCL_OK)) { + return TCL_ERROR; + } else if (CheckAllRequirements (interp, objc-3, objv+3) != TCL_OK) { + Tcl_Free (argv2i); + return TCL_ERROR; +#endif + } +#ifdef TCL_TIP268 + + satisfies = AllRequirementsSatisfied (argv2i, objc-3, objv+3); + Tcl_Free (argv2i); + + Tcl_SetIntObj(Tcl_GetObjResult(interp), satisfies); + break; + } + default: { + panic("Tcl_PackageObjCmd: bad option index to pkgOptions"); + } +#endif + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * FindPackage -- + * + * This procedure finds the Package record for a particular package + * in a particular interpreter, creating a record if one doesn't + * already exist. + * + * Results: + * The return value is a pointer to the Package record for the + * package. + * + * Side effects: + * A new Package record may be created. + * + *---------------------------------------------------------------------- + */ + +static Package * +FindPackage(interp, name) + Tcl_Interp *interp; /* Interpreter to use for package lookup. */ + CONST char *name; /* Name of package to fine. */ +{ + Interp *iPtr = (Interp *) interp; + Tcl_HashEntry *hPtr; + int new; + Package *pkgPtr; + + hPtr = Tcl_CreateHashEntry(&iPtr->packageTable, name, &new); + if (new) { + pkgPtr = (Package *) ckalloc(sizeof(Package)); + pkgPtr->version = NULL; + pkgPtr->availPtr = NULL; + pkgPtr->clientData = NULL; + Tcl_SetHashValue(hPtr, pkgPtr); + } else { + pkgPtr = (Package *) Tcl_GetHashValue(hPtr); + } + return pkgPtr; +} + +/* + *---------------------------------------------------------------------- + * + * TclFreePackageInfo -- + * + * This procedure 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(iPtr) + Interp *iPtr; /* Interpreter 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 = (Package *) 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); + } +} + +/* + *---------------------------------------------------------------------- + * + * CheckVersion / CheckVersionAndConvert -- + * + * This procedure checks to see whether a version number has + * valid syntax. + * + * Results: + * If string is a properly formed version number the TCL_OK + * is returned. Otherwise TCL_ERROR is returned and an error + * message is left in the interp's result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +#ifndef TCL_TIP268 +CheckVersion(interp, string) + Tcl_Interp *interp; /* Used for error reporting. */ + CONST char *string; /* Supposedly a version number, which is + * groups of decimal digits separated + * by dots. */ +#else +CheckVersionAndConvert(interp, string, internal, stable) + Tcl_Interp *interp; /* Used for error reporting. */ + CONST char *string; /* Supposedly a version number, which is + * groups of decimal digits separated by + * dots. */ + char** internal; /* Internal normalized representation */ + int* stable; /* Flag: Version is (un)stable. */ +#endif +{ + CONST char *p = string; + char prevChar; +#ifdef TCL_TIP268 + 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 '.' + */ + +#endif + if (!isdigit(UCHAR(*p))) { /* INTL: digit */ + goto error; + } +#ifdef TCL_TIP268 + *ip++ = *p; +#endif + for (prevChar = *p, p++; *p != 0; p++) { +#ifndef TCL_TIP268 + if (!isdigit(UCHAR(*p)) && + ((*p != '.') || (prevChar == '.'))) { /* INTL: digit */ +#else + if ( + (!isdigit(UCHAR(*p))) && + (((*p != '.') && (*p != 'a') && (*p != 'b')) || + ((hasunstable && ((*p == 'a') || (*p == 'b'))) || + (((prevChar == 'a') || (prevChar == 'b') || (prevChar == '.')) && (*p == '.')) || + (((*p == 'a') || (*p == 'b') || (*p == '.')) && (prevChar == '.')))) + ) { + /* INTL: digit */ +#endif + goto error; + } +#ifdef TCL_TIP268 + 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; } +#endif + prevChar = *p; + } +#ifndef TCL_TIP268 + if (prevChar != '.') { +#else + if ((prevChar != '.') && (prevChar != 'a') && (prevChar != 'b')) { + *ip = '\0'; + if (internal != NULL) { + *internal = ibuf; + } else { + Tcl_Free (ibuf); + } + if (stable != NULL) { + *stable = !hasunstable; + } +#endif + return TCL_OK; + } + + error: +#ifdef TCL_TIP268 + ckfree (ibuf); +#endif + Tcl_AppendResult(interp, "expected version number but got \"", + string, "\"", (char *) NULL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * ComparePkgVersions / CompareVersions -- + * + * This procedure compares two version numbers. (268: in internal rep). + * + * Results: + * The return value is -1 if v1 is less than v2, 0 if the two + * version numbers are the same, and 1 if v1 is greater than v2. + * If *satPtr is non-NULL, the word it points to is filled in + * with 1 if v2 >= v1 and both numbers have the same major number + * or 0 otherwise. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +#ifndef TCL_TIP268 +ComparePkgVersions(v1, v2, satPtr) + CONST char *v1; + CONST char *v2; /* Versions strings, of form 2.1.3 (any + * number of version numbers). */ + int *satPtr; /* If non-null, the word pointed to is + * filled in with a 0/1 value. 1 means + * v1 "satisfies" v2: v1 is greater than + * or equal to v2 and both version numbers + * have the same major number. */ +#else +CompareVersions(v1, v2, isMajorPtr) + CONST char *v1; /* Versions strings, of form 2.1.3 (any number */ + CONST char *v2; /* of version numbers). */ + int *isMajorPtr; /* If non-null, the word pointed to is filled + * in with a 0/1 value. 1 means that the difference + * occured in the first element. */ +#endif +{ + int thisIsMajor, n1, n2; +#ifdef TCL_TIP268 + int res, flip; +#endif + + /* + * 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. + */ + + thisIsMajor = 1; + while (1) { + /* + * Parse one decimal number from the front of each string. + */ + + n1 = n2 = 0; +#ifndef TCL_TIP268 + while ((*v1 != 0) && (*v1 != '.')) { +#else + flip = 0; + while ((*v1 != 0) && (*v1 != ' ')) { + if (*v1 == '-') {flip = 1 ; v1++ ; continue;} +#endif + n1 = 10*n1 + (*v1 - '0'); + v1++; + } +#ifndef TCL_TIP268 + while ((*v2 != 0) && (*v2 != '.')) { +#else + if (flip) n1 = -n1; + flip = 0; + while ((*v2 != 0) && (*v2 != ' ')) { + if (*v2 == '-') {flip = 1; v2++ ; continue;} +#endif + n2 = 10*n2 + (*v2 - '0'); + v2++; + } +#ifdef TCL_TIP268 + if (flip) n2 = -n2; +#endif + + /* + * Compare and go on to the next version number if the current numbers + * match. + */ + + if (n1 != n2) { + break; + } + if (*v1 != 0) { + v1++; + } else if (*v2 == 0) { + break; + } + if (*v2 != 0) { + v2++; + } + thisIsMajor = 0; + } +#ifndef TCL_TIP268 + if (satPtr != NULL) { + *satPtr = (n1 == n2) || ((n1 > n2) && !thisIsMajor); + } +#endif + if (n1 > n2) { +#ifndef TCL_TIP268 + return 1; +#else + res = 1; +#endif + } else if (n1 == n2) { +#ifndef TCL_TIP268 + return 0; +#else + res = 0; +#endif + } else { +#ifndef TCL_TIP268 + return -1; +#else + res = -1; + } + + 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(interp, reqc, reqv) + Tcl_Interp* interp; + int reqc; /* Requirements to check. */ + Tcl_Obj *CONST reqv[]; +{ + int i; + for (i = 0; i < reqc; i++) { + if ((CheckRequirement(interp, Tcl_GetString(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(interp, string) + Tcl_Interp *interp; /* Used for error reporting. */ + CONST char *string; /* Supposedly a requirement. */ +{ + /* Syntax of requirement = version + * = version-version + * = version- + */ + + char* dash = NULL; + char* 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; +#endif + } +#ifdef TCL_TIP268 + + /* 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. + */ + + buf = strdup (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))) { + free (buf); + return TCL_ERROR; + } + + free (buf); + return TCL_OK; +#endif +} +#ifdef TCL_TIP268 + +/* + *---------------------------------------------------------------------- + * + * AddRequirementsToResult -- + * + * This function accumulates requirements in the interpreter result. + * + * Results: + * None. + * + * Side effects: + * The interpreter result is extended. + * + *---------------------------------------------------------------------- + */ + +static void +AddRequirementsToResult(interp, reqc, reqv) + 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++) { + Tcl_AppendResult(interp, " ", TclGetString(reqv[i]), NULL); + } + } +} + +/* + *---------------------------------------------------------------------- + * + * AddRequirementsToDString -- + * + * This function accumulates requirements in a DString. + * + * Results: + * None. + * + * Side effects: + * The DString argument is extended. + * + *---------------------------------------------------------------------- + */ + +static void +AddRequirementsToDString(dstring, reqc, reqv) + Tcl_DString* dstring; + int reqc; /* Requirements constraining the desired version. */ + Tcl_Obj *CONST reqv[]; /* 0 means to use the latest version available. */ +{ + if (reqc > 0) { + int i; + for (i = 0; i < reqc; i++) { + Tcl_DStringAppend(dstring, " ", 1); + Tcl_DStringAppend(dstring, TclGetString(reqv[i]), -1); + } + } else { + Tcl_DStringAppend(dstring, " 0-", -1); + } +} + +/* + *---------------------------------------------------------------------- + * + * AllRequirementSatisfied -- + * + * 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 +AllRequirementsSatisfied(availVersionI, reqc, reqv) + CONST 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, satisfies; + + for (satisfies = i = 0; i < reqc; i++) { + satisfies = RequirementSatisfied(availVersionI, Tcl_GetString(reqv[i])); + if (satisfies) break; + } + return satisfies; +} + +/* + *---------------------------------------------------------------------- + * + * 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(havei, req) + CONST 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; + char* 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); + Tcl_Free (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. + */ + + buf = strdup (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'. + */ + + /* No max part, unbound */ + + CheckVersionAndConvert (NULL, buf, &min, NULL); + strcat (min, " -2"); + satisfied = (CompareVersions(havei, min, NULL) >= 0); + Tcl_Free (min); + free (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)); + } + + Tcl_Free (min); + Tcl_Free (max); + free (buf); + return satisfied; +} + +/* + *---------------------------------------------------------------------- + * + * ExactRequirement -- + * + * This function is the core for the translation of -exact requests. + * It translates the request of the version into a range of versions. + * The translation was chosen for backwards compatibility. + * + * Results: + * A Tcl_Obj containing the version range as string. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static Tcl_Obj* +ExactRequirement(version) + CONST char* version; +{ + /* A -exact request for a version X.y is translated into the range + * X.y-X.(y+1). For example -exact 8.4 means the range "8.4-8.5". + * + * This translation was chosen to prevent packages which currently use a + * 'package require -exact tclversion' from being affected by the core now + * registering itself as 8.4.x (patchlevel) instead of 8.4 + * (version). Examples are tbcload, compiler, and ITcl. + * + * Translating -exact 8.4 to the range "8.4-8.4" instead would require us + * and everyone else to rebuild these packages to require -exact 8.4.14, + * or whatever the exact current patchlevel is. A backward compatibility + * issue with effects similar to the bugfix made in 8.5 now requiring + * ifneeded and provided versions to match. Instead we have chosen to + * interpret exactness to not be exactly equal, but to be exact only + * within the specified level, and allowing variation in the deeper + * level. More examples: + * + * -exact 8 => "8-9" + * -exact 8.4 => "8.4-8.5" + * -exact 8.4.14 => "8.4.14-8.4.15" + * -exact 8.0a2 => "8.0a2-8.0a3" + */ + + char* iv; + int lc, i; + CONST char** lv; + char buf [30]; + Tcl_Obj* o = Tcl_NewStringObj (version,-1); + Tcl_AppendStringsToObj (o, "-", NULL); + + /* Assuming valid syntax here */ + CheckVersionAndConvert (NULL, version, &iv, NULL); + + /* Split the list into components */ + Tcl_SplitList (NULL, iv, &lc, &lv); + + /* Iterate over the components and make them parts of the result. Except + * for the last, which is handled separately, to allow the + * incrementation. + */ + + for (i=0; i < (lc-1); i++) { + /* Regular component */ + Tcl_AppendStringsToObj (o, lv[i], NULL); + /* Separator component */ + i ++; + if (0 == strcmp ("-1", lv[i])) { + Tcl_AppendStringsToObj (o, "b", NULL); + } else if (0 == strcmp ("-2", lv[i])) { + Tcl_AppendStringsToObj (o, "a", NULL); + } else { + Tcl_AppendStringsToObj (o, ".", NULL); + } + } + /* Regular component, last */ + sprintf (buf, "%d", atoi (lv [lc-1]) + 1); + Tcl_AppendStringsToObj (o, buf, NULL); + + ckfree ((char*) lv); + return o; +} + +/* + *---------------------------------------------------------------------- + * + * VersionCleanupProc -- + * + * This function is called to delete the last remember package version + * string for an interpreter when the interpreter is deleted. It gets + * invoked via the Tcl AssocData mechanism. + * + * Results: + * None. + * + * Side effects: + * Storage for the version object for interp get deleted. + * + *---------------------------------------------------------------------- + */ + +static void +VersionCleanupProc ( + ClientData clientData, /* Pointer to remembered version string object + * for interp. */ + Tcl_Interp *interp) /* Interpreter that is being deleted. */ +{ + Tcl_Obj* ov = (Tcl_Obj*) clientData; + if (ov != NULL) { + Tcl_DecrRefCount (ov); + } +} + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ +#endif