os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclPkg.c
1.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
1.2 +++ b/os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclPkg.c Fri Jun 15 03:10:57 2012 +0200
1.3 @@ -0,0 +1,2405 @@
1.4 +/*
1.5 + * tclPkg.c --
1.6 + *
1.7 + * This file implements package and version control for Tcl via
1.8 + * the "package" command and a few C APIs.
1.9 + *
1.10 + * Copyright (c) 1996 Sun Microsystems, Inc.
1.11 + * Copyright (c) 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net>
1.12 + * Portions Copyright (c) 2007-2008 Nokia Corporation and/or its subsidiaries. All rights reserved.
1.13 + *
1.14 + * See the file "license.terms" for information on usage and redistribution
1.15 + * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
1.16 + *
1.17 + * RCS: @(#) $Id: tclPkg.c,v 1.9.2.9 2007/03/19 17:06:26 dgp Exp $
1.18 + *
1.19 + * TIP #268.
1.20 + * Heavily rewritten to handle the extend version numbers, and extended
1.21 + * package requirements.
1.22 + */
1.23 +
1.24 +#include "tclInt.h"
1.25 +
1.26 +/*
1.27 + * Each invocation of the "package ifneeded" command creates a structure
1.28 + * of the following type, which is used to load the package into the
1.29 + * interpreter if it is requested with a "package require" command.
1.30 + */
1.31 +
1.32 +typedef struct PkgAvail {
1.33 + char *version; /* Version string; malloc'ed. */
1.34 + char *script; /* Script to invoke to provide this version
1.35 + * of the package. Malloc'ed and protected
1.36 + * by Tcl_Preserve and Tcl_Release. */
1.37 + struct PkgAvail *nextPtr; /* Next in list of available versions of
1.38 + * the same package. */
1.39 +} PkgAvail;
1.40 +
1.41 +/*
1.42 + * For each package that is known in any way to an interpreter, there
1.43 + * is one record of the following type. These records are stored in
1.44 + * the "packageTable" hash table in the interpreter, keyed by
1.45 + * package name such as "Tk" (no version number).
1.46 + */
1.47 +
1.48 +typedef struct Package {
1.49 + char *version; /* Version that has been supplied in this
1.50 + * interpreter via "package provide"
1.51 + * (malloc'ed). NULL means the package doesn't
1.52 + * exist in this interpreter yet. */
1.53 + PkgAvail *availPtr; /* First in list of all available versions
1.54 + * of this package. */
1.55 + ClientData clientData; /* Client data. */
1.56 +} Package;
1.57 +
1.58 +/*
1.59 + * Prototypes for procedures defined in this file:
1.60 + */
1.61 +
1.62 +#ifndef TCL_TIP268
1.63 +static int CheckVersion _ANSI_ARGS_((Tcl_Interp *interp,
1.64 + CONST char *string));
1.65 +static int ComparePkgVersions _ANSI_ARGS_((CONST char *v1,
1.66 + CONST char *v2,
1.67 + int *satPtr));
1.68 +static Package * FindPackage _ANSI_ARGS_((Tcl_Interp *interp,
1.69 + CONST char *name));
1.70 +#else
1.71 +static int CheckVersionAndConvert(Tcl_Interp *interp, CONST char *string,
1.72 + char** internal, int* stable);
1.73 +static int CompareVersions(CONST char *v1i, CONST char *v2i,
1.74 + int *isMajorPtr);
1.75 +static int CheckRequirement(Tcl_Interp *interp, CONST char *string);
1.76 +static int CheckAllRequirements(Tcl_Interp* interp,
1.77 + int reqc, Tcl_Obj *CONST reqv[]);
1.78 +static int RequirementSatisfied(CONST char *havei, CONST char *req);
1.79 +static int AllRequirementsSatisfied(CONST char *havei,
1.80 + int reqc, Tcl_Obj *CONST reqv[]);
1.81 +static void AddRequirementsToResult(Tcl_Interp* interp,
1.82 + int reqc, Tcl_Obj *CONST reqv[]);
1.83 +static void AddRequirementsToDString(Tcl_DString* dstring,
1.84 + int reqc, Tcl_Obj *CONST reqv[]);
1.85 +static Package * FindPackage(Tcl_Interp *interp, CONST char *name);
1.86 +static Tcl_Obj* ExactRequirement(CONST char* version);
1.87 +static void VersionCleanupProc(ClientData clientData,
1.88 + Tcl_Interp *interp);
1.89 +#endif
1.90 +
1.91 +/*
1.92 + *----------------------------------------------------------------------
1.93 + *
1.94 + * Tcl_PkgProvide / Tcl_PkgProvideEx --
1.95 + *
1.96 + * This procedure is invoked to declare that a particular version
1.97 + * of a particular package is now present in an interpreter. There
1.98 + * must not be any other version of this package already
1.99 + * provided in the interpreter.
1.100 + *
1.101 + * Results:
1.102 + * Normally returns TCL_OK; if there is already another version
1.103 + * of the package loaded then TCL_ERROR is returned and an error
1.104 + * message is left in the interp's result.
1.105 + *
1.106 + * Side effects:
1.107 + * The interpreter remembers that this package is available,
1.108 + * so that no other version of the package may be provided for
1.109 + * the interpreter.
1.110 + *
1.111 + *----------------------------------------------------------------------
1.112 + */
1.113 +
1.114 +EXPORT_C int
1.115 +Tcl_PkgProvide(interp, name, version)
1.116 + Tcl_Interp *interp; /* Interpreter in which package is now
1.117 + * available. */
1.118 + CONST char *name; /* Name of package. */
1.119 + CONST char *version; /* Version string for package. */
1.120 +{
1.121 + return Tcl_PkgProvideEx(interp, name, version, (ClientData) NULL);
1.122 +}
1.123 +
1.124 +EXPORT_C int
1.125 +Tcl_PkgProvideEx(interp, name, version, clientData)
1.126 + Tcl_Interp *interp; /* Interpreter in which package is now
1.127 + * available. */
1.128 + CONST char *name; /* Name of package. */
1.129 + CONST char *version; /* Version string for package. */
1.130 + ClientData clientData; /* clientdata for this package (normally
1.131 + * used for C callback function table) */
1.132 +{
1.133 + Package *pkgPtr;
1.134 +#ifdef TCL_TIP268
1.135 + char* pvi;
1.136 + char* vi;
1.137 + int res;
1.138 +#endif
1.139 +
1.140 + pkgPtr = FindPackage(interp, name);
1.141 + if (pkgPtr->version == NULL) {
1.142 + pkgPtr->version = ckalloc((unsigned) (strlen(version) + 1));
1.143 + strcpy(pkgPtr->version, version);
1.144 + pkgPtr->clientData = clientData;
1.145 + return TCL_OK;
1.146 + }
1.147 +#ifndef TCL_TIP268
1.148 + if (ComparePkgVersions(pkgPtr->version, version, (int *) NULL) == 0) {
1.149 +#else
1.150 + if (CheckVersionAndConvert (interp, pkgPtr->version, &pvi, NULL) != TCL_OK) {
1.151 + return TCL_ERROR;
1.152 + } else if (CheckVersionAndConvert (interp, version, &vi, NULL) != TCL_OK) {
1.153 + Tcl_Free (pvi);
1.154 + return TCL_ERROR;
1.155 + }
1.156 +
1.157 + res = CompareVersions(pvi, vi, NULL);
1.158 + Tcl_Free (pvi);
1.159 + Tcl_Free (vi);
1.160 +
1.161 + if (res == 0) {
1.162 +#endif
1.163 + if (clientData != NULL) {
1.164 + pkgPtr->clientData = clientData;
1.165 + }
1.166 + return TCL_OK;
1.167 + }
1.168 + Tcl_AppendResult(interp, "conflicting versions provided for package \"",
1.169 + name, "\": ", pkgPtr->version, ", then ", version, (char *) NULL);
1.170 + return TCL_ERROR;
1.171 +}
1.172 +
1.173 +/*
1.174 + *----------------------------------------------------------------------
1.175 + *
1.176 + * Tcl_PkgRequire / Tcl_PkgRequireEx / Tcl_PkgRequireProc --
1.177 + *
1.178 + * This procedure is called by code that depends on a particular
1.179 + * version of a particular package. If the package is not already
1.180 + * provided in the interpreter, this procedure invokes a Tcl script
1.181 + * to provide it. If the package is already provided, this
1.182 + * procedure makes sure that the caller's needs don't conflict with
1.183 + * the version that is present.
1.184 + *
1.185 + * Results:
1.186 + * If successful, returns the version string for the currently
1.187 + * provided version of the package, which may be different from
1.188 + * the "version" argument. If the caller's requirements
1.189 + * cannot be met (e.g. the version requested conflicts with
1.190 + * a currently provided version, or the required version cannot
1.191 + * be found, or the script to provide the required version
1.192 + * generates an error), NULL is returned and an error
1.193 + * message is left in the interp's result.
1.194 + *
1.195 + * Side effects:
1.196 + * The script from some previous "package ifneeded" command may
1.197 + * be invoked to provide the package.
1.198 + *
1.199 + *----------------------------------------------------------------------
1.200 + */
1.201 +
1.202 +#ifndef TCL_TIP268
1.203 +/*
1.204 + * Empty definition for Stubs when TIP 268 is not activated.
1.205 + */
1.206 +EXPORT_C int
1.207 +Tcl_PkgRequireProc(interp,name,reqc,reqv,clientDataPtr)
1.208 + Tcl_Interp *interp; /* Interpreter in which package is now
1.209 + * available. */
1.210 + CONST char *name; /* Name of desired package. */
1.211 + int reqc; /* Requirements constraining the desired version. */
1.212 + Tcl_Obj *CONST reqv[]; /* 0 means to use the latest version available. */
1.213 + ClientData *clientDataPtr;
1.214 +{
1.215 + return TCL_ERROR;
1.216 +}
1.217 +#endif
1.218 +
1.219 +EXPORT_C CONST char *
1.220 +Tcl_PkgRequire(interp, name, version, exact)
1.221 + Tcl_Interp *interp; /* Interpreter in which package is now
1.222 + * available. */
1.223 + CONST char *name; /* Name of desired package. */
1.224 + CONST char *version; /* Version string for desired version; NULL
1.225 + * means use the latest version available. */
1.226 + int exact; /* Non-zero means that only the particular
1.227 + * version given is acceptable. Zero means use
1.228 + * the latest compatible version. */
1.229 +{
1.230 + return Tcl_PkgRequireEx(interp, name, version, exact, (ClientData *) NULL);
1.231 +}
1.232 +
1.233 +EXPORT_C CONST char *
1.234 +Tcl_PkgRequireEx(interp, name, version, exact, clientDataPtr)
1.235 + Tcl_Interp *interp; /* Interpreter in which package is now
1.236 + * available. */
1.237 + CONST char *name; /* Name of desired package. */
1.238 + CONST char *version; /* Version string for desired version;
1.239 + * NULL means use the latest version
1.240 + * available. */
1.241 + int exact; /* Non-zero means that only the particular
1.242 + * version given is acceptable. Zero means
1.243 + * use the latest compatible version. */
1.244 + ClientData *clientDataPtr; /* Used to return the client data for this
1.245 + * package. If it is NULL then the client
1.246 + * data is not returned. This is unchanged
1.247 + * if this call fails for any reason. */
1.248 +{
1.249 +#ifndef TCL_TIP268
1.250 + Package *pkgPtr;
1.251 + PkgAvail *availPtr, *bestPtr;
1.252 + char *script;
1.253 + int code, satisfies, result, pass;
1.254 + Tcl_DString command;
1.255 +#else
1.256 + Tcl_Obj *ov;
1.257 + int res;
1.258 +#endif
1.259 +
1.260 + /*
1.261 + * If an attempt is being made to load this into a standalone executable
1.262 + * on a platform where backlinking is not supported then this must be
1.263 + * a shared version of Tcl (Otherwise the load would have failed).
1.264 + * Detect this situation by checking that this library has been correctly
1.265 + * initialised. If it has not been then return immediately as nothing will
1.266 + * work.
1.267 + */
1.268 +
1.269 + if (tclEmptyStringRep == NULL) {
1.270 +
1.271 + /*
1.272 + * OK, so what's going on here?
1.273 + *
1.274 + * First, what are we doing? We are performing a check on behalf of
1.275 + * one particular caller, Tcl_InitStubs(). When a package is
1.276 + * stub-enabled, it is statically linked to libtclstub.a, which
1.277 + * contains a copy of Tcl_InitStubs(). When a stub-enabled package
1.278 + * is loaded, its *_Init() function is supposed to call
1.279 + * Tcl_InitStubs() before calling any other functions in the Tcl
1.280 + * library. The first Tcl function called by Tcl_InitStubs() through
1.281 + * the stub table is Tcl_PkgRequireEx(), so this code right here is
1.282 + * the first code that is part of the original Tcl library in the
1.283 + * executable that gets executed on behalf of a newly loaded
1.284 + * stub-enabled package.
1.285 + *
1.286 + * One easy error for the developer/builder of a stub-enabled package
1.287 + * to make is to forget to define USE_TCL_STUBS when compiling the
1.288 + * package. When that happens, the package will contain symbols
1.289 + * that are references to the Tcl library, rather than function
1.290 + * pointers referencing the stub table. On platforms that lack
1.291 + * backlinking, those unresolved references may cause the loading
1.292 + * of the package to also load a second copy of the Tcl library,
1.293 + * leading to all kinds of trouble. We would like to catch that
1.294 + * error and report a useful message back to the user. That's
1.295 + * what we're doing.
1.296 + *
1.297 + * Second, how does this work? If we reach this point, then the
1.298 + * global variable tclEmptyStringRep has the value NULL. Compare
1.299 + * that with the definition of tclEmptyStringRep near the top of
1.300 + * the file generic/tclObj.c. It clearly should not have the value
1.301 + * NULL; it should point to the char tclEmptyString. If we see it
1.302 + * having the value NULL, then somehow we are seeing a Tcl library
1.303 + * that isn't completely initialized, and that's an indicator for the
1.304 + * error condition described above. (Further explanation is welcome.)
1.305 + *
1.306 + * Third, so what do we do about it? This situation indicates
1.307 + * the package we just loaded wasn't properly compiled to be
1.308 + * stub-enabled, yet it thinks it is stub-enabled (it called
1.309 + * Tcl_InitStubs()). We want to report that the package just
1.310 + * loaded is broken, so we want to place an error message in
1.311 + * the interpreter result and return NULL to indicate failure
1.312 + * to Tcl_InitStubs() so that it will also fail. (Further
1.313 + * explanation why we don't want to Tcl_Panic() is welcome.
1.314 + * After all, two Tcl libraries can't be a good thing!)
1.315 + *
1.316 + * Trouble is that's going to be tricky. We're now using a Tcl
1.317 + * library that's not fully initialized. In particular, it
1.318 + * doesn't have a proper value for tclEmptyStringRep. The
1.319 + * Tcl_Obj system heavily depends on the value of tclEmptyStringRep
1.320 + * and all of Tcl depends (increasingly) on the Tcl_Obj system, we
1.321 + * need to correct that flaw before making the calls to set the
1.322 + * interpreter result to the error message. That's the only flaw
1.323 + * corrected; other problems with initialization of the Tcl library
1.324 + * are not remedied, so be very careful about adding any other calls
1.325 + * here without checking how they behave when initialization is
1.326 + * incomplete.
1.327 + */
1.328 +
1.329 + tclEmptyStringRep = &tclEmptyString;
1.330 + Tcl_AppendResult(interp, "Cannot load package \"", name,
1.331 + "\" in standalone executable: This package is not ",
1.332 + "compiled with stub support", NULL);
1.333 + return NULL;
1.334 + }
1.335 +
1.336 +#ifdef TCL_TIP268
1.337 + /* Translate between old and new API, and defer to the new function. */
1.338 +
1.339 + if (version == NULL) {
1.340 + res = Tcl_PkgRequireProc(interp, name, 0, NULL, clientDataPtr);
1.341 + } else {
1.342 + if (exact) {
1.343 + ov = ExactRequirement (version);
1.344 + } else {
1.345 + ov = Tcl_NewStringObj (version,-1);
1.346 + }
1.347 +
1.348 + Tcl_IncrRefCount (ov);
1.349 + res = Tcl_PkgRequireProc(interp, name, 1, &ov, clientDataPtr);
1.350 + Tcl_DecrRefCount (ov);
1.351 + }
1.352 +
1.353 + if (res != TCL_OK) {
1.354 + return NULL;
1.355 + }
1.356 +
1.357 + /* This function returns the version string explictly, and leaves the
1.358 + * interpreter result empty. However "Tcl_PkgRequireProc" above returned
1.359 + * the version through the interpreter result. Simply resetting the result
1.360 + * now potentially deletes the string (obj), and the pointer to its string
1.361 + * rep we have, as our result, may be dangling due to this. Our solution
1.362 + * is to remember the object in interp associated data, with a proper
1.363 + * reference count, and then reset the result. Now pointers will not
1.364 + * dangle. It will be a leak however if nothing is done. So the next time
1.365 + * we come through here we delete the object remembered by this call, as
1.366 + * we can then be sure that there is no pointer to its string around
1.367 + * anymore. Beyond that we have a deletion function which cleans up the last
1.368 + * remembered object which was not cleaned up directly, here.
1.369 + */
1.370 +
1.371 + ov = (Tcl_Obj*) Tcl_GetAssocData (interp, "tcl/Tcl_PkgRequireEx", NULL);
1.372 + if (ov != NULL) {
1.373 + Tcl_DecrRefCount (ov);
1.374 + }
1.375 +
1.376 + ov = Tcl_GetObjResult (interp);
1.377 + Tcl_IncrRefCount (ov);
1.378 + Tcl_SetAssocData(interp, "tcl/Tcl_PkgRequireEx", VersionCleanupProc,
1.379 + (ClientData) ov);
1.380 + Tcl_ResetResult (interp);
1.381 +
1.382 + return Tcl_GetString (ov);
1.383 +}
1.384 +
1.385 +EXPORT_C int
1.386 +Tcl_PkgRequireProc(interp,name,reqc,reqv,clientDataPtr)
1.387 + Tcl_Interp *interp; /* Interpreter in which package is now
1.388 + * available. */
1.389 + CONST char *name; /* Name of desired package. */
1.390 + int reqc; /* Requirements constraining the desired version. */
1.391 + Tcl_Obj *CONST reqv[]; /* 0 means to use the latest version available. */
1.392 + ClientData *clientDataPtr;
1.393 +{
1.394 + Interp *iPtr = (Interp *) interp;
1.395 + Package *pkgPtr;
1.396 + PkgAvail *availPtr, *bestPtr, *bestStablePtr;
1.397 + char *availVersion, *bestVersion; /* Internal rep. of versions */
1.398 + int availStable;
1.399 + char *script;
1.400 + int code, satisfies, pass;
1.401 + Tcl_DString command;
1.402 + char* pkgVersionI;
1.403 +
1.404 +#endif
1.405 + /*
1.406 + * It can take up to three passes to find the package: one pass to run the
1.407 + * "package unknown" script, one to run the "package ifneeded" script for
1.408 + * a specific version, and a final pass to lookup the package loaded by
1.409 + * the "package ifneeded" script.
1.410 + */
1.411 +
1.412 + for (pass = 1; ; pass++) {
1.413 + pkgPtr = FindPackage(interp, name);
1.414 + if (pkgPtr->version != NULL) {
1.415 + break;
1.416 + }
1.417 +
1.418 + /*
1.419 + * Check whether we're already attempting to load some version
1.420 + * of this package (circular dependency detection).
1.421 + */
1.422 +
1.423 + if (pkgPtr->clientData != NULL) {
1.424 + Tcl_AppendResult(interp, "circular package dependency: ",
1.425 + "attempt to provide ", name, " ",
1.426 + (char *)(pkgPtr->clientData), " requires ", name, NULL);
1.427 +#ifndef TCL_TIP268
1.428 + if (version != NULL) {
1.429 + Tcl_AppendResult(interp, " ", version, NULL);
1.430 + }
1.431 + return NULL;
1.432 +#else
1.433 + AddRequirementsToResult (interp, reqc, reqv);
1.434 + return TCL_ERROR;
1.435 +#endif
1.436 + }
1.437 +
1.438 + /*
1.439 + * The package isn't yet present. Search the list of available
1.440 + * versions and invoke the script for the best available version.
1.441 + *
1.442 + * For TIP 268 we are actually locating the best, and the best stable
1.443 + * version. One of them is then chosen based on the selection mode.
1.444 + */
1.445 +#ifndef TCL_TIP268
1.446 + bestPtr = NULL;
1.447 + for (availPtr = pkgPtr->availPtr; availPtr != NULL;
1.448 + availPtr = availPtr->nextPtr) {
1.449 + if ((bestPtr != NULL) && (ComparePkgVersions(availPtr->version,
1.450 + bestPtr->version, (int *) NULL) <= 0)) {
1.451 +#else
1.452 + bestPtr = NULL;
1.453 + bestStablePtr = NULL;
1.454 + bestVersion = NULL;
1.455 +
1.456 + for (availPtr = pkgPtr->availPtr;
1.457 + availPtr != NULL;
1.458 + availPtr = availPtr->nextPtr) {
1.459 + if (CheckVersionAndConvert (interp, availPtr->version,
1.460 + &availVersion, &availStable) != TCL_OK) {
1.461 + /* The provided version number is has invalid syntax. This
1.462 + * should not happen. This should have been caught by the
1.463 + * 'package ifneeded' registering the package.
1.464 + */
1.465 +#endif
1.466 + continue;
1.467 + }
1.468 +#ifndef TCL_TIP268
1.469 + if (version != NULL) {
1.470 + result = ComparePkgVersions(availPtr->version, version,
1.471 + &satisfies);
1.472 + if ((result != 0) && exact) {
1.473 +#else
1.474 + if (bestPtr != NULL) {
1.475 + int res = CompareVersions (availVersion, bestVersion, NULL);
1.476 + /* Note: Use internal reps! */
1.477 + if (res <= 0) {
1.478 + /* The version of the package sought is not as good as the
1.479 + * currently selected version. Ignore it. */
1.480 + Tcl_Free (availVersion);
1.481 + availVersion = NULL;
1.482 +#endif
1.483 + continue;
1.484 + }
1.485 +#ifdef TCL_TIP268
1.486 + }
1.487 +
1.488 + /* We have found a version which is better than our max. */
1.489 +
1.490 + if (reqc > 0) {
1.491 + /* Check satisfaction of requirements */
1.492 + satisfies = AllRequirementsSatisfied (availVersion, reqc, reqv);
1.493 +#endif
1.494 + if (!satisfies) {
1.495 +#ifdef TCL_TIP268
1.496 + Tcl_Free (availVersion);
1.497 + availVersion = NULL;
1.498 +#endif
1.499 + continue;
1.500 + }
1.501 + }
1.502 + bestPtr = availPtr;
1.503 +#ifdef TCL_TIP268
1.504 + if (bestVersion != NULL) Tcl_Free (bestVersion);
1.505 + bestVersion = availVersion;
1.506 + availVersion = NULL;
1.507 +
1.508 + /* If this new best version is stable then it also has to be
1.509 + * better than the max stable version found so far.
1.510 + */
1.511 +
1.512 + if (availStable) {
1.513 + bestStablePtr = availPtr;
1.514 + }
1.515 + }
1.516 +
1.517 + if (bestVersion != NULL) {
1.518 + Tcl_Free (bestVersion);
1.519 + }
1.520 +
1.521 + /* Now choose a version among the two best. For 'latest' we simply
1.522 + * take (actually keep) the best. For 'stable' we take the best
1.523 + * stable, if there is any, or the best if there is nothing stable.
1.524 + */
1.525 +
1.526 + if ((iPtr->packagePrefer == PKG_PREFER_STABLE) && (bestStablePtr != NULL)) {
1.527 + bestPtr = bestStablePtr;
1.528 +#endif
1.529 + }
1.530 + if (bestPtr != NULL) {
1.531 + /*
1.532 + * We found an ifneeded script for the package. Be careful while
1.533 + * executing it: this could cause reentrancy, so (a) protect the
1.534 + * script itself from deletion and (b) don't assume that bestPtr
1.535 + * will still exist when the script completes.
1.536 + */
1.537 +
1.538 + CONST char *versionToProvide = bestPtr->version;
1.539 + script = bestPtr->script;
1.540 + pkgPtr->clientData = (ClientData) versionToProvide;
1.541 + Tcl_Preserve((ClientData) script);
1.542 + Tcl_Preserve((ClientData) versionToProvide);
1.543 + code = Tcl_EvalEx(interp, script, -1, TCL_EVAL_GLOBAL);
1.544 + Tcl_Release((ClientData) script);
1.545 + pkgPtr = FindPackage(interp, name);
1.546 + if (code == TCL_OK) {
1.547 +#ifdef TCL_TIP268
1.548 + Tcl_ResetResult(interp);
1.549 +#endif
1.550 + if (pkgPtr->version == NULL) {
1.551 +#ifndef TCL_TIP268
1.552 + Tcl_ResetResult(interp);
1.553 +#endif
1.554 + code = TCL_ERROR;
1.555 + Tcl_AppendResult(interp, "attempt to provide package ",
1.556 + name, " ", versionToProvide,
1.557 + " failed: no version of package ", name,
1.558 + " provided", NULL);
1.559 +#ifndef TCL_TIP268
1.560 + } else if (0 != ComparePkgVersions(
1.561 + pkgPtr->version, versionToProvide, NULL)) {
1.562 + /* At this point, it is clear that a prior
1.563 + * [package ifneeded] command lied to us. It said
1.564 + * that to get a particular version of a particular
1.565 + * package, we needed to evaluate a particular script.
1.566 + * However, we evaluated that script and got a different
1.567 + * version than we were told. This is an error, and we
1.568 + * ought to report it.
1.569 + *
1.570 + * However, we've been letting this type of error slide
1.571 + * for a long time, and as a result, a lot of packages
1.572 + * suffer from them.
1.573 + *
1.574 + * It's a bit too harsh to make a large number of
1.575 + * existing packages start failing by releasing a
1.576 + * new patch release, so we forgive this type of error
1.577 + * for the rest of the Tcl 8.4 series.
1.578 + *
1.579 + * We considered reporting a warning, but in practice
1.580 + * even that appears too harsh a change for a patch release.
1.581 + *
1.582 + * We limit the error reporting to only
1.583 + * the situation where a broken ifneeded script leads
1.584 + * to a failure to satisfy the requirement.
1.585 + */
1.586 + if (version) {
1.587 + result = ComparePkgVersions(
1.588 + pkgPtr->version, version, &satisfies);
1.589 + if (result && (exact || !satisfies)) {
1.590 + Tcl_ResetResult(interp);
1.591 + code = TCL_ERROR;
1.592 + Tcl_AppendResult(interp,
1.593 + "attempt to provide package ", name, " ",
1.594 + versionToProvide, " failed: package ",
1.595 + name, " ", pkgPtr->version,
1.596 + " provided instead", NULL);
1.597 +#else
1.598 + } else {
1.599 + char* pvi;
1.600 + char* vi;
1.601 + int res;
1.602 +
1.603 + if (CheckVersionAndConvert (interp, pkgPtr->version, &pvi, NULL) != TCL_OK) {
1.604 + code = TCL_ERROR;
1.605 + } else if (CheckVersionAndConvert (interp, versionToProvide, &vi, NULL) != TCL_OK) {
1.606 + Tcl_Free (pvi);
1.607 + code = TCL_ERROR;
1.608 + } else {
1.609 + res = CompareVersions(pvi, vi, NULL);
1.610 + Tcl_Free (vi);
1.611 +
1.612 + if (res != 0) {
1.613 + /* At this point, it is clear that a prior
1.614 + * [package ifneeded] command lied to us. It said
1.615 + * that to get a particular version of a particular
1.616 + * package, we needed to evaluate a particular script.
1.617 + * However, we evaluated that script and got a different
1.618 + * version than we were told. This is an error, and we
1.619 + * ought to report it.
1.620 + *
1.621 + * However, we've been letting this type of error slide
1.622 + * for a long time, and as a result, a lot of packages
1.623 + * suffer from them.
1.624 + *
1.625 + * It's a bit too harsh to make a large number of
1.626 + * existing packages start failing by releasing a
1.627 + * new patch release, so we forgive this type of error
1.628 + * for the rest of the Tcl 8.4 series.
1.629 + *
1.630 + * We considered reporting a warning, but in practice
1.631 + * even that appears too harsh a change for a patch release.
1.632 + *
1.633 + * We limit the error reporting to only
1.634 + * the situation where a broken ifneeded script leads
1.635 + * to a failure to satisfy the requirement.
1.636 + */
1.637 +
1.638 + if (reqc > 0) {
1.639 + satisfies = AllRequirementsSatisfied (pvi, reqc, reqv);
1.640 + if (!satisfies) {
1.641 + Tcl_ResetResult(interp);
1.642 + code = TCL_ERROR;
1.643 + Tcl_AppendResult(interp,
1.644 + "attempt to provide package ", name, " ",
1.645 + versionToProvide, " failed: package ",
1.646 + name, " ", pkgPtr->version,
1.647 + " provided instead", NULL);
1.648 + }
1.649 + }
1.650 + /*
1.651 + * Warning generation now disabled
1.652 + if (code == TCL_OK) {
1.653 + Tcl_Obj *msg = Tcl_NewStringObj(
1.654 + "attempt to provide package ", -1);
1.655 + Tcl_Obj *cmdPtr = Tcl_NewListObj(0, NULL);
1.656 + Tcl_ListObjAppendElement(NULL, cmdPtr,
1.657 + Tcl_NewStringObj("tclLog", -1));
1.658 + Tcl_AppendStringsToObj(msg, name, " ", versionToProvide,
1.659 + " failed: package ", name, " ",
1.660 + pkgPtr->version, " provided instead", NULL);
1.661 + Tcl_ListObjAppendElement(NULL, cmdPtr, msg);
1.662 + Tcl_IncrRefCount(cmdPtr);
1.663 + Tcl_EvalObjEx(interp, cmdPtr, TCL_EVAL_GLOBAL);
1.664 + Tcl_DecrRefCount(cmdPtr);
1.665 + Tcl_ResetResult(interp);
1.666 + }
1.667 + */
1.668 +#endif
1.669 + }
1.670 +#ifdef TCL_TIP268
1.671 + Tcl_Free (pvi);
1.672 +#endif
1.673 + }
1.674 +#ifndef TCL_TIP268
1.675 + /*
1.676 + * Warning generation now disabled
1.677 + if (code == TCL_OK) {
1.678 + Tcl_Obj *msg = Tcl_NewStringObj(
1.679 + "attempt to provide package ", -1);
1.680 + Tcl_Obj *cmdPtr = Tcl_NewListObj(0, NULL);
1.681 + Tcl_ListObjAppendElement(NULL, cmdPtr,
1.682 + Tcl_NewStringObj("tclLog", -1));
1.683 + Tcl_AppendStringsToObj(msg, name, " ", versionToProvide,
1.684 + " failed: package ", name, " ",
1.685 + pkgPtr->version, " provided instead", NULL);
1.686 + Tcl_ListObjAppendElement(NULL, cmdPtr, msg);
1.687 + Tcl_IncrRefCount(cmdPtr);
1.688 + Tcl_EvalObjEx(interp, cmdPtr, TCL_EVAL_GLOBAL);
1.689 + Tcl_DecrRefCount(cmdPtr);
1.690 + Tcl_ResetResult(interp);
1.691 + }
1.692 + */
1.693 +#endif
1.694 + }
1.695 + } else if (code != TCL_ERROR) {
1.696 + Tcl_Obj *codePtr = Tcl_NewIntObj(code);
1.697 + Tcl_ResetResult(interp);
1.698 + Tcl_AppendResult(interp, "attempt to provide package ",
1.699 + name, " ", versionToProvide, " failed: ",
1.700 + "bad return code: ", Tcl_GetString(codePtr), NULL);
1.701 + Tcl_DecrRefCount(codePtr);
1.702 + code = TCL_ERROR;
1.703 + }
1.704 + Tcl_Release((ClientData) versionToProvide);
1.705 +
1.706 + if (code != TCL_OK) {
1.707 + /*
1.708 + * Take a non-TCL_OK code from the script as an
1.709 + * indication the package wasn't loaded properly,
1.710 + * so the package system should not remember an
1.711 + * improper load.
1.712 + *
1.713 + * This is consistent with our returning NULL.
1.714 + * If we're not willing to tell our caller we
1.715 + * got a particular version, we shouldn't store
1.716 + * that version for telling future callers either.
1.717 + */
1.718 + Tcl_AddErrorInfo(interp, "\n (\"package ifneeded\" script)");
1.719 + if (pkgPtr->version != NULL) {
1.720 + ckfree(pkgPtr->version);
1.721 + pkgPtr->version = NULL;
1.722 + }
1.723 + pkgPtr->clientData = NULL;
1.724 +#ifndef TCL_TIP268
1.725 + return NULL;
1.726 +#else
1.727 + return TCL_ERROR;
1.728 +#endif
1.729 + }
1.730 + break;
1.731 + }
1.732 +
1.733 + /*
1.734 + * The package is not in the database. If there is a "package unknown"
1.735 + * command, invoke it (but only on the first pass; after that, we
1.736 + * should not get here in the first place).
1.737 + */
1.738 +
1.739 + if (pass > 1) {
1.740 + break;
1.741 + }
1.742 + script = ((Interp *) interp)->packageUnknown;
1.743 + if (script != NULL) {
1.744 + Tcl_DStringInit(&command);
1.745 + Tcl_DStringAppend(&command, script, -1);
1.746 + Tcl_DStringAppendElement(&command, name);
1.747 +#ifndef TCL_TIP268
1.748 + Tcl_DStringAppend(&command, " ", 1);
1.749 + Tcl_DStringAppend(&command, (version != NULL) ? version : "{}",
1.750 + -1);
1.751 + if (exact) {
1.752 + Tcl_DStringAppend(&command, " -exact", 7);
1.753 + }
1.754 +#else
1.755 + AddRequirementsToDString(&command, reqc, reqv);
1.756 +#endif
1.757 + code = Tcl_EvalEx(interp, Tcl_DStringValue(&command),
1.758 + Tcl_DStringLength(&command), TCL_EVAL_GLOBAL);
1.759 + Tcl_DStringFree(&command);
1.760 + if ((code != TCL_OK) && (code != TCL_ERROR)) {
1.761 + Tcl_Obj *codePtr = Tcl_NewIntObj(code);
1.762 + Tcl_ResetResult(interp);
1.763 + Tcl_AppendResult(interp, "bad return code: ",
1.764 + Tcl_GetString(codePtr), NULL);
1.765 + Tcl_DecrRefCount(codePtr);
1.766 + code = TCL_ERROR;
1.767 + }
1.768 + if (code == TCL_ERROR) {
1.769 + Tcl_AddErrorInfo(interp, "\n (\"package unknown\" script)");
1.770 +#ifndef TCL_TIP268
1.771 + return NULL;
1.772 +#else
1.773 + return TCL_ERROR;
1.774 +#endif
1.775 + }
1.776 + Tcl_ResetResult(interp);
1.777 + }
1.778 + }
1.779 +
1.780 + if (pkgPtr->version == NULL) {
1.781 + Tcl_AppendResult(interp, "can't find package ", name, (char *) NULL);
1.782 +#ifndef TCL_TIP268
1.783 + if (version != NULL) {
1.784 + Tcl_AppendResult(interp, " ", version, (char *) NULL);
1.785 + }
1.786 + return NULL;
1.787 +#else
1.788 + AddRequirementsToResult(interp, reqc, reqv);
1.789 + return TCL_ERROR;
1.790 +#endif
1.791 + }
1.792 +
1.793 + /*
1.794 + * At this point we know that the package is present. Make sure that the
1.795 + * provided version meets the current requirements.
1.796 + */
1.797 +
1.798 +#ifndef TCL_TIP268
1.799 + if (version == NULL) {
1.800 + if (clientDataPtr) {
1.801 + *clientDataPtr = pkgPtr->clientData;
1.802 + }
1.803 + return pkgPtr->version;
1.804 +#else
1.805 + if (reqc == 0) {
1.806 + satisfies = 1;
1.807 + } else {
1.808 + CheckVersionAndConvert (interp, pkgPtr->version, &pkgVersionI, NULL);
1.809 + satisfies = AllRequirementsSatisfied (pkgVersionI, reqc, reqv);
1.810 +
1.811 + Tcl_Free (pkgVersionI);
1.812 +#endif
1.813 + }
1.814 +#ifndef TCL_TIP268
1.815 + result = ComparePkgVersions(pkgPtr->version, version, &satisfies);
1.816 + if ((satisfies && !exact) || (result == 0)) {
1.817 +#else
1.818 + if (satisfies) {
1.819 +#endif
1.820 + if (clientDataPtr) {
1.821 + *clientDataPtr = pkgPtr->clientData;
1.822 + }
1.823 +#ifndef TCL_TIP268
1.824 + return pkgPtr->version;
1.825 +#else
1.826 + Tcl_SetObjResult (interp, Tcl_NewStringObj (pkgPtr->version, -1));
1.827 + return TCL_OK;
1.828 +#endif
1.829 + }
1.830 + Tcl_AppendResult(interp, "version conflict for package \"",
1.831 + name, "\": have ", pkgPtr->version,
1.832 +#ifndef TCL_TIP268
1.833 + ", need ", version, (char *) NULL);
1.834 + return NULL;
1.835 +#else
1.836 + ", need", (char*) NULL);
1.837 + AddRequirementsToResult (interp, reqc, reqv);
1.838 + return TCL_ERROR;
1.839 +#endif
1.840 +}
1.841 +
1.842 +/*
1.843 + *----------------------------------------------------------------------
1.844 + *
1.845 + * Tcl_PkgPresent / Tcl_PkgPresentEx --
1.846 + *
1.847 + * Checks to see whether the specified package is present. If it
1.848 + * is not then no additional action is taken.
1.849 + *
1.850 + * Results:
1.851 + * If successful, returns the version string for the currently
1.852 + * provided version of the package, which may be different from
1.853 + * the "version" argument. If the caller's requirements
1.854 + * cannot be met (e.g. the version requested conflicts with
1.855 + * a currently provided version), NULL is returned and an error
1.856 + * message is left in interp->result.
1.857 + *
1.858 + * Side effects:
1.859 + * None.
1.860 + *
1.861 + *----------------------------------------------------------------------
1.862 + */
1.863 +
1.864 +EXPORT_C CONST char *
1.865 +Tcl_PkgPresent(interp, name, version, exact)
1.866 + Tcl_Interp *interp; /* Interpreter in which package is now
1.867 + * available. */
1.868 + CONST char *name; /* Name of desired package. */
1.869 + CONST char *version; /* Version string for desired version;
1.870 + * NULL means use the latest version
1.871 + * available. */
1.872 + int exact; /* Non-zero means that only the particular
1.873 + * version given is acceptable. Zero means
1.874 + * use the latest compatible version. */
1.875 +{
1.876 + return Tcl_PkgPresentEx(interp, name, version, exact, (ClientData *) NULL);
1.877 +}
1.878 +
1.879 +EXPORT_C CONST char *
1.880 +Tcl_PkgPresentEx(interp, name, version, exact, clientDataPtr)
1.881 + Tcl_Interp *interp; /* Interpreter in which package is now
1.882 + * available. */
1.883 + CONST char *name; /* Name of desired package. */
1.884 + CONST char *version; /* Version string for desired version;
1.885 + * NULL means use the latest version
1.886 + * available. */
1.887 + int exact; /* Non-zero means that only the particular
1.888 + * version given is acceptable. Zero means
1.889 + * use the latest compatible version. */
1.890 + ClientData *clientDataPtr; /* Used to return the client data for this
1.891 + * package. If it is NULL then the client
1.892 + * data is not returned. This is unchanged
1.893 + * if this call fails for any reason. */
1.894 +{
1.895 + Interp *iPtr = (Interp *) interp;
1.896 + Tcl_HashEntry *hPtr;
1.897 + Package *pkgPtr;
1.898 + int satisfies, result;
1.899 +
1.900 + hPtr = Tcl_FindHashEntry(&iPtr->packageTable, name);
1.901 + if (hPtr) {
1.902 + pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
1.903 + if (pkgPtr->version != NULL) {
1.904 +#ifdef TCL_TIP268
1.905 + char* pvi;
1.906 + char* vi;
1.907 + int thisIsMajor;
1.908 +#endif
1.909 +
1.910 + /*
1.911 + * At this point we know that the package is present. Make sure
1.912 + * that the provided version meets the current requirement.
1.913 + */
1.914 +
1.915 + if (version == NULL) {
1.916 + if (clientDataPtr) {
1.917 + *clientDataPtr = pkgPtr->clientData;
1.918 + }
1.919 +
1.920 + return pkgPtr->version;
1.921 + }
1.922 +#ifndef TCL_TIP268
1.923 + result = ComparePkgVersions(pkgPtr->version, version, &satisfies);
1.924 +#else
1.925 + if (CheckVersionAndConvert (interp, pkgPtr->version, &pvi, NULL) != TCL_OK) {
1.926 + return NULL;
1.927 + } else if (CheckVersionAndConvert (interp, version, &vi, NULL) != TCL_OK) {
1.928 + Tcl_Free (pvi);
1.929 + return NULL;
1.930 + }
1.931 + result = CompareVersions(pvi, vi, &thisIsMajor);
1.932 + Tcl_Free (pvi);
1.933 + Tcl_Free (vi);
1.934 + satisfies = (result == 0) || ((result == 1) && !thisIsMajor);
1.935 +#endif
1.936 + if ((satisfies && !exact) || (result == 0)) {
1.937 + if (clientDataPtr) {
1.938 + *clientDataPtr = pkgPtr->clientData;
1.939 + }
1.940 +
1.941 + return pkgPtr->version;
1.942 + }
1.943 + Tcl_AppendResult(interp, "version conflict for package \"",
1.944 + name, "\": have ", pkgPtr->version,
1.945 + ", need ", version, (char *) NULL);
1.946 + return NULL;
1.947 + }
1.948 + }
1.949 +
1.950 + if (version != NULL) {
1.951 + Tcl_AppendResult(interp, "package ", name, " ", version,
1.952 + " is not present", (char *) NULL);
1.953 + } else {
1.954 + Tcl_AppendResult(interp, "package ", name, " is not present",
1.955 + (char *) NULL);
1.956 + }
1.957 + return NULL;
1.958 +}
1.959 +
1.960 +/*
1.961 + *----------------------------------------------------------------------
1.962 + *
1.963 + * Tcl_PackageObjCmd --
1.964 + *
1.965 + * This procedure is invoked to process the "package" Tcl command.
1.966 + * See the user documentation for details on what it does.
1.967 + *
1.968 + * Results:
1.969 + * A standard Tcl result.
1.970 + *
1.971 + * Side effects:
1.972 + * See the user documentation.
1.973 + *
1.974 + *----------------------------------------------------------------------
1.975 + */
1.976 +
1.977 +/* ARGSUSED */
1.978 +int
1.979 +Tcl_PackageObjCmd(dummy, interp, objc, objv)
1.980 + ClientData dummy; /* Not used. */
1.981 + Tcl_Interp *interp; /* Current interpreter. */
1.982 + int objc; /* Number of arguments. */
1.983 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.984 +{
1.985 + static CONST char *pkgOptions[] = {
1.986 + "forget", "ifneeded", "names",
1.987 +#ifdef TCL_TIP268
1.988 + "prefer",
1.989 +#endif
1.990 + "present", "provide", "require", "unknown", "vcompare",
1.991 + "versions", "vsatisfies", (char *) NULL
1.992 + };
1.993 + enum pkgOptions {
1.994 + PKG_FORGET, PKG_IFNEEDED, PKG_NAMES,
1.995 +#ifdef TCL_TIP268
1.996 + PKG_PREFER,
1.997 +#endif
1.998 + PKG_PRESENT, PKG_PROVIDE, PKG_REQUIRE, PKG_UNKNOWN, PKG_VCOMPARE,
1.999 + PKG_VERSIONS, PKG_VSATISFIES
1.1000 + };
1.1001 + Interp *iPtr = (Interp *) interp;
1.1002 + int optionIndex, exact, i, satisfies;
1.1003 + PkgAvail *availPtr, *prevPtr;
1.1004 + Package *pkgPtr;
1.1005 + Tcl_HashEntry *hPtr;
1.1006 + Tcl_HashSearch search;
1.1007 + Tcl_HashTable *tablePtr;
1.1008 + CONST char *version;
1.1009 + char *argv2, *argv3, *argv4;
1.1010 +#ifdef TCL_TIP268
1.1011 + char* iva = NULL;
1.1012 + char* ivb = NULL;
1.1013 +#endif
1.1014 +
1.1015 + if (objc < 2) {
1.1016 + Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?");
1.1017 + return TCL_ERROR;
1.1018 + }
1.1019 +
1.1020 + if (Tcl_GetIndexFromObj(interp, objv[1], pkgOptions, "option", 0,
1.1021 + &optionIndex) != TCL_OK) {
1.1022 + return TCL_ERROR;
1.1023 + }
1.1024 + switch ((enum pkgOptions) optionIndex) {
1.1025 +#ifndef TCL_TIP268
1.1026 + case PKG_FORGET: {
1.1027 + char *keyString;
1.1028 + for (i = 2; i < objc; i++) {
1.1029 + keyString = Tcl_GetString(objv[i]);
1.1030 + hPtr = Tcl_FindHashEntry(&iPtr->packageTable, keyString);
1.1031 + if (hPtr == NULL) {
1.1032 + continue;
1.1033 + }
1.1034 + pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
1.1035 + Tcl_DeleteHashEntry(hPtr);
1.1036 + if (pkgPtr->version != NULL) {
1.1037 + ckfree(pkgPtr->version);
1.1038 + }
1.1039 + while (pkgPtr->availPtr != NULL) {
1.1040 + availPtr = pkgPtr->availPtr;
1.1041 + pkgPtr->availPtr = availPtr->nextPtr;
1.1042 + Tcl_EventuallyFree((ClientData)availPtr->version, TCL_DYNAMIC);
1.1043 + Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC);
1.1044 + ckfree((char *) availPtr);
1.1045 + }
1.1046 + ckfree((char *) pkgPtr);
1.1047 + }
1.1048 + break;
1.1049 +#else
1.1050 + case PKG_FORGET: {
1.1051 + char *keyString;
1.1052 + for (i = 2; i < objc; i++) {
1.1053 + keyString = Tcl_GetString(objv[i]);
1.1054 + hPtr = Tcl_FindHashEntry(&iPtr->packageTable, keyString);
1.1055 + if (hPtr == NULL) {
1.1056 + continue;
1.1057 + }
1.1058 + pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
1.1059 + Tcl_DeleteHashEntry(hPtr);
1.1060 + if (pkgPtr->version != NULL) {
1.1061 + ckfree(pkgPtr->version);
1.1062 + }
1.1063 + while (pkgPtr->availPtr != NULL) {
1.1064 + availPtr = pkgPtr->availPtr;
1.1065 + pkgPtr->availPtr = availPtr->nextPtr;
1.1066 + Tcl_EventuallyFree((ClientData)availPtr->version, TCL_DYNAMIC);
1.1067 + Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC);
1.1068 + ckfree((char *) availPtr);
1.1069 + }
1.1070 + ckfree((char *) pkgPtr);
1.1071 + }
1.1072 + break;
1.1073 + }
1.1074 + case PKG_IFNEEDED: {
1.1075 + int length;
1.1076 + char* argv3i;
1.1077 + char* avi;
1.1078 + int res;
1.1079 +
1.1080 + if ((objc != 4) && (objc != 5)) {
1.1081 + Tcl_WrongNumArgs(interp, 2, objv, "package version ?script?");
1.1082 + return TCL_ERROR;
1.1083 + }
1.1084 + argv3 = Tcl_GetString(objv[3]);
1.1085 + if (CheckVersionAndConvert(interp, argv3, &argv3i, NULL) != TCL_OK) {
1.1086 + return TCL_ERROR;
1.1087 +#endif
1.1088 + }
1.1089 +#ifndef TCL_TIP268
1.1090 + case PKG_IFNEEDED: {
1.1091 + int length;
1.1092 + if ((objc != 4) && (objc != 5)) {
1.1093 + Tcl_WrongNumArgs(interp, 2, objv, "package version ?script?");
1.1094 + return TCL_ERROR;
1.1095 +#else
1.1096 + argv2 = Tcl_GetString(objv[2]);
1.1097 + if (objc == 4) {
1.1098 + hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2);
1.1099 + if (hPtr == NULL) {
1.1100 + Tcl_Free (argv3i);
1.1101 + return TCL_OK;
1.1102 +#endif
1.1103 + }
1.1104 +#ifndef TCL_TIP268
1.1105 + argv3 = Tcl_GetString(objv[3]);
1.1106 + if (CheckVersion(interp, argv3) != TCL_OK) {
1.1107 +#else
1.1108 + pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
1.1109 + } else {
1.1110 + pkgPtr = FindPackage(interp, argv2);
1.1111 + }
1.1112 + argv3 = Tcl_GetStringFromObj(objv[3], &length);
1.1113 +
1.1114 + for (availPtr = pkgPtr->availPtr, prevPtr = NULL;
1.1115 + availPtr != NULL;
1.1116 + prevPtr = availPtr, availPtr = availPtr->nextPtr) {
1.1117 +
1.1118 + if (CheckVersionAndConvert (interp, availPtr->version, &avi, NULL) != TCL_OK) {
1.1119 + Tcl_Free (argv3i);
1.1120 +#endif
1.1121 + return TCL_ERROR;
1.1122 + }
1.1123 +#ifndef TCL_TIP268
1.1124 + argv2 = Tcl_GetString(objv[2]);
1.1125 + if (objc == 4) {
1.1126 + hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2);
1.1127 + if (hPtr == NULL) {
1.1128 +#else
1.1129 +
1.1130 + res = CompareVersions(avi, argv3i, NULL);
1.1131 + Tcl_Free (avi);
1.1132 +
1.1133 + if (res == 0){
1.1134 + if (objc == 4) {
1.1135 + Tcl_Free (argv3i);
1.1136 + Tcl_SetResult(interp, availPtr->script, TCL_VOLATILE);
1.1137 +#endif
1.1138 + return TCL_OK;
1.1139 + }
1.1140 +#ifndef TCL_TIP268
1.1141 + pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
1.1142 + } else {
1.1143 + pkgPtr = FindPackage(interp, argv2);
1.1144 + }
1.1145 + argv3 = Tcl_GetStringFromObj(objv[3], &length);
1.1146 + for (availPtr = pkgPtr->availPtr, prevPtr = NULL; availPtr != NULL;
1.1147 + prevPtr = availPtr, availPtr = availPtr->nextPtr) {
1.1148 + if (ComparePkgVersions(availPtr->version, argv3, (int *) NULL)
1.1149 + == 0) {
1.1150 + if (objc == 4) {
1.1151 + Tcl_SetResult(interp, availPtr->script, TCL_VOLATILE);
1.1152 + return TCL_OK;
1.1153 + }
1.1154 + Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC);
1.1155 + break;
1.1156 + }
1.1157 + }
1.1158 + if (objc == 4) {
1.1159 + return TCL_OK;
1.1160 +#else
1.1161 + Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC);
1.1162 + break;
1.1163 +#endif
1.1164 + }
1.1165 +#ifndef TCL_TIP268
1.1166 + if (availPtr == NULL) {
1.1167 + availPtr = (PkgAvail *) ckalloc(sizeof(PkgAvail));
1.1168 + availPtr->version = ckalloc((unsigned) (length + 1));
1.1169 + strcpy(availPtr->version, argv3);
1.1170 + if (prevPtr == NULL) {
1.1171 + availPtr->nextPtr = pkgPtr->availPtr;
1.1172 + pkgPtr->availPtr = availPtr;
1.1173 + } else {
1.1174 + availPtr->nextPtr = prevPtr->nextPtr;
1.1175 + prevPtr->nextPtr = availPtr;
1.1176 + }
1.1177 +#else
1.1178 + }
1.1179 + Tcl_Free (argv3i);
1.1180 + if (objc == 4) {
1.1181 + return TCL_OK;
1.1182 + }
1.1183 + if (availPtr == NULL) {
1.1184 + availPtr = (PkgAvail *) ckalloc(sizeof(PkgAvail));
1.1185 + availPtr->version = ckalloc((unsigned) (length + 1));
1.1186 + strcpy(availPtr->version, argv3);
1.1187 + if (prevPtr == NULL) {
1.1188 + availPtr->nextPtr = pkgPtr->availPtr;
1.1189 + pkgPtr->availPtr = availPtr;
1.1190 + } else {
1.1191 + availPtr->nextPtr = prevPtr->nextPtr;
1.1192 + prevPtr->nextPtr = availPtr;
1.1193 +#endif
1.1194 + }
1.1195 +#ifndef TCL_TIP268
1.1196 + argv4 = Tcl_GetStringFromObj(objv[4], &length);
1.1197 + availPtr->script = ckalloc((unsigned) (length + 1));
1.1198 + strcpy(availPtr->script, argv4);
1.1199 + break;
1.1200 +#endif
1.1201 + }
1.1202 +#ifndef TCL_TIP268
1.1203 + case PKG_NAMES: {
1.1204 + if (objc != 2) {
1.1205 + Tcl_WrongNumArgs(interp, 2, objv, NULL);
1.1206 +#else
1.1207 + argv4 = Tcl_GetStringFromObj(objv[4], &length);
1.1208 + availPtr->script = ckalloc((unsigned) (length + 1));
1.1209 + strcpy(availPtr->script, argv4);
1.1210 + break;
1.1211 + }
1.1212 + case PKG_NAMES: {
1.1213 + if (objc != 2) {
1.1214 + Tcl_WrongNumArgs(interp, 2, objv, NULL);
1.1215 + return TCL_ERROR;
1.1216 + }
1.1217 + tablePtr = &iPtr->packageTable;
1.1218 + for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL;
1.1219 + hPtr = Tcl_NextHashEntry(&search)) {
1.1220 + pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
1.1221 + if ((pkgPtr->version != NULL) || (pkgPtr->availPtr != NULL)) {
1.1222 + Tcl_AppendElement(interp, Tcl_GetHashKey(tablePtr, hPtr));
1.1223 + }
1.1224 + }
1.1225 + break;
1.1226 + }
1.1227 + case PKG_PRESENT: {
1.1228 + if (objc < 3) {
1.1229 + presentSyntax:
1.1230 + Tcl_WrongNumArgs(interp, 2, objv, "?-exact? package ?version?");
1.1231 + return TCL_ERROR;
1.1232 + }
1.1233 + argv2 = Tcl_GetString(objv[2]);
1.1234 + if ((argv2[0] == '-') && (strcmp(argv2, "-exact") == 0)) {
1.1235 + exact = 1;
1.1236 + } else {
1.1237 + exact = 0;
1.1238 + }
1.1239 + version = NULL;
1.1240 + if (objc == (4 + exact)) {
1.1241 + version = Tcl_GetString(objv[3 + exact]);
1.1242 + if (CheckVersionAndConvert(interp, version, NULL, NULL) != TCL_OK) {
1.1243 +#endif
1.1244 + return TCL_ERROR;
1.1245 + }
1.1246 +#ifndef TCL_TIP268
1.1247 + tablePtr = &iPtr->packageTable;
1.1248 + for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL;
1.1249 + hPtr = Tcl_NextHashEntry(&search)) {
1.1250 +#else
1.1251 + } else if ((objc != 3) || exact) {
1.1252 + goto presentSyntax;
1.1253 + }
1.1254 + if (exact) {
1.1255 + argv3 = Tcl_GetString(objv[3]);
1.1256 + version = Tcl_PkgPresent(interp, argv3, version, exact);
1.1257 + } else {
1.1258 + version = Tcl_PkgPresent(interp, argv2, version, exact);
1.1259 + }
1.1260 + if (version == NULL) {
1.1261 + return TCL_ERROR;
1.1262 + }
1.1263 + Tcl_SetObjResult( interp, Tcl_NewStringObj( version, -1 ) );
1.1264 + break;
1.1265 + }
1.1266 + case PKG_PROVIDE: {
1.1267 + if ((objc != 3) && (objc != 4)) {
1.1268 + Tcl_WrongNumArgs(interp, 2, objv, "package ?version?");
1.1269 + return TCL_ERROR;
1.1270 + }
1.1271 + argv2 = Tcl_GetString(objv[2]);
1.1272 + if (objc == 3) {
1.1273 + hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2);
1.1274 + if (hPtr != NULL) {
1.1275 +#endif
1.1276 + pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
1.1277 +#ifndef TCL_TIP268
1.1278 + if ((pkgPtr->version != NULL) || (pkgPtr->availPtr != NULL)) {
1.1279 + Tcl_AppendElement(interp, Tcl_GetHashKey(tablePtr, hPtr));
1.1280 +#else
1.1281 + if (pkgPtr->version != NULL) {
1.1282 + Tcl_SetResult(interp, pkgPtr->version, TCL_VOLATILE);
1.1283 +#endif
1.1284 + }
1.1285 + }
1.1286 +#ifndef TCL_TIP268
1.1287 + break;
1.1288 +#else
1.1289 + return TCL_OK;
1.1290 +#endif
1.1291 + }
1.1292 +#ifndef TCL_TIP268
1.1293 + case PKG_PRESENT: {
1.1294 + if (objc < 3) {
1.1295 + presentSyntax:
1.1296 + Tcl_WrongNumArgs(interp, 2, objv, "?-exact? package ?version?");
1.1297 + return TCL_ERROR;
1.1298 +#else
1.1299 + argv3 = Tcl_GetString(objv[3]);
1.1300 + if (CheckVersionAndConvert(interp, argv3, NULL, NULL) != TCL_OK) {
1.1301 + return TCL_ERROR;
1.1302 + }
1.1303 + return Tcl_PkgProvide(interp, argv2, argv3);
1.1304 + }
1.1305 + case PKG_REQUIRE: {
1.1306 + if (objc < 3) {
1.1307 + requireSyntax:
1.1308 + Tcl_WrongNumArgs(interp, 2, objv, "?-exact? package ?requirement...?");
1.1309 + return TCL_ERROR;
1.1310 + }
1.1311 + version = NULL;
1.1312 + argv2 = Tcl_GetString(objv[2]);
1.1313 + if ((argv2[0] == '-') && (strcmp(argv2, "-exact") == 0)) {
1.1314 + Tcl_Obj* ov;
1.1315 + int res;
1.1316 +
1.1317 + if (objc != 5) {
1.1318 + goto requireSyntax;
1.1319 +#endif
1.1320 + }
1.1321 +#ifndef TCL_TIP268
1.1322 + argv2 = Tcl_GetString(objv[2]);
1.1323 + if ((argv2[0] == '-') && (strcmp(argv2, "-exact") == 0)) {
1.1324 + exact = 1;
1.1325 + } else {
1.1326 + exact = 0;
1.1327 +#else
1.1328 + version = Tcl_GetString(objv[4]);
1.1329 + if (CheckVersionAndConvert(interp, version, NULL, NULL) != TCL_OK) {
1.1330 + return TCL_ERROR;
1.1331 +#endif
1.1332 + }
1.1333 +#ifdef TCL_TIP268
1.1334 + /* Create a new-style requirement for the exact version. */
1.1335 +
1.1336 + ov = ExactRequirement (version);
1.1337 +#endif
1.1338 + version = NULL;
1.1339 +#ifndef TCL_TIP268
1.1340 + if (objc == (4 + exact)) {
1.1341 + version = Tcl_GetString(objv[3 + exact]);
1.1342 + if (CheckVersion(interp, version) != TCL_OK) {
1.1343 + return TCL_ERROR;
1.1344 + }
1.1345 + } else if ((objc != 3) || exact) {
1.1346 + goto presentSyntax;
1.1347 + }
1.1348 + if (exact) {
1.1349 + argv3 = Tcl_GetString(objv[3]);
1.1350 + version = Tcl_PkgPresent(interp, argv3, version, exact);
1.1351 + } else {
1.1352 + version = Tcl_PkgPresent(interp, argv2, version, exact);
1.1353 + }
1.1354 + if (version == NULL) {
1.1355 +#else
1.1356 + argv3 = Tcl_GetString(objv[3]);
1.1357 +
1.1358 + Tcl_IncrRefCount (ov);
1.1359 + res = Tcl_PkgRequireProc(interp, argv3, 1, &ov, NULL);
1.1360 + Tcl_DecrRefCount (ov);
1.1361 + return res;
1.1362 + } else {
1.1363 + if (CheckAllRequirements (interp, objc-3, objv+3) != TCL_OK) {
1.1364 +#endif
1.1365 + return TCL_ERROR;
1.1366 + }
1.1367 +#ifndef TCL_TIP268
1.1368 + Tcl_SetObjResult( interp, Tcl_NewStringObj( version, -1 ) );
1.1369 + break;
1.1370 +#else
1.1371 + return Tcl_PkgRequireProc(interp, argv2, objc-3, objv+3, NULL);
1.1372 +#endif
1.1373 + }
1.1374 +#ifndef TCL_TIP268
1.1375 + case PKG_PROVIDE: {
1.1376 + if ((objc != 3) && (objc != 4)) {
1.1377 + Tcl_WrongNumArgs(interp, 2, objv, "package ?version?");
1.1378 +#else
1.1379 + break;
1.1380 + }
1.1381 + case PKG_UNKNOWN: {
1.1382 + int length;
1.1383 + if (objc == 2) {
1.1384 + if (iPtr->packageUnknown != NULL) {
1.1385 + Tcl_SetResult(interp, iPtr->packageUnknown, TCL_VOLATILE);
1.1386 + }
1.1387 + } else if (objc == 3) {
1.1388 + if (iPtr->packageUnknown != NULL) {
1.1389 + ckfree(iPtr->packageUnknown);
1.1390 + }
1.1391 + argv2 = Tcl_GetStringFromObj(objv[2], &length);
1.1392 + if (argv2[0] == 0) {
1.1393 + iPtr->packageUnknown = NULL;
1.1394 + } else {
1.1395 + iPtr->packageUnknown = (char *) ckalloc((unsigned)
1.1396 + (length + 1));
1.1397 + strcpy(iPtr->packageUnknown, argv2);
1.1398 + }
1.1399 + } else {
1.1400 + Tcl_WrongNumArgs(interp, 2, objv, "?command?");
1.1401 + return TCL_ERROR;
1.1402 + }
1.1403 + break;
1.1404 + }
1.1405 + case PKG_PREFER: {
1.1406 + /* See tclInt.h for the enum, just before Interp */
1.1407 + static CONST char *pkgPreferOptions[] = {
1.1408 + "latest", "stable", NULL
1.1409 + };
1.1410 +
1.1411 + if (objc > 3) {
1.1412 + Tcl_WrongNumArgs(interp, 2, objv, "?latest|stable?");
1.1413 + return TCL_ERROR;
1.1414 + } else if (objc == 3) {
1.1415 + /* Set value. */
1.1416 + int new;
1.1417 + if (Tcl_GetIndexFromObj(interp, objv[2], pkgPreferOptions, "preference", 0,
1.1418 + &new) != TCL_OK) {
1.1419 +#endif
1.1420 + return TCL_ERROR;
1.1421 + }
1.1422 +#ifndef TCL_TIP268
1.1423 + argv2 = Tcl_GetString(objv[2]);
1.1424 + if (objc == 3) {
1.1425 + hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2);
1.1426 + if (hPtr != NULL) {
1.1427 + pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
1.1428 + if (pkgPtr->version != NULL) {
1.1429 + Tcl_SetResult(interp, pkgPtr->version, TCL_VOLATILE);
1.1430 + }
1.1431 + }
1.1432 + return TCL_OK;
1.1433 +#else
1.1434 + if (new < iPtr->packagePrefer) {
1.1435 + iPtr->packagePrefer = new;
1.1436 +#endif
1.1437 + }
1.1438 +#ifndef TCL_TIP268
1.1439 + argv3 = Tcl_GetString(objv[3]);
1.1440 + if (CheckVersion(interp, argv3) != TCL_OK) {
1.1441 + return TCL_ERROR;
1.1442 + }
1.1443 + return Tcl_PkgProvide(interp, argv2, argv3);
1.1444 +#endif
1.1445 + }
1.1446 +#ifndef TCL_TIP268
1.1447 + case PKG_REQUIRE: {
1.1448 + if (objc < 3) {
1.1449 + requireSyntax:
1.1450 + Tcl_WrongNumArgs(interp, 2, objv, "?-exact? package ?version?");
1.1451 + return TCL_ERROR;
1.1452 + }
1.1453 + argv2 = Tcl_GetString(objv[2]);
1.1454 + if ((argv2[0] == '-') && (strcmp(argv2, "-exact") == 0)) {
1.1455 + exact = 1;
1.1456 + } else {
1.1457 + exact = 0;
1.1458 + }
1.1459 + version = NULL;
1.1460 + if (objc == (4 + exact)) {
1.1461 + version = Tcl_GetString(objv[3 + exact]);
1.1462 + if (CheckVersion(interp, version) != TCL_OK) {
1.1463 + return TCL_ERROR;
1.1464 + }
1.1465 + } else if ((objc != 3) || exact) {
1.1466 + goto requireSyntax;
1.1467 + }
1.1468 + if (exact) {
1.1469 + argv3 = Tcl_GetString(objv[3]);
1.1470 + version = Tcl_PkgRequire(interp, argv3, version, exact);
1.1471 + } else {
1.1472 + version = Tcl_PkgRequire(interp, argv2, version, exact);
1.1473 + }
1.1474 + if (version == NULL) {
1.1475 + return TCL_ERROR;
1.1476 + }
1.1477 + Tcl_SetObjResult( interp, Tcl_NewStringObj( version, -1 ) );
1.1478 + break;
1.1479 +#else
1.1480 + /* Always return current value. */
1.1481 + Tcl_SetObjResult(interp, Tcl_NewStringObj (pkgPreferOptions [iPtr->packagePrefer], -1));
1.1482 + break;
1.1483 + }
1.1484 + case PKG_VCOMPARE: {
1.1485 + if (objc != 4) {
1.1486 + Tcl_WrongNumArgs(interp, 2, objv, "version1 version2");
1.1487 + return TCL_ERROR;
1.1488 +#endif
1.1489 + }
1.1490 +#ifndef TCL_TIP268
1.1491 + case PKG_UNKNOWN: {
1.1492 + int length;
1.1493 + if (objc == 2) {
1.1494 + if (iPtr->packageUnknown != NULL) {
1.1495 + Tcl_SetResult(interp, iPtr->packageUnknown, TCL_VOLATILE);
1.1496 + }
1.1497 + } else if (objc == 3) {
1.1498 + if (iPtr->packageUnknown != NULL) {
1.1499 + ckfree(iPtr->packageUnknown);
1.1500 + }
1.1501 + argv2 = Tcl_GetStringFromObj(objv[2], &length);
1.1502 + if (argv2[0] == 0) {
1.1503 + iPtr->packageUnknown = NULL;
1.1504 + } else {
1.1505 + iPtr->packageUnknown = (char *) ckalloc((unsigned)
1.1506 + (length + 1));
1.1507 + strcpy(iPtr->packageUnknown, argv2);
1.1508 + }
1.1509 + } else {
1.1510 + Tcl_WrongNumArgs(interp, 2, objv, "?command?");
1.1511 + return TCL_ERROR;
1.1512 + }
1.1513 + break;
1.1514 +#else
1.1515 + argv3 = Tcl_GetString(objv[3]);
1.1516 + argv2 = Tcl_GetString(objv[2]);
1.1517 + if ((CheckVersionAndConvert (interp, argv2, &iva, NULL) != TCL_OK) ||
1.1518 + (CheckVersionAndConvert (interp, argv3, &ivb, NULL) != TCL_OK)) {
1.1519 + if (iva != NULL) { Tcl_Free (iva); }
1.1520 + /* ivb cannot be set in this branch */
1.1521 + return TCL_ERROR;
1.1522 +#endif
1.1523 + }
1.1524 +#ifndef TCL_TIP268
1.1525 + case PKG_VCOMPARE: {
1.1526 + if (objc != 4) {
1.1527 + Tcl_WrongNumArgs(interp, 2, objv, "version1 version2");
1.1528 + return TCL_ERROR;
1.1529 + }
1.1530 + argv3 = Tcl_GetString(objv[3]);
1.1531 + argv2 = Tcl_GetString(objv[2]);
1.1532 + if ((CheckVersion(interp, argv2) != TCL_OK)
1.1533 + || (CheckVersion(interp, argv3) != TCL_OK)) {
1.1534 + return TCL_ERROR;
1.1535 + }
1.1536 + Tcl_SetIntObj(Tcl_GetObjResult(interp),
1.1537 + ComparePkgVersions(argv2, argv3, (int *) NULL));
1.1538 + break;
1.1539 +#else
1.1540 +
1.1541 + /* Comparison is done on the internal representation */
1.1542 + Tcl_SetObjResult(interp,Tcl_NewIntObj(CompareVersions(iva, ivb, NULL)));
1.1543 + Tcl_Free (iva);
1.1544 + Tcl_Free (ivb);
1.1545 + break;
1.1546 + }
1.1547 + case PKG_VERSIONS: {
1.1548 + if (objc != 3) {
1.1549 + Tcl_WrongNumArgs(interp, 2, objv, "package");
1.1550 + return TCL_ERROR;
1.1551 +#endif
1.1552 + }
1.1553 +#ifndef TCL_TIP268
1.1554 + case PKG_VERSIONS: {
1.1555 + if (objc != 3) {
1.1556 + Tcl_WrongNumArgs(interp, 2, objv, "package");
1.1557 + return TCL_ERROR;
1.1558 +#else
1.1559 + argv2 = Tcl_GetString(objv[2]);
1.1560 + hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2);
1.1561 + if (hPtr != NULL) {
1.1562 + pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
1.1563 + for (availPtr = pkgPtr->availPtr; availPtr != NULL;
1.1564 + availPtr = availPtr->nextPtr) {
1.1565 + Tcl_AppendElement(interp, availPtr->version);
1.1566 +#endif
1.1567 + }
1.1568 +#ifndef TCL_TIP268
1.1569 + argv2 = Tcl_GetString(objv[2]);
1.1570 + hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2);
1.1571 + if (hPtr != NULL) {
1.1572 + pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
1.1573 + for (availPtr = pkgPtr->availPtr; availPtr != NULL;
1.1574 + availPtr = availPtr->nextPtr) {
1.1575 + Tcl_AppendElement(interp, availPtr->version);
1.1576 + }
1.1577 + }
1.1578 + break;
1.1579 +#endif
1.1580 + }
1.1581 +#ifndef TCL_TIP268
1.1582 + case PKG_VSATISFIES: {
1.1583 + if (objc != 4) {
1.1584 + Tcl_WrongNumArgs(interp, 2, objv, "version1 version2");
1.1585 + return TCL_ERROR;
1.1586 + }
1.1587 + argv3 = Tcl_GetString(objv[3]);
1.1588 + argv2 = Tcl_GetString(objv[2]);
1.1589 + if ((CheckVersion(interp, argv2) != TCL_OK)
1.1590 + || (CheckVersion(interp, argv3) != TCL_OK)) {
1.1591 + return TCL_ERROR;
1.1592 + }
1.1593 + ComparePkgVersions(argv2, argv3, &satisfies);
1.1594 + Tcl_SetIntObj(Tcl_GetObjResult(interp), satisfies);
1.1595 + break;
1.1596 +#else
1.1597 + break;
1.1598 + }
1.1599 + case PKG_VSATISFIES: {
1.1600 + char* argv2i = NULL;
1.1601 +
1.1602 + if (objc < 4) {
1.1603 + Tcl_WrongNumArgs(interp, 2, objv, "version requirement requirement...");
1.1604 + return TCL_ERROR;
1.1605 +#endif
1.1606 + }
1.1607 +#ifndef TCL_TIP268
1.1608 + default: {
1.1609 + panic("Tcl_PackageObjCmd: bad option index to pkgOptions");
1.1610 +#else
1.1611 +
1.1612 + argv2 = Tcl_GetString(objv[2]);
1.1613 + if ((CheckVersionAndConvert(interp, argv2, &argv2i, NULL) != TCL_OK)) {
1.1614 + return TCL_ERROR;
1.1615 + } else if (CheckAllRequirements (interp, objc-3, objv+3) != TCL_OK) {
1.1616 + Tcl_Free (argv2i);
1.1617 + return TCL_ERROR;
1.1618 +#endif
1.1619 + }
1.1620 +#ifdef TCL_TIP268
1.1621 +
1.1622 + satisfies = AllRequirementsSatisfied (argv2i, objc-3, objv+3);
1.1623 + Tcl_Free (argv2i);
1.1624 +
1.1625 + Tcl_SetIntObj(Tcl_GetObjResult(interp), satisfies);
1.1626 + break;
1.1627 + }
1.1628 + default: {
1.1629 + panic("Tcl_PackageObjCmd: bad option index to pkgOptions");
1.1630 + }
1.1631 +#endif
1.1632 + }
1.1633 + return TCL_OK;
1.1634 +}
1.1635 +
1.1636 +/*
1.1637 + *----------------------------------------------------------------------
1.1638 + *
1.1639 + * FindPackage --
1.1640 + *
1.1641 + * This procedure finds the Package record for a particular package
1.1642 + * in a particular interpreter, creating a record if one doesn't
1.1643 + * already exist.
1.1644 + *
1.1645 + * Results:
1.1646 + * The return value is a pointer to the Package record for the
1.1647 + * package.
1.1648 + *
1.1649 + * Side effects:
1.1650 + * A new Package record may be created.
1.1651 + *
1.1652 + *----------------------------------------------------------------------
1.1653 + */
1.1654 +
1.1655 +static Package *
1.1656 +FindPackage(interp, name)
1.1657 + Tcl_Interp *interp; /* Interpreter to use for package lookup. */
1.1658 + CONST char *name; /* Name of package to fine. */
1.1659 +{
1.1660 + Interp *iPtr = (Interp *) interp;
1.1661 + Tcl_HashEntry *hPtr;
1.1662 + int new;
1.1663 + Package *pkgPtr;
1.1664 +
1.1665 + hPtr = Tcl_CreateHashEntry(&iPtr->packageTable, name, &new);
1.1666 + if (new) {
1.1667 + pkgPtr = (Package *) ckalloc(sizeof(Package));
1.1668 + pkgPtr->version = NULL;
1.1669 + pkgPtr->availPtr = NULL;
1.1670 + pkgPtr->clientData = NULL;
1.1671 + Tcl_SetHashValue(hPtr, pkgPtr);
1.1672 + } else {
1.1673 + pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
1.1674 + }
1.1675 + return pkgPtr;
1.1676 +}
1.1677 +
1.1678 +/*
1.1679 + *----------------------------------------------------------------------
1.1680 + *
1.1681 + * TclFreePackageInfo --
1.1682 + *
1.1683 + * This procedure is called during interpreter deletion to
1.1684 + * free all of the package-related information for the
1.1685 + * interpreter.
1.1686 + *
1.1687 + * Results:
1.1688 + * None.
1.1689 + *
1.1690 + * Side effects:
1.1691 + * Memory is freed.
1.1692 + *
1.1693 + *----------------------------------------------------------------------
1.1694 + */
1.1695 +
1.1696 +void
1.1697 +TclFreePackageInfo(iPtr)
1.1698 + Interp *iPtr; /* Interpreter that is being deleted. */
1.1699 +{
1.1700 + Package *pkgPtr;
1.1701 + Tcl_HashSearch search;
1.1702 + Tcl_HashEntry *hPtr;
1.1703 + PkgAvail *availPtr;
1.1704 +
1.1705 + for (hPtr = Tcl_FirstHashEntry(&iPtr->packageTable, &search);
1.1706 + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
1.1707 + pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
1.1708 + if (pkgPtr->version != NULL) {
1.1709 + ckfree(pkgPtr->version);
1.1710 + }
1.1711 + while (pkgPtr->availPtr != NULL) {
1.1712 + availPtr = pkgPtr->availPtr;
1.1713 + pkgPtr->availPtr = availPtr->nextPtr;
1.1714 + Tcl_EventuallyFree((ClientData)availPtr->version, TCL_DYNAMIC);
1.1715 + Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC);
1.1716 + ckfree((char *) availPtr);
1.1717 + }
1.1718 + ckfree((char *) pkgPtr);
1.1719 + }
1.1720 + Tcl_DeleteHashTable(&iPtr->packageTable);
1.1721 + if (iPtr->packageUnknown != NULL) {
1.1722 + ckfree(iPtr->packageUnknown);
1.1723 + }
1.1724 +}
1.1725 +
1.1726 +/*
1.1727 + *----------------------------------------------------------------------
1.1728 + *
1.1729 + * CheckVersion / CheckVersionAndConvert --
1.1730 + *
1.1731 + * This procedure checks to see whether a version number has
1.1732 + * valid syntax.
1.1733 + *
1.1734 + * Results:
1.1735 + * If string is a properly formed version number the TCL_OK
1.1736 + * is returned. Otherwise TCL_ERROR is returned and an error
1.1737 + * message is left in the interp's result.
1.1738 + *
1.1739 + * Side effects:
1.1740 + * None.
1.1741 + *
1.1742 + *----------------------------------------------------------------------
1.1743 + */
1.1744 +
1.1745 +static int
1.1746 +#ifndef TCL_TIP268
1.1747 +CheckVersion(interp, string)
1.1748 + Tcl_Interp *interp; /* Used for error reporting. */
1.1749 + CONST char *string; /* Supposedly a version number, which is
1.1750 + * groups of decimal digits separated
1.1751 + * by dots. */
1.1752 +#else
1.1753 +CheckVersionAndConvert(interp, string, internal, stable)
1.1754 + Tcl_Interp *interp; /* Used for error reporting. */
1.1755 + CONST char *string; /* Supposedly a version number, which is
1.1756 + * groups of decimal digits separated by
1.1757 + * dots. */
1.1758 + char** internal; /* Internal normalized representation */
1.1759 + int* stable; /* Flag: Version is (un)stable. */
1.1760 +#endif
1.1761 +{
1.1762 + CONST char *p = string;
1.1763 + char prevChar;
1.1764 +#ifdef TCL_TIP268
1.1765 + int hasunstable = 0;
1.1766 + /* 4* assuming that each char is a separator (a,b become ' -x ').
1.1767 + * 4+ to have spce for an additional -2 at the end
1.1768 + */
1.1769 + char* ibuf = ckalloc (4+4*strlen(string));
1.1770 + char* ip = ibuf;
1.1771 +
1.1772 + /* Basic rules
1.1773 + * (1) First character has to be a digit.
1.1774 + * (2) All other characters have to be a digit or '.'
1.1775 + * (3) Two '.'s may not follow each other.
1.1776 +
1.1777 + * TIP 268, Modified rules
1.1778 + * (1) s.a.
1.1779 + * (2) All other characters have to be a digit, 'a', 'b', or '.'
1.1780 + * (3) s.a.
1.1781 + * (4) Only one of 'a' or 'b' may occur.
1.1782 + * (5) Neither 'a', nor 'b' may occur before or after a '.'
1.1783 + */
1.1784 +
1.1785 +#endif
1.1786 + if (!isdigit(UCHAR(*p))) { /* INTL: digit */
1.1787 + goto error;
1.1788 + }
1.1789 +#ifdef TCL_TIP268
1.1790 + *ip++ = *p;
1.1791 +#endif
1.1792 + for (prevChar = *p, p++; *p != 0; p++) {
1.1793 +#ifndef TCL_TIP268
1.1794 + if (!isdigit(UCHAR(*p)) &&
1.1795 + ((*p != '.') || (prevChar == '.'))) { /* INTL: digit */
1.1796 +#else
1.1797 + if (
1.1798 + (!isdigit(UCHAR(*p))) &&
1.1799 + (((*p != '.') && (*p != 'a') && (*p != 'b')) ||
1.1800 + ((hasunstable && ((*p == 'a') || (*p == 'b'))) ||
1.1801 + (((prevChar == 'a') || (prevChar == 'b') || (prevChar == '.')) && (*p == '.')) ||
1.1802 + (((*p == 'a') || (*p == 'b') || (*p == '.')) && (prevChar == '.'))))
1.1803 + ) {
1.1804 + /* INTL: digit */
1.1805 +#endif
1.1806 + goto error;
1.1807 + }
1.1808 +#ifdef TCL_TIP268
1.1809 + if ((*p == 'a') || (*p == 'b')) { hasunstable = 1 ; }
1.1810 +
1.1811 + /* Translation to the internal rep. Regular version chars are copied
1.1812 + * as is. The separators are translated to numerics. The new separator
1.1813 + * for all parts is space. */
1.1814 +
1.1815 + if (*p == '.') { *ip++ = ' '; *ip++ = '0'; *ip++ = ' '; }
1.1816 + else if (*p == 'a') { *ip++ = ' '; *ip++ = '-'; *ip++ = '2'; *ip++ = ' '; }
1.1817 + else if (*p == 'b') { *ip++ = ' '; *ip++ = '-'; *ip++ = '1'; *ip++ = ' '; }
1.1818 + else { *ip++ = *p; }
1.1819 +#endif
1.1820 + prevChar = *p;
1.1821 + }
1.1822 +#ifndef TCL_TIP268
1.1823 + if (prevChar != '.') {
1.1824 +#else
1.1825 + if ((prevChar != '.') && (prevChar != 'a') && (prevChar != 'b')) {
1.1826 + *ip = '\0';
1.1827 + if (internal != NULL) {
1.1828 + *internal = ibuf;
1.1829 + } else {
1.1830 + Tcl_Free (ibuf);
1.1831 + }
1.1832 + if (stable != NULL) {
1.1833 + *stable = !hasunstable;
1.1834 + }
1.1835 +#endif
1.1836 + return TCL_OK;
1.1837 + }
1.1838 +
1.1839 + error:
1.1840 +#ifdef TCL_TIP268
1.1841 + ckfree (ibuf);
1.1842 +#endif
1.1843 + Tcl_AppendResult(interp, "expected version number but got \"",
1.1844 + string, "\"", (char *) NULL);
1.1845 + return TCL_ERROR;
1.1846 +}
1.1847 +
1.1848 +/*
1.1849 + *----------------------------------------------------------------------
1.1850 + *
1.1851 + * ComparePkgVersions / CompareVersions --
1.1852 + *
1.1853 + * This procedure compares two version numbers. (268: in internal rep).
1.1854 + *
1.1855 + * Results:
1.1856 + * The return value is -1 if v1 is less than v2, 0 if the two
1.1857 + * version numbers are the same, and 1 if v1 is greater than v2.
1.1858 + * If *satPtr is non-NULL, the word it points to is filled in
1.1859 + * with 1 if v2 >= v1 and both numbers have the same major number
1.1860 + * or 0 otherwise.
1.1861 + *
1.1862 + * Side effects:
1.1863 + * None.
1.1864 + *
1.1865 + *----------------------------------------------------------------------
1.1866 + */
1.1867 +
1.1868 +static int
1.1869 +#ifndef TCL_TIP268
1.1870 +ComparePkgVersions(v1, v2, satPtr)
1.1871 + CONST char *v1;
1.1872 + CONST char *v2; /* Versions strings, of form 2.1.3 (any
1.1873 + * number of version numbers). */
1.1874 + int *satPtr; /* If non-null, the word pointed to is
1.1875 + * filled in with a 0/1 value. 1 means
1.1876 + * v1 "satisfies" v2: v1 is greater than
1.1877 + * or equal to v2 and both version numbers
1.1878 + * have the same major number. */
1.1879 +#else
1.1880 +CompareVersions(v1, v2, isMajorPtr)
1.1881 + CONST char *v1; /* Versions strings, of form 2.1.3 (any number */
1.1882 + CONST char *v2; /* of version numbers). */
1.1883 + int *isMajorPtr; /* If non-null, the word pointed to is filled
1.1884 + * in with a 0/1 value. 1 means that the difference
1.1885 + * occured in the first element. */
1.1886 +#endif
1.1887 +{
1.1888 + int thisIsMajor, n1, n2;
1.1889 +#ifdef TCL_TIP268
1.1890 + int res, flip;
1.1891 +#endif
1.1892 +
1.1893 + /*
1.1894 + * Each iteration of the following loop processes one number from each
1.1895 + * string, terminated by a " " (space). If those numbers don't match then the
1.1896 + * comparison is over; otherwise, we loop back for the next number.
1.1897 + *
1.1898 + * TIP 268.
1.1899 + * This is identical the function 'ComparePkgVersion', but using the new
1.1900 + * space separator as used by the internal rep of version numbers. The
1.1901 + * special separators 'a' and 'b' have already been dealt with in
1.1902 + * 'CheckVersionAndConvert', they were translated into numbers as
1.1903 + * well. This keeps the comparison sane. Otherwise we would have to
1.1904 + * compare numerics, the separators, and also deal with the special case
1.1905 + * of end-of-string compared to separators. The semi-list rep we get here
1.1906 + * is much easier to handle, as it is still regular.
1.1907 + */
1.1908 +
1.1909 + thisIsMajor = 1;
1.1910 + while (1) {
1.1911 + /*
1.1912 + * Parse one decimal number from the front of each string.
1.1913 + */
1.1914 +
1.1915 + n1 = n2 = 0;
1.1916 +#ifndef TCL_TIP268
1.1917 + while ((*v1 != 0) && (*v1 != '.')) {
1.1918 +#else
1.1919 + flip = 0;
1.1920 + while ((*v1 != 0) && (*v1 != ' ')) {
1.1921 + if (*v1 == '-') {flip = 1 ; v1++ ; continue;}
1.1922 +#endif
1.1923 + n1 = 10*n1 + (*v1 - '0');
1.1924 + v1++;
1.1925 + }
1.1926 +#ifndef TCL_TIP268
1.1927 + while ((*v2 != 0) && (*v2 != '.')) {
1.1928 +#else
1.1929 + if (flip) n1 = -n1;
1.1930 + flip = 0;
1.1931 + while ((*v2 != 0) && (*v2 != ' ')) {
1.1932 + if (*v2 == '-') {flip = 1; v2++ ; continue;}
1.1933 +#endif
1.1934 + n2 = 10*n2 + (*v2 - '0');
1.1935 + v2++;
1.1936 + }
1.1937 +#ifdef TCL_TIP268
1.1938 + if (flip) n2 = -n2;
1.1939 +#endif
1.1940 +
1.1941 + /*
1.1942 + * Compare and go on to the next version number if the current numbers
1.1943 + * match.
1.1944 + */
1.1945 +
1.1946 + if (n1 != n2) {
1.1947 + break;
1.1948 + }
1.1949 + if (*v1 != 0) {
1.1950 + v1++;
1.1951 + } else if (*v2 == 0) {
1.1952 + break;
1.1953 + }
1.1954 + if (*v2 != 0) {
1.1955 + v2++;
1.1956 + }
1.1957 + thisIsMajor = 0;
1.1958 + }
1.1959 +#ifndef TCL_TIP268
1.1960 + if (satPtr != NULL) {
1.1961 + *satPtr = (n1 == n2) || ((n1 > n2) && !thisIsMajor);
1.1962 + }
1.1963 +#endif
1.1964 + if (n1 > n2) {
1.1965 +#ifndef TCL_TIP268
1.1966 + return 1;
1.1967 +#else
1.1968 + res = 1;
1.1969 +#endif
1.1970 + } else if (n1 == n2) {
1.1971 +#ifndef TCL_TIP268
1.1972 + return 0;
1.1973 +#else
1.1974 + res = 0;
1.1975 +#endif
1.1976 + } else {
1.1977 +#ifndef TCL_TIP268
1.1978 + return -1;
1.1979 +#else
1.1980 + res = -1;
1.1981 + }
1.1982 +
1.1983 + if (isMajorPtr != NULL) {
1.1984 + *isMajorPtr = thisIsMajor;
1.1985 + }
1.1986 +
1.1987 + return res;
1.1988 +}
1.1989 +
1.1990 +/*
1.1991 + *----------------------------------------------------------------------
1.1992 + *
1.1993 + * CheckAllRequirements --
1.1994 + *
1.1995 + * This function checks to see whether all requirements in a set
1.1996 + * have valid syntax.
1.1997 + *
1.1998 + * Results:
1.1999 + * TCL_OK is returned if all requirements are valid.
1.2000 + * Otherwise TCL_ERROR is returned and an error message
1.2001 + * is left in the interp's result.
1.2002 + *
1.2003 + * Side effects:
1.2004 + * May modify the interpreter result.
1.2005 + *
1.2006 + *----------------------------------------------------------------------
1.2007 + */
1.2008 +
1.2009 +static int
1.2010 +CheckAllRequirements(interp, reqc, reqv)
1.2011 + Tcl_Interp* interp;
1.2012 + int reqc; /* Requirements to check. */
1.2013 + Tcl_Obj *CONST reqv[];
1.2014 +{
1.2015 + int i;
1.2016 + for (i = 0; i < reqc; i++) {
1.2017 + if ((CheckRequirement(interp, Tcl_GetString(reqv[i])) != TCL_OK)) {
1.2018 + return TCL_ERROR;
1.2019 + }
1.2020 + }
1.2021 + return TCL_OK;
1.2022 +}
1.2023 +
1.2024 +/*
1.2025 + *----------------------------------------------------------------------
1.2026 + *
1.2027 + * CheckRequirement --
1.2028 + *
1.2029 + * This function checks to see whether a requirement has valid syntax.
1.2030 + *
1.2031 + * Results:
1.2032 + * If string is a properly formed requirement then TCL_OK is returned.
1.2033 + * Otherwise TCL_ERROR is returned and an error message is left in the
1.2034 + * interp's result.
1.2035 + *
1.2036 + * Side effects:
1.2037 + * None.
1.2038 + *
1.2039 + *----------------------------------------------------------------------
1.2040 + */
1.2041 +
1.2042 +static int
1.2043 +CheckRequirement(interp, string)
1.2044 + Tcl_Interp *interp; /* Used for error reporting. */
1.2045 + CONST char *string; /* Supposedly a requirement. */
1.2046 +{
1.2047 + /* Syntax of requirement = version
1.2048 + * = version-version
1.2049 + * = version-
1.2050 + */
1.2051 +
1.2052 + char* dash = NULL;
1.2053 + char* buf;
1.2054 +
1.2055 + dash = strchr (string, '-');
1.2056 + if (dash == NULL) {
1.2057 + /* no dash found, has to be a simple version */
1.2058 + return CheckVersionAndConvert (interp, string, NULL, NULL);
1.2059 + }
1.2060 + if (strchr (dash+1, '-') != NULL) {
1.2061 + /* More dashes found after the first. This is wrong. */
1.2062 + Tcl_AppendResult(interp, "expected versionMin-versionMax but got \"", string,
1.2063 + "\"", NULL);
1.2064 + return TCL_ERROR;
1.2065 +#endif
1.2066 + }
1.2067 +#ifdef TCL_TIP268
1.2068 +
1.2069 + /* Exactly one dash is present. Copy the string, split at the location of
1.2070 + * dash and check that both parts are versions. Note that the max part can
1.2071 + * be empty.
1.2072 + */
1.2073 +
1.2074 + buf = strdup (string);
1.2075 + dash = buf + (dash - string);
1.2076 + *dash = '\0'; /* buf now <=> min part */
1.2077 + dash ++; /* dash now <=> max part */
1.2078 +
1.2079 + if ((CheckVersionAndConvert(interp, buf, NULL, NULL) != TCL_OK) ||
1.2080 + ((*dash != '\0') &&
1.2081 + (CheckVersionAndConvert(interp, dash, NULL, NULL) != TCL_OK))) {
1.2082 + free (buf);
1.2083 + return TCL_ERROR;
1.2084 + }
1.2085 +
1.2086 + free (buf);
1.2087 + return TCL_OK;
1.2088 +#endif
1.2089 +}
1.2090 +#ifdef TCL_TIP268
1.2091 +
1.2092 +/*
1.2093 + *----------------------------------------------------------------------
1.2094 + *
1.2095 + * AddRequirementsToResult --
1.2096 + *
1.2097 + * This function accumulates requirements in the interpreter result.
1.2098 + *
1.2099 + * Results:
1.2100 + * None.
1.2101 + *
1.2102 + * Side effects:
1.2103 + * The interpreter result is extended.
1.2104 + *
1.2105 + *----------------------------------------------------------------------
1.2106 + */
1.2107 +
1.2108 +static void
1.2109 +AddRequirementsToResult(interp, reqc, reqv)
1.2110 + Tcl_Interp* interp;
1.2111 + int reqc; /* Requirements constraining the desired version. */
1.2112 + Tcl_Obj *CONST reqv[]; /* 0 means to use the latest version available. */
1.2113 +{
1.2114 + if (reqc > 0) {
1.2115 + int i;
1.2116 + for (i = 0; i < reqc; i++) {
1.2117 + Tcl_AppendResult(interp, " ", TclGetString(reqv[i]), NULL);
1.2118 + }
1.2119 + }
1.2120 +}
1.2121 +
1.2122 +/*
1.2123 + *----------------------------------------------------------------------
1.2124 + *
1.2125 + * AddRequirementsToDString --
1.2126 + *
1.2127 + * This function accumulates requirements in a DString.
1.2128 + *
1.2129 + * Results:
1.2130 + * None.
1.2131 + *
1.2132 + * Side effects:
1.2133 + * The DString argument is extended.
1.2134 + *
1.2135 + *----------------------------------------------------------------------
1.2136 + */
1.2137 +
1.2138 +static void
1.2139 +AddRequirementsToDString(dstring, reqc, reqv)
1.2140 + Tcl_DString* dstring;
1.2141 + int reqc; /* Requirements constraining the desired version. */
1.2142 + Tcl_Obj *CONST reqv[]; /* 0 means to use the latest version available. */
1.2143 +{
1.2144 + if (reqc > 0) {
1.2145 + int i;
1.2146 + for (i = 0; i < reqc; i++) {
1.2147 + Tcl_DStringAppend(dstring, " ", 1);
1.2148 + Tcl_DStringAppend(dstring, TclGetString(reqv[i]), -1);
1.2149 + }
1.2150 + } else {
1.2151 + Tcl_DStringAppend(dstring, " 0-", -1);
1.2152 + }
1.2153 +}
1.2154 +
1.2155 +/*
1.2156 + *----------------------------------------------------------------------
1.2157 + *
1.2158 + * AllRequirementSatisfied --
1.2159 + *
1.2160 + * This function checks to see whether a version satisfies at
1.2161 + * least one of a set of requirements.
1.2162 + *
1.2163 + * Results:
1.2164 + * If the requirements are satisfied 1 is returned.
1.2165 + * Otherwise 0 is returned. The function assumes
1.2166 + * that all pieces have valid syntax. And is allowed
1.2167 + * to make that assumption.
1.2168 + *
1.2169 + * Side effects:
1.2170 + * None.
1.2171 + *
1.2172 + *----------------------------------------------------------------------
1.2173 + */
1.2174 +
1.2175 +static int
1.2176 +AllRequirementsSatisfied(availVersionI, reqc, reqv)
1.2177 + CONST char* availVersionI; /* Candidate version to check against the requirements */
1.2178 + int reqc; /* Requirements constraining the desired version. */
1.2179 + Tcl_Obj *CONST reqv[]; /* 0 means to use the latest version available. */
1.2180 +{
1.2181 + int i, satisfies;
1.2182 +
1.2183 + for (satisfies = i = 0; i < reqc; i++) {
1.2184 + satisfies = RequirementSatisfied(availVersionI, Tcl_GetString(reqv[i]));
1.2185 + if (satisfies) break;
1.2186 + }
1.2187 + return satisfies;
1.2188 +}
1.2189 +
1.2190 +/*
1.2191 + *----------------------------------------------------------------------
1.2192 + *
1.2193 + * RequirementSatisfied --
1.2194 + *
1.2195 + * This function checks to see whether a version satisfies a requirement.
1.2196 + *
1.2197 + * Results:
1.2198 + * If the requirement is satisfied 1 is returned.
1.2199 + * Otherwise 0 is returned. The function assumes
1.2200 + * that all pieces have valid syntax. And is allowed
1.2201 + * to make that assumption.
1.2202 + *
1.2203 + * Side effects:
1.2204 + * None.
1.2205 + *
1.2206 + *----------------------------------------------------------------------
1.2207 + */
1.2208 +
1.2209 +static int
1.2210 +RequirementSatisfied(havei, req)
1.2211 + CONST char *havei; /* Version string, of candidate package we have */
1.2212 + CONST char *req; /* Requirement string the candidate has to satisfy */
1.2213 +{
1.2214 + /* The have candidate is already in internal rep. */
1.2215 +
1.2216 + int satisfied, res;
1.2217 + char* dash = NULL;
1.2218 + char* buf, *min, *max;
1.2219 +
1.2220 + dash = strchr (req, '-');
1.2221 + if (dash == NULL) {
1.2222 + /* No dash found, is a simple version, fallback to regular check.
1.2223 + * The 'CheckVersionAndConvert' cannot fail. We pad the requirement with
1.2224 + * 'a0', i.e '-2' before doing the comparison to properly accept
1.2225 + * unstables as well.
1.2226 + */
1.2227 +
1.2228 + char* reqi = NULL;
1.2229 + int thisIsMajor;
1.2230 +
1.2231 + CheckVersionAndConvert (NULL, req, &reqi, NULL);
1.2232 + strcat (reqi, " -2");
1.2233 + res = CompareVersions(havei, reqi, &thisIsMajor);
1.2234 + satisfied = (res == 0) || ((res == 1) && !thisIsMajor);
1.2235 + Tcl_Free (reqi);
1.2236 + return satisfied;
1.2237 + }
1.2238 +
1.2239 + /* Exactly one dash is present (Assumption of valid syntax). Copy the req,
1.2240 + * split at the location of dash and check that both parts are
1.2241 + * versions. Note that the max part can be empty.
1.2242 + */
1.2243 +
1.2244 + buf = strdup (req);
1.2245 + dash = buf + (dash - req);
1.2246 + *dash = '\0'; /* buf now <=> min part */
1.2247 + dash ++; /* dash now <=> max part */
1.2248 +
1.2249 + if (*dash == '\0') {
1.2250 + /* We have a min, but no max. For the comparison we generate the
1.2251 + * internal rep, padded with 'a0' i.e. '-2'.
1.2252 + */
1.2253 +
1.2254 + /* No max part, unbound */
1.2255 +
1.2256 + CheckVersionAndConvert (NULL, buf, &min, NULL);
1.2257 + strcat (min, " -2");
1.2258 + satisfied = (CompareVersions(havei, min, NULL) >= 0);
1.2259 + Tcl_Free (min);
1.2260 + free (buf);
1.2261 + return satisfied;
1.2262 + }
1.2263 +
1.2264 + /* We have both min and max, and generate their internal reps.
1.2265 + * When identical we compare as is, otherwise we pad with 'a0'
1.2266 + * to ove the range a bit.
1.2267 + */
1.2268 +
1.2269 + CheckVersionAndConvert (NULL, buf, &min, NULL);
1.2270 + CheckVersionAndConvert (NULL, dash, &max, NULL);
1.2271 +
1.2272 + if (CompareVersions(min, max, NULL) == 0) {
1.2273 + satisfied = (CompareVersions(min, havei, NULL) == 0);
1.2274 + } else {
1.2275 + strcat (min, " -2");
1.2276 + strcat (max, " -2");
1.2277 + satisfied = ((CompareVersions(min, havei, NULL) <= 0) &&
1.2278 + (CompareVersions(havei, max, NULL) < 0));
1.2279 + }
1.2280 +
1.2281 + Tcl_Free (min);
1.2282 + Tcl_Free (max);
1.2283 + free (buf);
1.2284 + return satisfied;
1.2285 +}
1.2286 +
1.2287 +/*
1.2288 + *----------------------------------------------------------------------
1.2289 + *
1.2290 + * ExactRequirement --
1.2291 + *
1.2292 + * This function is the core for the translation of -exact requests.
1.2293 + * It translates the request of the version into a range of versions.
1.2294 + * The translation was chosen for backwards compatibility.
1.2295 + *
1.2296 + * Results:
1.2297 + * A Tcl_Obj containing the version range as string.
1.2298 + *
1.2299 + * Side effects:
1.2300 + * None.
1.2301 + *
1.2302 + *----------------------------------------------------------------------
1.2303 + */
1.2304 +
1.2305 +static Tcl_Obj*
1.2306 +ExactRequirement(version)
1.2307 + CONST char* version;
1.2308 +{
1.2309 + /* A -exact request for a version X.y is translated into the range
1.2310 + * X.y-X.(y+1). For example -exact 8.4 means the range "8.4-8.5".
1.2311 + *
1.2312 + * This translation was chosen to prevent packages which currently use a
1.2313 + * 'package require -exact tclversion' from being affected by the core now
1.2314 + * registering itself as 8.4.x (patchlevel) instead of 8.4
1.2315 + * (version). Examples are tbcload, compiler, and ITcl.
1.2316 + *
1.2317 + * Translating -exact 8.4 to the range "8.4-8.4" instead would require us
1.2318 + * and everyone else to rebuild these packages to require -exact 8.4.14,
1.2319 + * or whatever the exact current patchlevel is. A backward compatibility
1.2320 + * issue with effects similar to the bugfix made in 8.5 now requiring
1.2321 + * ifneeded and provided versions to match. Instead we have chosen to
1.2322 + * interpret exactness to not be exactly equal, but to be exact only
1.2323 + * within the specified level, and allowing variation in the deeper
1.2324 + * level. More examples:
1.2325 + *
1.2326 + * -exact 8 => "8-9"
1.2327 + * -exact 8.4 => "8.4-8.5"
1.2328 + * -exact 8.4.14 => "8.4.14-8.4.15"
1.2329 + * -exact 8.0a2 => "8.0a2-8.0a3"
1.2330 + */
1.2331 +
1.2332 + char* iv;
1.2333 + int lc, i;
1.2334 + CONST char** lv;
1.2335 + char buf [30];
1.2336 + Tcl_Obj* o = Tcl_NewStringObj (version,-1);
1.2337 + Tcl_AppendStringsToObj (o, "-", NULL);
1.2338 +
1.2339 + /* Assuming valid syntax here */
1.2340 + CheckVersionAndConvert (NULL, version, &iv, NULL);
1.2341 +
1.2342 + /* Split the list into components */
1.2343 + Tcl_SplitList (NULL, iv, &lc, &lv);
1.2344 +
1.2345 + /* Iterate over the components and make them parts of the result. Except
1.2346 + * for the last, which is handled separately, to allow the
1.2347 + * incrementation.
1.2348 + */
1.2349 +
1.2350 + for (i=0; i < (lc-1); i++) {
1.2351 + /* Regular component */
1.2352 + Tcl_AppendStringsToObj (o, lv[i], NULL);
1.2353 + /* Separator component */
1.2354 + i ++;
1.2355 + if (0 == strcmp ("-1", lv[i])) {
1.2356 + Tcl_AppendStringsToObj (o, "b", NULL);
1.2357 + } else if (0 == strcmp ("-2", lv[i])) {
1.2358 + Tcl_AppendStringsToObj (o, "a", NULL);
1.2359 + } else {
1.2360 + Tcl_AppendStringsToObj (o, ".", NULL);
1.2361 + }
1.2362 + }
1.2363 + /* Regular component, last */
1.2364 + sprintf (buf, "%d", atoi (lv [lc-1]) + 1);
1.2365 + Tcl_AppendStringsToObj (o, buf, NULL);
1.2366 +
1.2367 + ckfree ((char*) lv);
1.2368 + return o;
1.2369 +}
1.2370 +
1.2371 +/*
1.2372 + *----------------------------------------------------------------------
1.2373 + *
1.2374 + * VersionCleanupProc --
1.2375 + *
1.2376 + * This function is called to delete the last remember package version
1.2377 + * string for an interpreter when the interpreter is deleted. It gets
1.2378 + * invoked via the Tcl AssocData mechanism.
1.2379 + *
1.2380 + * Results:
1.2381 + * None.
1.2382 + *
1.2383 + * Side effects:
1.2384 + * Storage for the version object for interp get deleted.
1.2385 + *
1.2386 + *----------------------------------------------------------------------
1.2387 + */
1.2388 +
1.2389 +static void
1.2390 +VersionCleanupProc (
1.2391 + ClientData clientData, /* Pointer to remembered version string object
1.2392 + * for interp. */
1.2393 + Tcl_Interp *interp) /* Interpreter that is being deleted. */
1.2394 +{
1.2395 + Tcl_Obj* ov = (Tcl_Obj*) clientData;
1.2396 + if (ov != NULL) {
1.2397 + Tcl_DecrRefCount (ov);
1.2398 + }
1.2399 +}
1.2400 +
1.2401 +/*
1.2402 + * Local Variables:
1.2403 + * mode: c
1.2404 + * c-basic-offset: 4
1.2405 + * fill-column: 78
1.2406 + * End:
1.2407 + */
1.2408 +#endif