[25] | 1 | /* |
---|
| 2 | * tclPkg.c -- |
---|
| 3 | * |
---|
| 4 | * This file implements package and version control for Tcl via the |
---|
| 5 | * "package" command and a few C APIs. |
---|
| 6 | * |
---|
| 7 | * Copyright (c) 1996 Sun Microsystems, Inc. |
---|
| 8 | * Copyright (c) 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net> |
---|
| 9 | * |
---|
| 10 | * See the file "license.terms" for information on usage and redistribution of |
---|
| 11 | * this file, and for a DISCLAIMER OF ALL WARRANTIES. |
---|
| 12 | * |
---|
| 13 | * RCS: @(#) $Id: tclPkg.c,v 1.34 2007/12/13 15:23:20 dgp Exp $ |
---|
| 14 | * |
---|
| 15 | * TIP #268. |
---|
| 16 | * Heavily rewritten to handle the extend version numbers, and extended |
---|
| 17 | * package requirements. |
---|
| 18 | */ |
---|
| 19 | |
---|
| 20 | #include "tclInt.h" |
---|
| 21 | |
---|
| 22 | /* |
---|
| 23 | * Each invocation of the "package ifneeded" command creates a structure of |
---|
| 24 | * the following type, which is used to load the package into the interpreter |
---|
| 25 | * if it is requested with a "package require" command. |
---|
| 26 | */ |
---|
| 27 | |
---|
| 28 | typedef struct PkgAvail { |
---|
| 29 | char *version; /* Version string; malloc'ed. */ |
---|
| 30 | char *script; /* Script to invoke to provide this version of |
---|
| 31 | * the package. Malloc'ed and protected by |
---|
| 32 | * Tcl_Preserve and Tcl_Release. */ |
---|
| 33 | struct PkgAvail *nextPtr; /* Next in list of available versions of the |
---|
| 34 | * same package. */ |
---|
| 35 | } PkgAvail; |
---|
| 36 | |
---|
| 37 | /* |
---|
| 38 | * For each package that is known in any way to an interpreter, there is one |
---|
| 39 | * record of the following type. These records are stored in the |
---|
| 40 | * "packageTable" hash table in the interpreter, keyed by package name such as |
---|
| 41 | * "Tk" (no version number). |
---|
| 42 | */ |
---|
| 43 | |
---|
| 44 | typedef struct Package { |
---|
| 45 | char *version; /* Version that has been supplied in this |
---|
| 46 | * interpreter via "package provide" |
---|
| 47 | * (malloc'ed). NULL means the package doesn't |
---|
| 48 | * exist in this interpreter yet. */ |
---|
| 49 | PkgAvail *availPtr; /* First in list of all available versions of |
---|
| 50 | * this package. */ |
---|
| 51 | ClientData clientData; /* Client data. */ |
---|
| 52 | } Package; |
---|
| 53 | |
---|
| 54 | /* |
---|
| 55 | * Prototypes for functions defined in this file: |
---|
| 56 | */ |
---|
| 57 | |
---|
| 58 | static int CheckVersionAndConvert(Tcl_Interp *interp, |
---|
| 59 | const char *string, char **internal, int *stable); |
---|
| 60 | static int CompareVersions(char *v1i, char *v2i, |
---|
| 61 | int *isMajorPtr); |
---|
| 62 | static int CheckRequirement(Tcl_Interp *interp, |
---|
| 63 | const char *string); |
---|
| 64 | static int CheckAllRequirements(Tcl_Interp *interp, int reqc, |
---|
| 65 | Tcl_Obj *const reqv[]); |
---|
| 66 | static int RequirementSatisfied(char *havei, const char *req); |
---|
| 67 | static int SomeRequirementSatisfied(char *havei, int reqc, |
---|
| 68 | Tcl_Obj *const reqv[]); |
---|
| 69 | static void AddRequirementsToResult(Tcl_Interp *interp, int reqc, |
---|
| 70 | Tcl_Obj *const reqv[]); |
---|
| 71 | static void AddRequirementsToDString(Tcl_DString *dstring, |
---|
| 72 | int reqc, Tcl_Obj *const reqv[]); |
---|
| 73 | static Package * FindPackage(Tcl_Interp *interp, const char *name); |
---|
| 74 | static const char * PkgRequireCore(Tcl_Interp *interp, const char *name, |
---|
| 75 | int reqc, Tcl_Obj *const reqv[], |
---|
| 76 | ClientData *clientDataPtr); |
---|
| 77 | |
---|
| 78 | /* |
---|
| 79 | * Helper macros. |
---|
| 80 | */ |
---|
| 81 | |
---|
| 82 | #define DupBlock(v,s,len) \ |
---|
| 83 | ((v) = ckalloc(len), memcpy((v),(s),(len))) |
---|
| 84 | #define DupString(v,s) \ |
---|
| 85 | do { \ |
---|
| 86 | unsigned local__len = (unsigned) (strlen(s) + 1); \ |
---|
| 87 | DupBlock((v),(s),local__len); \ |
---|
| 88 | } while (0) |
---|
| 89 | |
---|
| 90 | /* |
---|
| 91 | *---------------------------------------------------------------------- |
---|
| 92 | * |
---|
| 93 | * Tcl_PkgProvide / Tcl_PkgProvideEx -- |
---|
| 94 | * |
---|
| 95 | * This function is invoked to declare that a particular version of a |
---|
| 96 | * particular package is now present in an interpreter. There must not be |
---|
| 97 | * any other version of this package already provided in the interpreter. |
---|
| 98 | * |
---|
| 99 | * Results: |
---|
| 100 | * Normally returns TCL_OK; if there is already another version of the |
---|
| 101 | * package loaded then TCL_ERROR is returned and an error message is left |
---|
| 102 | * in the interp's result. |
---|
| 103 | * |
---|
| 104 | * Side effects: |
---|
| 105 | * The interpreter remembers that this package is available, so that no |
---|
| 106 | * other version of the package may be provided for the interpreter. |
---|
| 107 | * |
---|
| 108 | *---------------------------------------------------------------------- |
---|
| 109 | */ |
---|
| 110 | |
---|
| 111 | int |
---|
| 112 | Tcl_PkgProvide( |
---|
| 113 | Tcl_Interp *interp, /* Interpreter in which package is now |
---|
| 114 | * available. */ |
---|
| 115 | const char *name, /* Name of package. */ |
---|
| 116 | const char *version) /* Version string for package. */ |
---|
| 117 | { |
---|
| 118 | return Tcl_PkgProvideEx(interp, name, version, NULL); |
---|
| 119 | } |
---|
| 120 | |
---|
| 121 | int |
---|
| 122 | Tcl_PkgProvideEx( |
---|
| 123 | Tcl_Interp *interp, /* Interpreter in which package is now |
---|
| 124 | * available. */ |
---|
| 125 | const char *name, /* Name of package. */ |
---|
| 126 | const char *version, /* Version string for package. */ |
---|
| 127 | ClientData clientData) /* clientdata for this package (normally used |
---|
| 128 | * for C callback function table) */ |
---|
| 129 | { |
---|
| 130 | Package *pkgPtr; |
---|
| 131 | char *pvi, *vi; |
---|
| 132 | int res; |
---|
| 133 | |
---|
| 134 | pkgPtr = FindPackage(interp, name); |
---|
| 135 | if (pkgPtr->version == NULL) { |
---|
| 136 | DupString(pkgPtr->version, version); |
---|
| 137 | pkgPtr->clientData = clientData; |
---|
| 138 | return TCL_OK; |
---|
| 139 | } |
---|
| 140 | |
---|
| 141 | if (CheckVersionAndConvert(interp, pkgPtr->version, &pvi, |
---|
| 142 | NULL) != TCL_OK) { |
---|
| 143 | return TCL_ERROR; |
---|
| 144 | } else if (CheckVersionAndConvert(interp, version, &vi, NULL) != TCL_OK) { |
---|
| 145 | ckfree(pvi); |
---|
| 146 | return TCL_ERROR; |
---|
| 147 | } |
---|
| 148 | |
---|
| 149 | res = CompareVersions(pvi, vi, NULL); |
---|
| 150 | ckfree(pvi); |
---|
| 151 | ckfree(vi); |
---|
| 152 | |
---|
| 153 | if (res == 0) { |
---|
| 154 | if (clientData != NULL) { |
---|
| 155 | pkgPtr->clientData = clientData; |
---|
| 156 | } |
---|
| 157 | return TCL_OK; |
---|
| 158 | } |
---|
| 159 | Tcl_AppendResult(interp, "conflicting versions provided for package \"", |
---|
| 160 | name, "\": ", pkgPtr->version, ", then ", version, NULL); |
---|
| 161 | return TCL_ERROR; |
---|
| 162 | } |
---|
| 163 | |
---|
| 164 | /* |
---|
| 165 | *---------------------------------------------------------------------- |
---|
| 166 | * |
---|
| 167 | * Tcl_PkgRequire / Tcl_PkgRequireEx / Tcl_PkgRequireProc -- |
---|
| 168 | * |
---|
| 169 | * This function is called by code that depends on a particular version |
---|
| 170 | * of a particular package. If the package is not already provided in the |
---|
| 171 | * interpreter, this function invokes a Tcl script to provide it. If the |
---|
| 172 | * package is already provided, this function makes sure that the |
---|
| 173 | * caller's needs don't conflict with the version that is present. |
---|
| 174 | * |
---|
| 175 | * Results: |
---|
| 176 | * If successful, returns the version string for the currently provided |
---|
| 177 | * version of the package, which may be different from the "version" |
---|
| 178 | * argument. If the caller's requirements cannot be met (e.g. the version |
---|
| 179 | * requested conflicts with a currently provided version, or the required |
---|
| 180 | * version cannot be found, or the script to provide the required version |
---|
| 181 | * generates an error), NULL is returned and an error message is left in |
---|
| 182 | * the interp's result. |
---|
| 183 | * |
---|
| 184 | * Side effects: |
---|
| 185 | * The script from some previous "package ifneeded" command may be |
---|
| 186 | * invoked to provide the package. |
---|
| 187 | * |
---|
| 188 | *---------------------------------------------------------------------- |
---|
| 189 | */ |
---|
| 190 | |
---|
| 191 | const char * |
---|
| 192 | Tcl_PkgRequire( |
---|
| 193 | Tcl_Interp *interp, /* Interpreter in which package is now |
---|
| 194 | * available. */ |
---|
| 195 | const char *name, /* Name of desired package. */ |
---|
| 196 | const char *version, /* Version string for desired version; NULL |
---|
| 197 | * means use the latest version available. */ |
---|
| 198 | int exact) /* Non-zero means that only the particular |
---|
| 199 | * version given is acceptable. Zero means use |
---|
| 200 | * the latest compatible version. */ |
---|
| 201 | { |
---|
| 202 | return Tcl_PkgRequireEx(interp, name, version, exact, NULL); |
---|
| 203 | } |
---|
| 204 | |
---|
| 205 | const char * |
---|
| 206 | Tcl_PkgRequireEx( |
---|
| 207 | Tcl_Interp *interp, /* Interpreter in which package is now |
---|
| 208 | * available. */ |
---|
| 209 | const char *name, /* Name of desired package. */ |
---|
| 210 | const char *version, /* Version string for desired version; NULL |
---|
| 211 | * means use the latest version available. */ |
---|
| 212 | int exact, /* Non-zero means that only the particular |
---|
| 213 | * version given is acceptable. Zero means use |
---|
| 214 | * the latest compatible version. */ |
---|
| 215 | ClientData *clientDataPtr) /* Used to return the client data for this |
---|
| 216 | * package. If it is NULL then the client data |
---|
| 217 | * is not returned. This is unchanged if this |
---|
| 218 | * call fails for any reason. */ |
---|
| 219 | { |
---|
| 220 | Tcl_Obj *ov; |
---|
| 221 | const char *result = NULL; |
---|
| 222 | |
---|
| 223 | /* |
---|
| 224 | * If an attempt is being made to load this into a standalone executable |
---|
| 225 | * on a platform where backlinking is not supported then this must be a |
---|
| 226 | * shared version of Tcl (Otherwise the load would have failed). Detect |
---|
| 227 | * this situation by checking that this library has been correctly |
---|
| 228 | * initialised. If it has not been then return immediately as nothing will |
---|
| 229 | * work. |
---|
| 230 | */ |
---|
| 231 | |
---|
| 232 | if (tclEmptyStringRep == NULL) { |
---|
| 233 | /* |
---|
| 234 | * OK, so what's going on here? |
---|
| 235 | * |
---|
| 236 | * First, what are we doing? We are performing a check on behalf of |
---|
| 237 | * one particular caller, Tcl_InitStubs(). When a package is stub- |
---|
| 238 | * enabled, it is statically linked to libtclstub.a, which contains a |
---|
| 239 | * copy of Tcl_InitStubs(). When a stub-enabled package is loaded, its |
---|
| 240 | * *_Init() function is supposed to call Tcl_InitStubs() before |
---|
| 241 | * calling any other functions in the Tcl library. The first Tcl |
---|
| 242 | * function called by Tcl_InitStubs() through the stub table is |
---|
| 243 | * Tcl_PkgRequireEx(), so this code right here is the first code that |
---|
| 244 | * is part of the original Tcl library in the executable that gets |
---|
| 245 | * executed on behalf of a newly loaded stub-enabled package. |
---|
| 246 | * |
---|
| 247 | * One easy error for the developer/builder of a stub-enabled package |
---|
| 248 | * to make is to forget to define USE_TCL_STUBS when compiling the |
---|
| 249 | * package. When that happens, the package will contain symbols that |
---|
| 250 | * are references to the Tcl library, rather than function pointers |
---|
| 251 | * referencing the stub table. On platforms that lack backlinking, |
---|
| 252 | * those unresolved references may cause the loading of the package to |
---|
| 253 | * also load a second copy of the Tcl library, leading to all kinds of |
---|
| 254 | * trouble. We would like to catch that error and report a useful |
---|
| 255 | * message back to the user. That's what we're doing. |
---|
| 256 | * |
---|
| 257 | * Second, how does this work? If we reach this point, then the global |
---|
| 258 | * variable tclEmptyStringRep has the value NULL. Compare that with |
---|
| 259 | * the definition of tclEmptyStringRep near the top of the file |
---|
| 260 | * generic/tclObj.c. It clearly should not have the value NULL; it |
---|
| 261 | * should point to the char tclEmptyString. If we see it having the |
---|
| 262 | * value NULL, then somehow we are seeing a Tcl library that isn't |
---|
| 263 | * completely initialized, and that's an indicator for the error |
---|
| 264 | * condition described above. (Further explanation is welcome.) |
---|
| 265 | * |
---|
| 266 | * Third, so what do we do about it? This situation indicates the |
---|
| 267 | * package we just loaded wasn't properly compiled to be stub-enabled, |
---|
| 268 | * yet it thinks it is stub-enabled (it called Tcl_InitStubs()). We |
---|
| 269 | * want to report that the package just loaded is broken, so we want |
---|
| 270 | * to place an error message in the interpreter result and return NULL |
---|
| 271 | * to indicate failure to Tcl_InitStubs() so that it will also fail. |
---|
| 272 | * (Further explanation why we don't want to Tcl_Panic() is welcome. |
---|
| 273 | * After all, two Tcl libraries can't be a good thing!) |
---|
| 274 | * |
---|
| 275 | * Trouble is that's going to be tricky. We're now using a Tcl library |
---|
| 276 | * that's not fully initialized. In particular, it doesn't have a |
---|
| 277 | * proper value for tclEmptyStringRep. The Tcl_Obj system heavily |
---|
| 278 | * depends on the value of tclEmptyStringRep and all of Tcl depends |
---|
| 279 | * (increasingly) on the Tcl_Obj system, we need to correct that flaw |
---|
| 280 | * before making the calls to set the interpreter result to the error |
---|
| 281 | * message. That's the only flaw corrected; other problems with |
---|
| 282 | * initialization of the Tcl library are not remedied, so be very |
---|
| 283 | * careful about adding any other calls here without checking how they |
---|
| 284 | * behave when initialization is incomplete. |
---|
| 285 | */ |
---|
| 286 | |
---|
| 287 | tclEmptyStringRep = &tclEmptyString; |
---|
| 288 | Tcl_AppendResult(interp, "Cannot load package \"", name, |
---|
| 289 | "\" in standalone executable: This package is not " |
---|
| 290 | "compiled with stub support", NULL); |
---|
| 291 | return NULL; |
---|
| 292 | } |
---|
| 293 | |
---|
| 294 | /* |
---|
| 295 | * Translate between old and new API, and defer to the new function. |
---|
| 296 | */ |
---|
| 297 | |
---|
| 298 | if (version == NULL) { |
---|
| 299 | result = PkgRequireCore(interp, name, 0, NULL, clientDataPtr); |
---|
| 300 | } else { |
---|
| 301 | if (exact && TCL_OK |
---|
| 302 | != CheckVersionAndConvert(interp, version, NULL, NULL)) { |
---|
| 303 | return NULL; |
---|
| 304 | } |
---|
| 305 | ov = Tcl_NewStringObj(version, -1); |
---|
| 306 | if (exact) { |
---|
| 307 | Tcl_AppendStringsToObj(ov, "-", version, NULL); |
---|
| 308 | } |
---|
| 309 | Tcl_IncrRefCount(ov); |
---|
| 310 | result = PkgRequireCore(interp, name, 1, &ov, clientDataPtr); |
---|
| 311 | TclDecrRefCount(ov); |
---|
| 312 | } |
---|
| 313 | |
---|
| 314 | return result; |
---|
| 315 | } |
---|
| 316 | |
---|
| 317 | int |
---|
| 318 | Tcl_PkgRequireProc( |
---|
| 319 | Tcl_Interp *interp, /* Interpreter in which package is now |
---|
| 320 | * available. */ |
---|
| 321 | const char *name, /* Name of desired package. */ |
---|
| 322 | int reqc, /* Requirements constraining the desired |
---|
| 323 | * version. */ |
---|
| 324 | Tcl_Obj *const reqv[], /* 0 means to use the latest version |
---|
| 325 | * available. */ |
---|
| 326 | ClientData *clientDataPtr) |
---|
| 327 | { |
---|
| 328 | const char *result = |
---|
| 329 | PkgRequireCore(interp, name, reqc, reqv, clientDataPtr); |
---|
| 330 | |
---|
| 331 | if (result == NULL) { |
---|
| 332 | return TCL_ERROR; |
---|
| 333 | } |
---|
| 334 | Tcl_SetObjResult(interp, Tcl_NewStringObj(result, -1)); |
---|
| 335 | return TCL_OK; |
---|
| 336 | } |
---|
| 337 | |
---|
| 338 | static const char * |
---|
| 339 | PkgRequireCore( |
---|
| 340 | Tcl_Interp *interp, /* Interpreter in which package is now |
---|
| 341 | * available. */ |
---|
| 342 | const char *name, /* Name of desired package. */ |
---|
| 343 | int reqc, /* Requirements constraining the desired |
---|
| 344 | * version. */ |
---|
| 345 | Tcl_Obj *const reqv[], /* 0 means to use the latest version |
---|
| 346 | * available. */ |
---|
| 347 | ClientData *clientDataPtr) |
---|
| 348 | { |
---|
| 349 | Interp *iPtr = (Interp *) interp; |
---|
| 350 | Package *pkgPtr; |
---|
| 351 | PkgAvail *availPtr, *bestPtr, *bestStablePtr; |
---|
| 352 | char *availVersion, *bestVersion; |
---|
| 353 | /* Internal rep. of versions */ |
---|
| 354 | int availStable, code, satisfies, pass; |
---|
| 355 | char *script, *pkgVersionI; |
---|
| 356 | Tcl_DString command; |
---|
| 357 | |
---|
| 358 | /* |
---|
| 359 | * It can take up to three passes to find the package: one pass to run the |
---|
| 360 | * "package unknown" script, one to run the "package ifneeded" script for |
---|
| 361 | * a specific version, and a final pass to lookup the package loaded by |
---|
| 362 | * the "package ifneeded" script. |
---|
| 363 | */ |
---|
| 364 | |
---|
| 365 | for (pass=1 ;; pass++) { |
---|
| 366 | pkgPtr = FindPackage(interp, name); |
---|
| 367 | if (pkgPtr->version != NULL) { |
---|
| 368 | break; |
---|
| 369 | } |
---|
| 370 | |
---|
| 371 | /* |
---|
| 372 | * Check whether we're already attempting to load some version of this |
---|
| 373 | * package (circular dependency detection). |
---|
| 374 | */ |
---|
| 375 | |
---|
| 376 | if (pkgPtr->clientData != NULL) { |
---|
| 377 | Tcl_AppendResult(interp, "circular package dependency: " |
---|
| 378 | "attempt to provide ", name, " ", |
---|
| 379 | (char *) pkgPtr->clientData, " requires ", name, NULL); |
---|
| 380 | AddRequirementsToResult(interp, reqc, reqv); |
---|
| 381 | return NULL; |
---|
| 382 | } |
---|
| 383 | |
---|
| 384 | /* |
---|
| 385 | * The package isn't yet present. Search the list of available |
---|
| 386 | * versions and invoke the script for the best available version. We |
---|
| 387 | * are actually locating the best, and the best stable version. One of |
---|
| 388 | * them is then chosen based on the selection mode. |
---|
| 389 | */ |
---|
| 390 | |
---|
| 391 | bestPtr = NULL; |
---|
| 392 | bestStablePtr = NULL; |
---|
| 393 | bestVersion = NULL; |
---|
| 394 | |
---|
| 395 | for (availPtr = pkgPtr->availPtr; availPtr != NULL; |
---|
| 396 | availPtr = availPtr->nextPtr) { |
---|
| 397 | if (CheckVersionAndConvert(interp, availPtr->version, |
---|
| 398 | &availVersion, &availStable) != TCL_OK) { |
---|
| 399 | /* |
---|
| 400 | * The provided version number has invalid syntax. This |
---|
| 401 | * should not happen. This should have been caught by the |
---|
| 402 | * 'package ifneeded' registering the package. |
---|
| 403 | */ |
---|
| 404 | |
---|
| 405 | continue; |
---|
| 406 | } |
---|
| 407 | |
---|
| 408 | if (bestPtr != NULL) { |
---|
| 409 | int res = CompareVersions(availVersion, bestVersion, NULL); |
---|
| 410 | |
---|
| 411 | /* |
---|
| 412 | * Note: Use internal reps! |
---|
| 413 | */ |
---|
| 414 | |
---|
| 415 | if (res <= 0) { |
---|
| 416 | /* |
---|
| 417 | * The version of the package sought is not as good as the |
---|
| 418 | * currently selected version. Ignore it. |
---|
| 419 | */ |
---|
| 420 | |
---|
| 421 | ckfree(availVersion); |
---|
| 422 | availVersion = NULL; |
---|
| 423 | continue; |
---|
| 424 | } |
---|
| 425 | } |
---|
| 426 | |
---|
| 427 | /* We have found a version which is better than our max. */ |
---|
| 428 | |
---|
| 429 | if (reqc > 0) { |
---|
| 430 | /* Check satisfaction of requirements. */ |
---|
| 431 | |
---|
| 432 | satisfies = SomeRequirementSatisfied(availVersion, reqc, reqv); |
---|
| 433 | if (!satisfies) { |
---|
| 434 | ckfree(availVersion); |
---|
| 435 | availVersion = NULL; |
---|
| 436 | continue; |
---|
| 437 | } |
---|
| 438 | } |
---|
| 439 | |
---|
| 440 | bestPtr = availPtr; |
---|
| 441 | |
---|
| 442 | if (bestVersion != NULL) { |
---|
| 443 | ckfree(bestVersion); |
---|
| 444 | } |
---|
| 445 | bestVersion = availVersion; |
---|
| 446 | |
---|
| 447 | /* |
---|
| 448 | * If this new best version is stable then it also has to be |
---|
| 449 | * better than the max stable version found so far. |
---|
| 450 | */ |
---|
| 451 | |
---|
| 452 | if (availStable) { |
---|
| 453 | bestStablePtr = availPtr; |
---|
| 454 | } |
---|
| 455 | } |
---|
| 456 | |
---|
| 457 | if (bestVersion != NULL) { |
---|
| 458 | ckfree(bestVersion); |
---|
| 459 | } |
---|
| 460 | |
---|
| 461 | /* |
---|
| 462 | * Now choose a version among the two best. For 'latest' we simply |
---|
| 463 | * take (actually keep) the best. For 'stable' we take the best |
---|
| 464 | * stable, if there is any, or the best if there is nothing stable. |
---|
| 465 | */ |
---|
| 466 | |
---|
| 467 | if ((iPtr->packagePrefer == PKG_PREFER_STABLE) |
---|
| 468 | && (bestStablePtr != NULL)) { |
---|
| 469 | bestPtr = bestStablePtr; |
---|
| 470 | } |
---|
| 471 | |
---|
| 472 | if (bestPtr != NULL) { |
---|
| 473 | /* |
---|
| 474 | * We found an ifneeded script for the package. Be careful while |
---|
| 475 | * executing it: this could cause reentrancy, so (a) protect the |
---|
| 476 | * script itself from deletion and (b) don't assume that bestPtr |
---|
| 477 | * will still exist when the script completes. |
---|
| 478 | */ |
---|
| 479 | |
---|
| 480 | const char *versionToProvide = bestPtr->version; |
---|
| 481 | script = bestPtr->script; |
---|
| 482 | |
---|
| 483 | pkgPtr->clientData = (ClientData) versionToProvide; |
---|
| 484 | Tcl_Preserve((ClientData) script); |
---|
| 485 | Tcl_Preserve((ClientData) versionToProvide); |
---|
| 486 | code = Tcl_EvalEx(interp, script, -1, TCL_EVAL_GLOBAL); |
---|
| 487 | Tcl_Release((ClientData) script); |
---|
| 488 | |
---|
| 489 | pkgPtr = FindPackage(interp, name); |
---|
| 490 | if (code == TCL_OK) { |
---|
| 491 | Tcl_ResetResult(interp); |
---|
| 492 | if (pkgPtr->version == NULL) { |
---|
| 493 | code = TCL_ERROR; |
---|
| 494 | Tcl_AppendResult(interp, "attempt to provide package ", |
---|
| 495 | name, " ", versionToProvide, |
---|
| 496 | " failed: no version of package ", name, |
---|
| 497 | " provided", NULL); |
---|
| 498 | } else { |
---|
| 499 | char *pvi, *vi; |
---|
| 500 | |
---|
| 501 | if (CheckVersionAndConvert(interp, pkgPtr->version, &pvi, |
---|
| 502 | NULL) != TCL_OK) { |
---|
| 503 | code = TCL_ERROR; |
---|
| 504 | } else if (CheckVersionAndConvert(interp, |
---|
| 505 | versionToProvide, &vi, NULL) != TCL_OK) { |
---|
| 506 | ckfree(pvi); |
---|
| 507 | code = TCL_ERROR; |
---|
| 508 | } else { |
---|
| 509 | int res = CompareVersions(pvi, vi, NULL); |
---|
| 510 | |
---|
| 511 | ckfree(pvi); |
---|
| 512 | ckfree(vi); |
---|
| 513 | if (res != 0) { |
---|
| 514 | code = TCL_ERROR; |
---|
| 515 | Tcl_AppendResult(interp, |
---|
| 516 | "attempt to provide package ", name, " ", |
---|
| 517 | versionToProvide, " failed: package ", |
---|
| 518 | name, " ", pkgPtr->version, |
---|
| 519 | " provided instead", NULL); |
---|
| 520 | } |
---|
| 521 | } |
---|
| 522 | } |
---|
| 523 | } else if (code != TCL_ERROR) { |
---|
| 524 | Tcl_Obj *codePtr = Tcl_NewIntObj(code); |
---|
| 525 | |
---|
| 526 | Tcl_ResetResult(interp); |
---|
| 527 | Tcl_AppendResult(interp, "attempt to provide package ", name, |
---|
| 528 | " ", versionToProvide, " failed: bad return code: ", |
---|
| 529 | TclGetString(codePtr), NULL); |
---|
| 530 | TclDecrRefCount(codePtr); |
---|
| 531 | code = TCL_ERROR; |
---|
| 532 | } |
---|
| 533 | |
---|
| 534 | if (code == TCL_ERROR) { |
---|
| 535 | Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( |
---|
| 536 | "\n (\"package ifneeded %s %s\" script)", |
---|
| 537 | name, versionToProvide)); |
---|
| 538 | } |
---|
| 539 | Tcl_Release((ClientData) versionToProvide); |
---|
| 540 | |
---|
| 541 | if (code != TCL_OK) { |
---|
| 542 | /* |
---|
| 543 | * Take a non-TCL_OK code from the script as an indication the |
---|
| 544 | * package wasn't loaded properly, so the package system |
---|
| 545 | * should not remember an improper load. |
---|
| 546 | * |
---|
| 547 | * This is consistent with our returning NULL. If we're not |
---|
| 548 | * willing to tell our caller we got a particular version, we |
---|
| 549 | * shouldn't store that version for telling future callers |
---|
| 550 | * either. |
---|
| 551 | */ |
---|
| 552 | |
---|
| 553 | if (pkgPtr->version != NULL) { |
---|
| 554 | ckfree(pkgPtr->version); |
---|
| 555 | pkgPtr->version = NULL; |
---|
| 556 | } |
---|
| 557 | pkgPtr->clientData = NULL; |
---|
| 558 | return NULL; |
---|
| 559 | } |
---|
| 560 | |
---|
| 561 | break; |
---|
| 562 | } |
---|
| 563 | |
---|
| 564 | /* |
---|
| 565 | * The package is not in the database. If there is a "package unknown" |
---|
| 566 | * command, invoke it (but only on the first pass; after that, we |
---|
| 567 | * should not get here in the first place). |
---|
| 568 | */ |
---|
| 569 | |
---|
| 570 | if (pass > 1) { |
---|
| 571 | break; |
---|
| 572 | } |
---|
| 573 | |
---|
| 574 | script = ((Interp *) interp)->packageUnknown; |
---|
| 575 | if (script != NULL) { |
---|
| 576 | Tcl_DStringInit(&command); |
---|
| 577 | Tcl_DStringAppend(&command, script, -1); |
---|
| 578 | Tcl_DStringAppendElement(&command, name); |
---|
| 579 | AddRequirementsToDString(&command, reqc, reqv); |
---|
| 580 | |
---|
| 581 | code = Tcl_EvalEx(interp, Tcl_DStringValue(&command), |
---|
| 582 | Tcl_DStringLength(&command), TCL_EVAL_GLOBAL); |
---|
| 583 | Tcl_DStringFree(&command); |
---|
| 584 | |
---|
| 585 | if ((code != TCL_OK) && (code != TCL_ERROR)) { |
---|
| 586 | Tcl_Obj *codePtr = Tcl_NewIntObj(code); |
---|
| 587 | Tcl_ResetResult(interp); |
---|
| 588 | Tcl_AppendResult(interp, "bad return code: ", |
---|
| 589 | TclGetString(codePtr), NULL); |
---|
| 590 | Tcl_DecrRefCount(codePtr); |
---|
| 591 | code = TCL_ERROR; |
---|
| 592 | } |
---|
| 593 | if (code == TCL_ERROR) { |
---|
| 594 | Tcl_AddErrorInfo(interp, |
---|
| 595 | "\n (\"package unknown\" script)"); |
---|
| 596 | return NULL; |
---|
| 597 | } |
---|
| 598 | Tcl_ResetResult(interp); |
---|
| 599 | } |
---|
| 600 | } |
---|
| 601 | |
---|
| 602 | if (pkgPtr->version == NULL) { |
---|
| 603 | Tcl_AppendResult(interp, "can't find package ", name, NULL); |
---|
| 604 | AddRequirementsToResult(interp, reqc, reqv); |
---|
| 605 | return NULL; |
---|
| 606 | } |
---|
| 607 | |
---|
| 608 | /* |
---|
| 609 | * At this point we know that the package is present. Make sure that the |
---|
| 610 | * provided version meets the current requirements. |
---|
| 611 | */ |
---|
| 612 | |
---|
| 613 | if (reqc == 0) { |
---|
| 614 | satisfies = 1; |
---|
| 615 | } else { |
---|
| 616 | CheckVersionAndConvert(interp, pkgPtr->version, &pkgVersionI, NULL); |
---|
| 617 | satisfies = SomeRequirementSatisfied(pkgVersionI, reqc, reqv); |
---|
| 618 | |
---|
| 619 | ckfree(pkgVersionI); |
---|
| 620 | } |
---|
| 621 | |
---|
| 622 | if (satisfies) { |
---|
| 623 | if (clientDataPtr) { |
---|
| 624 | *clientDataPtr = pkgPtr->clientData; |
---|
| 625 | } |
---|
| 626 | return pkgPtr->version; |
---|
| 627 | } |
---|
| 628 | |
---|
| 629 | Tcl_AppendResult(interp, "version conflict for package \"", name, |
---|
| 630 | "\": have ", pkgPtr->version, ", need", NULL); |
---|
| 631 | AddRequirementsToResult(interp, reqc, reqv); |
---|
| 632 | return NULL; |
---|
| 633 | } |
---|
| 634 | |
---|
| 635 | /* |
---|
| 636 | *---------------------------------------------------------------------- |
---|
| 637 | * |
---|
| 638 | * Tcl_PkgPresent / Tcl_PkgPresentEx -- |
---|
| 639 | * |
---|
| 640 | * Checks to see whether the specified package is present. If it is not |
---|
| 641 | * then no additional action is taken. |
---|
| 642 | * |
---|
| 643 | * Results: |
---|
| 644 | * If successful, returns the version string for the currently provided |
---|
| 645 | * version of the package, which may be different from the "version" |
---|
| 646 | * argument. If the caller's requirements cannot be met (e.g. the version |
---|
| 647 | * requested conflicts with a currently provided version), NULL is |
---|
| 648 | * returned and an error message is left in interp->result. |
---|
| 649 | * |
---|
| 650 | * Side effects: |
---|
| 651 | * None. |
---|
| 652 | * |
---|
| 653 | *---------------------------------------------------------------------- |
---|
| 654 | */ |
---|
| 655 | |
---|
| 656 | const char * |
---|
| 657 | Tcl_PkgPresent( |
---|
| 658 | Tcl_Interp *interp, /* Interpreter in which package is now |
---|
| 659 | * available. */ |
---|
| 660 | const char *name, /* Name of desired package. */ |
---|
| 661 | const char *version, /* Version string for desired version; NULL |
---|
| 662 | * means use the latest version available. */ |
---|
| 663 | int exact) /* Non-zero means that only the particular |
---|
| 664 | * version given is acceptable. Zero means use |
---|
| 665 | * the latest compatible version. */ |
---|
| 666 | { |
---|
| 667 | return Tcl_PkgPresentEx(interp, name, version, exact, NULL); |
---|
| 668 | } |
---|
| 669 | |
---|
| 670 | const char * |
---|
| 671 | Tcl_PkgPresentEx( |
---|
| 672 | Tcl_Interp *interp, /* Interpreter in which package is now |
---|
| 673 | * available. */ |
---|
| 674 | const char *name, /* Name of desired package. */ |
---|
| 675 | const char *version, /* Version string for desired version; NULL |
---|
| 676 | * means use the latest version available. */ |
---|
| 677 | int exact, /* Non-zero means that only the particular |
---|
| 678 | * version given is acceptable. Zero means use |
---|
| 679 | * the latest compatible version. */ |
---|
| 680 | ClientData *clientDataPtr) /* Used to return the client data for this |
---|
| 681 | * package. If it is NULL then the client data |
---|
| 682 | * is not returned. This is unchanged if this |
---|
| 683 | * call fails for any reason. */ |
---|
| 684 | { |
---|
| 685 | Interp *iPtr = (Interp *) interp; |
---|
| 686 | Tcl_HashEntry *hPtr; |
---|
| 687 | Package *pkgPtr; |
---|
| 688 | |
---|
| 689 | hPtr = Tcl_FindHashEntry(&iPtr->packageTable, name); |
---|
| 690 | if (hPtr) { |
---|
| 691 | pkgPtr = Tcl_GetHashValue(hPtr); |
---|
| 692 | if (pkgPtr->version != NULL) { |
---|
| 693 | /* |
---|
| 694 | * At this point we know that the package is present. Make sure |
---|
| 695 | * that the provided version meets the current requirement by |
---|
| 696 | * calling Tcl_PkgRequireEx() to check for us. |
---|
| 697 | */ |
---|
| 698 | |
---|
| 699 | const char *foundVersion = Tcl_PkgRequireEx(interp, name, version, |
---|
| 700 | exact, clientDataPtr); |
---|
| 701 | |
---|
| 702 | if (foundVersion == NULL) { |
---|
| 703 | Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PACKAGE", name, |
---|
| 704 | NULL); |
---|
| 705 | } |
---|
| 706 | return foundVersion; |
---|
| 707 | } |
---|
| 708 | } |
---|
| 709 | |
---|
| 710 | if (version != NULL) { |
---|
| 711 | Tcl_AppendResult(interp, "package ", name, " ", version, |
---|
| 712 | " is not present", NULL); |
---|
| 713 | } else { |
---|
| 714 | Tcl_AppendResult(interp, "package ", name, " is not present", NULL); |
---|
| 715 | } |
---|
| 716 | Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PACKAGE", name, NULL); |
---|
| 717 | return NULL; |
---|
| 718 | } |
---|
| 719 | |
---|
| 720 | /* |
---|
| 721 | *---------------------------------------------------------------------- |
---|
| 722 | * |
---|
| 723 | * Tcl_PackageObjCmd -- |
---|
| 724 | * |
---|
| 725 | * This function is invoked to process the "package" Tcl command. See the |
---|
| 726 | * user documentation for details on what it does. |
---|
| 727 | * |
---|
| 728 | * Results: |
---|
| 729 | * A standard Tcl result. |
---|
| 730 | * |
---|
| 731 | * Side effects: |
---|
| 732 | * See the user documentation. |
---|
| 733 | * |
---|
| 734 | *---------------------------------------------------------------------- |
---|
| 735 | */ |
---|
| 736 | |
---|
| 737 | /* ARGSUSED */ |
---|
| 738 | int |
---|
| 739 | Tcl_PackageObjCmd( |
---|
| 740 | ClientData dummy, /* Not used. */ |
---|
| 741 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
| 742 | int objc, /* Number of arguments. */ |
---|
| 743 | Tcl_Obj *const objv[]) /* Argument objects. */ |
---|
| 744 | { |
---|
| 745 | static const char *pkgOptions[] = { |
---|
| 746 | "forget", "ifneeded", "names", "prefer", "present", |
---|
| 747 | "provide", "require", "unknown", "vcompare", "versions", |
---|
| 748 | "vsatisfies", NULL |
---|
| 749 | }; |
---|
| 750 | enum pkgOptions { |
---|
| 751 | PKG_FORGET, PKG_IFNEEDED, PKG_NAMES, PKG_PREFER, PKG_PRESENT, |
---|
| 752 | PKG_PROVIDE, PKG_REQUIRE, PKG_UNKNOWN, PKG_VCOMPARE, PKG_VERSIONS, |
---|
| 753 | PKG_VSATISFIES |
---|
| 754 | }; |
---|
| 755 | Interp *iPtr = (Interp *) interp; |
---|
| 756 | int optionIndex, exact, i, satisfies; |
---|
| 757 | PkgAvail *availPtr, *prevPtr; |
---|
| 758 | Package *pkgPtr; |
---|
| 759 | Tcl_HashEntry *hPtr; |
---|
| 760 | Tcl_HashSearch search; |
---|
| 761 | Tcl_HashTable *tablePtr; |
---|
| 762 | const char *version; |
---|
| 763 | char *argv2, *argv3, *argv4, *iva = NULL, *ivb = NULL; |
---|
| 764 | |
---|
| 765 | if (objc < 2) { |
---|
| 766 | Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?"); |
---|
| 767 | return TCL_ERROR; |
---|
| 768 | } |
---|
| 769 | |
---|
| 770 | if (Tcl_GetIndexFromObj(interp, objv[1], pkgOptions, "option", 0, |
---|
| 771 | &optionIndex) != TCL_OK) { |
---|
| 772 | return TCL_ERROR; |
---|
| 773 | } |
---|
| 774 | switch ((enum pkgOptions) optionIndex) { |
---|
| 775 | case PKG_FORGET: { |
---|
| 776 | char *keyString; |
---|
| 777 | |
---|
| 778 | for (i = 2; i < objc; i++) { |
---|
| 779 | keyString = TclGetString(objv[i]); |
---|
| 780 | hPtr = Tcl_FindHashEntry(&iPtr->packageTable, keyString); |
---|
| 781 | if (hPtr == NULL) { |
---|
| 782 | continue; |
---|
| 783 | } |
---|
| 784 | pkgPtr = Tcl_GetHashValue(hPtr); |
---|
| 785 | Tcl_DeleteHashEntry(hPtr); |
---|
| 786 | if (pkgPtr->version != NULL) { |
---|
| 787 | ckfree(pkgPtr->version); |
---|
| 788 | } |
---|
| 789 | while (pkgPtr->availPtr != NULL) { |
---|
| 790 | availPtr = pkgPtr->availPtr; |
---|
| 791 | pkgPtr->availPtr = availPtr->nextPtr; |
---|
| 792 | Tcl_EventuallyFree((ClientData)availPtr->version, TCL_DYNAMIC); |
---|
| 793 | Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC); |
---|
| 794 | ckfree((char *) availPtr); |
---|
| 795 | } |
---|
| 796 | ckfree((char *) pkgPtr); |
---|
| 797 | } |
---|
| 798 | break; |
---|
| 799 | } |
---|
| 800 | case PKG_IFNEEDED: { |
---|
| 801 | int length, res; |
---|
| 802 | char *argv3i, *avi; |
---|
| 803 | |
---|
| 804 | if ((objc != 4) && (objc != 5)) { |
---|
| 805 | Tcl_WrongNumArgs(interp, 2, objv, "package version ?script?"); |
---|
| 806 | return TCL_ERROR; |
---|
| 807 | } |
---|
| 808 | argv3 = TclGetString(objv[3]); |
---|
| 809 | if (CheckVersionAndConvert(interp, argv3, &argv3i, NULL) != TCL_OK) { |
---|
| 810 | return TCL_ERROR; |
---|
| 811 | } |
---|
| 812 | argv2 = TclGetString(objv[2]); |
---|
| 813 | if (objc == 4) { |
---|
| 814 | hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2); |
---|
| 815 | if (hPtr == NULL) { |
---|
| 816 | ckfree(argv3i); |
---|
| 817 | return TCL_OK; |
---|
| 818 | } |
---|
| 819 | pkgPtr = Tcl_GetHashValue(hPtr); |
---|
| 820 | } else { |
---|
| 821 | pkgPtr = FindPackage(interp, argv2); |
---|
| 822 | } |
---|
| 823 | argv3 = Tcl_GetStringFromObj(objv[3], &length); |
---|
| 824 | |
---|
| 825 | for (availPtr = pkgPtr->availPtr, prevPtr = NULL; availPtr != NULL; |
---|
| 826 | prevPtr = availPtr, availPtr = availPtr->nextPtr) { |
---|
| 827 | if (CheckVersionAndConvert(interp, availPtr->version, &avi, |
---|
| 828 | NULL) != TCL_OK) { |
---|
| 829 | ckfree(argv3i); |
---|
| 830 | return TCL_ERROR; |
---|
| 831 | } |
---|
| 832 | |
---|
| 833 | res = CompareVersions(avi, argv3i, NULL); |
---|
| 834 | ckfree(avi); |
---|
| 835 | |
---|
| 836 | if (res == 0){ |
---|
| 837 | if (objc == 4) { |
---|
| 838 | ckfree(argv3i); |
---|
| 839 | Tcl_SetResult(interp, availPtr->script, TCL_VOLATILE); |
---|
| 840 | return TCL_OK; |
---|
| 841 | } |
---|
| 842 | Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC); |
---|
| 843 | break; |
---|
| 844 | } |
---|
| 845 | } |
---|
| 846 | ckfree(argv3i); |
---|
| 847 | |
---|
| 848 | if (objc == 4) { |
---|
| 849 | return TCL_OK; |
---|
| 850 | } |
---|
| 851 | if (availPtr == NULL) { |
---|
| 852 | availPtr = (PkgAvail *) ckalloc(sizeof(PkgAvail)); |
---|
| 853 | DupBlock(availPtr->version, argv3, (unsigned) length + 1); |
---|
| 854 | |
---|
| 855 | if (prevPtr == NULL) { |
---|
| 856 | availPtr->nextPtr = pkgPtr->availPtr; |
---|
| 857 | pkgPtr->availPtr = availPtr; |
---|
| 858 | } else { |
---|
| 859 | availPtr->nextPtr = prevPtr->nextPtr; |
---|
| 860 | prevPtr->nextPtr = availPtr; |
---|
| 861 | } |
---|
| 862 | } |
---|
| 863 | argv4 = Tcl_GetStringFromObj(objv[4], &length); |
---|
| 864 | DupBlock(availPtr->script, argv4, (unsigned) length + 1); |
---|
| 865 | break; |
---|
| 866 | } |
---|
| 867 | case PKG_NAMES: |
---|
| 868 | if (objc != 2) { |
---|
| 869 | Tcl_WrongNumArgs(interp, 2, objv, NULL); |
---|
| 870 | return TCL_ERROR; |
---|
| 871 | } |
---|
| 872 | tablePtr = &iPtr->packageTable; |
---|
| 873 | for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL; |
---|
| 874 | hPtr = Tcl_NextHashEntry(&search)) { |
---|
| 875 | pkgPtr = Tcl_GetHashValue(hPtr); |
---|
| 876 | if ((pkgPtr->version != NULL) || (pkgPtr->availPtr != NULL)) { |
---|
| 877 | Tcl_AppendElement(interp, Tcl_GetHashKey(tablePtr, hPtr)); |
---|
| 878 | } |
---|
| 879 | } |
---|
| 880 | break; |
---|
| 881 | case PKG_PRESENT: { |
---|
| 882 | const char *name; |
---|
| 883 | if (objc < 3) { |
---|
| 884 | goto require; |
---|
| 885 | } |
---|
| 886 | argv2 = TclGetString(objv[2]); |
---|
| 887 | if ((argv2[0] == '-') && (strcmp(argv2, "-exact") == 0)) { |
---|
| 888 | if (objc != 5) { |
---|
| 889 | goto requireSyntax; |
---|
| 890 | } |
---|
| 891 | exact = 1; |
---|
| 892 | name = TclGetString(objv[3]); |
---|
| 893 | } else { |
---|
| 894 | exact = 0; |
---|
| 895 | name = argv2; |
---|
| 896 | } |
---|
| 897 | |
---|
| 898 | hPtr = Tcl_FindHashEntry(&iPtr->packageTable, name); |
---|
| 899 | if (hPtr != NULL) { |
---|
| 900 | pkgPtr = Tcl_GetHashValue(hPtr); |
---|
| 901 | if (pkgPtr->version != NULL) { |
---|
| 902 | goto require; |
---|
| 903 | } |
---|
| 904 | } |
---|
| 905 | |
---|
| 906 | version = NULL; |
---|
| 907 | if (exact) { |
---|
| 908 | version = TclGetString(objv[4]); |
---|
| 909 | if (CheckVersionAndConvert(interp, version, NULL, |
---|
| 910 | NULL) != TCL_OK) { |
---|
| 911 | return TCL_ERROR; |
---|
| 912 | } |
---|
| 913 | } else { |
---|
| 914 | if (CheckAllRequirements(interp, objc-3, objv+3) != TCL_OK) { |
---|
| 915 | return TCL_ERROR; |
---|
| 916 | } |
---|
| 917 | if ((objc > 3) && (CheckVersionAndConvert(interp, |
---|
| 918 | TclGetString(objv[3]), NULL, NULL) == TCL_OK)) { |
---|
| 919 | version = TclGetString(objv[3]); |
---|
| 920 | } |
---|
| 921 | } |
---|
| 922 | Tcl_PkgPresent(interp, name, version, exact); |
---|
| 923 | return TCL_ERROR; |
---|
| 924 | break; |
---|
| 925 | } |
---|
| 926 | case PKG_PROVIDE: |
---|
| 927 | if ((objc != 3) && (objc != 4)) { |
---|
| 928 | Tcl_WrongNumArgs(interp, 2, objv, "package ?version?"); |
---|
| 929 | return TCL_ERROR; |
---|
| 930 | } |
---|
| 931 | argv2 = TclGetString(objv[2]); |
---|
| 932 | if (objc == 3) { |
---|
| 933 | hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2); |
---|
| 934 | if (hPtr != NULL) { |
---|
| 935 | pkgPtr = Tcl_GetHashValue(hPtr); |
---|
| 936 | if (pkgPtr->version != NULL) { |
---|
| 937 | Tcl_SetResult(interp, pkgPtr->version, TCL_VOLATILE); |
---|
| 938 | } |
---|
| 939 | } |
---|
| 940 | return TCL_OK; |
---|
| 941 | } |
---|
| 942 | argv3 = TclGetString(objv[3]); |
---|
| 943 | if (CheckVersionAndConvert(interp, argv3, NULL, NULL) != TCL_OK) { |
---|
| 944 | return TCL_ERROR; |
---|
| 945 | } |
---|
| 946 | return Tcl_PkgProvide(interp, argv2, argv3); |
---|
| 947 | case PKG_REQUIRE: |
---|
| 948 | require: |
---|
| 949 | if (objc < 3) { |
---|
| 950 | requireSyntax: |
---|
| 951 | Tcl_WrongNumArgs(interp, 2, objv, |
---|
| 952 | "?-exact? package ?requirement...?"); |
---|
| 953 | return TCL_ERROR; |
---|
| 954 | } |
---|
| 955 | |
---|
| 956 | version = NULL; |
---|
| 957 | |
---|
| 958 | argv2 = TclGetString(objv[2]); |
---|
| 959 | if ((argv2[0] == '-') && (strcmp(argv2, "-exact") == 0)) { |
---|
| 960 | Tcl_Obj *ov; |
---|
| 961 | int res; |
---|
| 962 | |
---|
| 963 | if (objc != 5) { |
---|
| 964 | goto requireSyntax; |
---|
| 965 | } |
---|
| 966 | |
---|
| 967 | version = TclGetString(objv[4]); |
---|
| 968 | if (CheckVersionAndConvert(interp, version, NULL, |
---|
| 969 | NULL) != TCL_OK) { |
---|
| 970 | return TCL_ERROR; |
---|
| 971 | } |
---|
| 972 | |
---|
| 973 | /* |
---|
| 974 | * Create a new-style requirement for the exact version. |
---|
| 975 | */ |
---|
| 976 | |
---|
| 977 | ov = Tcl_NewStringObj(version, -1); |
---|
| 978 | Tcl_AppendStringsToObj(ov, "-", version, NULL); |
---|
| 979 | version = NULL; |
---|
| 980 | argv3 = TclGetString(objv[3]); |
---|
| 981 | |
---|
| 982 | Tcl_IncrRefCount(ov); |
---|
| 983 | res = Tcl_PkgRequireProc(interp, argv3, 1, &ov, NULL); |
---|
| 984 | TclDecrRefCount(ov); |
---|
| 985 | return res; |
---|
| 986 | } else { |
---|
| 987 | if (CheckAllRequirements(interp, objc-3, objv+3) != TCL_OK) { |
---|
| 988 | return TCL_ERROR; |
---|
| 989 | } |
---|
| 990 | |
---|
| 991 | return Tcl_PkgRequireProc(interp, argv2, objc-3, objv+3, NULL); |
---|
| 992 | } |
---|
| 993 | break; |
---|
| 994 | case PKG_UNKNOWN: { |
---|
| 995 | int length; |
---|
| 996 | |
---|
| 997 | if (objc == 2) { |
---|
| 998 | if (iPtr->packageUnknown != NULL) { |
---|
| 999 | Tcl_SetResult(interp, iPtr->packageUnknown, TCL_VOLATILE); |
---|
| 1000 | } |
---|
| 1001 | } else if (objc == 3) { |
---|
| 1002 | if (iPtr->packageUnknown != NULL) { |
---|
| 1003 | ckfree(iPtr->packageUnknown); |
---|
| 1004 | } |
---|
| 1005 | argv2 = Tcl_GetStringFromObj(objv[2], &length); |
---|
| 1006 | if (argv2[0] == 0) { |
---|
| 1007 | iPtr->packageUnknown = NULL; |
---|
| 1008 | } else { |
---|
| 1009 | DupBlock(iPtr->packageUnknown, argv2, (unsigned) length+1); |
---|
| 1010 | } |
---|
| 1011 | } else { |
---|
| 1012 | Tcl_WrongNumArgs(interp, 2, objv, "?command?"); |
---|
| 1013 | return TCL_ERROR; |
---|
| 1014 | } |
---|
| 1015 | break; |
---|
| 1016 | } |
---|
| 1017 | case PKG_PREFER: { |
---|
| 1018 | static const char *pkgPreferOptions[] = { |
---|
| 1019 | "latest", "stable", NULL |
---|
| 1020 | }; |
---|
| 1021 | |
---|
| 1022 | /* |
---|
| 1023 | * See tclInt.h for the enum, just before Interp. |
---|
| 1024 | */ |
---|
| 1025 | |
---|
| 1026 | if (objc > 3) { |
---|
| 1027 | Tcl_WrongNumArgs(interp, 2, objv, "?latest|stable?"); |
---|
| 1028 | return TCL_ERROR; |
---|
| 1029 | } else if (objc == 3) { |
---|
| 1030 | /* |
---|
| 1031 | * Seting the value. |
---|
| 1032 | */ |
---|
| 1033 | |
---|
| 1034 | int newPref; |
---|
| 1035 | |
---|
| 1036 | if (Tcl_GetIndexFromObj(interp, objv[2], pkgPreferOptions, |
---|
| 1037 | "preference", 0, &newPref) != TCL_OK) { |
---|
| 1038 | return TCL_ERROR; |
---|
| 1039 | } |
---|
| 1040 | |
---|
| 1041 | if (newPref < iPtr->packagePrefer) { |
---|
| 1042 | iPtr->packagePrefer = newPref; |
---|
| 1043 | } |
---|
| 1044 | } |
---|
| 1045 | |
---|
| 1046 | /* |
---|
| 1047 | * Always return current value. |
---|
| 1048 | */ |
---|
| 1049 | |
---|
| 1050 | Tcl_SetObjResult(interp, |
---|
| 1051 | Tcl_NewStringObj(pkgPreferOptions[iPtr->packagePrefer], -1)); |
---|
| 1052 | break; |
---|
| 1053 | } |
---|
| 1054 | case PKG_VCOMPARE: |
---|
| 1055 | if (objc != 4) { |
---|
| 1056 | Tcl_WrongNumArgs(interp, 2, objv, "version1 version2"); |
---|
| 1057 | return TCL_ERROR; |
---|
| 1058 | } |
---|
| 1059 | argv3 = TclGetString(objv[3]); |
---|
| 1060 | argv2 = TclGetString(objv[2]); |
---|
| 1061 | if (CheckVersionAndConvert(interp, argv2, &iva, NULL) != TCL_OK || |
---|
| 1062 | CheckVersionAndConvert(interp, argv3, &ivb, NULL) != TCL_OK) { |
---|
| 1063 | if (iva != NULL) { |
---|
| 1064 | ckfree(iva); |
---|
| 1065 | } |
---|
| 1066 | |
---|
| 1067 | /* |
---|
| 1068 | * ivb cannot be set in this branch. |
---|
| 1069 | */ |
---|
| 1070 | |
---|
| 1071 | return TCL_ERROR; |
---|
| 1072 | } |
---|
| 1073 | |
---|
| 1074 | /* |
---|
| 1075 | * Comparison is done on the internal representation. |
---|
| 1076 | */ |
---|
| 1077 | |
---|
| 1078 | Tcl_SetObjResult(interp, |
---|
| 1079 | Tcl_NewIntObj(CompareVersions(iva, ivb, NULL))); |
---|
| 1080 | ckfree(iva); |
---|
| 1081 | ckfree(ivb); |
---|
| 1082 | break; |
---|
| 1083 | case PKG_VERSIONS: |
---|
| 1084 | if (objc != 3) { |
---|
| 1085 | Tcl_WrongNumArgs(interp, 2, objv, "package"); |
---|
| 1086 | return TCL_ERROR; |
---|
| 1087 | } |
---|
| 1088 | argv2 = TclGetString(objv[2]); |
---|
| 1089 | hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2); |
---|
| 1090 | if (hPtr != NULL) { |
---|
| 1091 | pkgPtr = Tcl_GetHashValue(hPtr); |
---|
| 1092 | for (availPtr = pkgPtr->availPtr; availPtr != NULL; |
---|
| 1093 | availPtr = availPtr->nextPtr) { |
---|
| 1094 | Tcl_AppendElement(interp, availPtr->version); |
---|
| 1095 | } |
---|
| 1096 | } |
---|
| 1097 | break; |
---|
| 1098 | case PKG_VSATISFIES: { |
---|
| 1099 | char *argv2i = NULL; |
---|
| 1100 | |
---|
| 1101 | if (objc < 4) { |
---|
| 1102 | Tcl_WrongNumArgs(interp, 2, objv, |
---|
| 1103 | "version requirement requirement..."); |
---|
| 1104 | return TCL_ERROR; |
---|
| 1105 | } |
---|
| 1106 | |
---|
| 1107 | argv2 = TclGetString(objv[2]); |
---|
| 1108 | if (CheckVersionAndConvert(interp, argv2, &argv2i, NULL) != TCL_OK) { |
---|
| 1109 | return TCL_ERROR; |
---|
| 1110 | } else if (CheckAllRequirements(interp, objc-3, objv+3) != TCL_OK) { |
---|
| 1111 | ckfree(argv2i); |
---|
| 1112 | return TCL_ERROR; |
---|
| 1113 | } |
---|
| 1114 | |
---|
| 1115 | satisfies = SomeRequirementSatisfied(argv2i, objc-3, objv+3); |
---|
| 1116 | ckfree(argv2i); |
---|
| 1117 | |
---|
| 1118 | Tcl_SetObjResult(interp, Tcl_NewBooleanObj(satisfies)); |
---|
| 1119 | break; |
---|
| 1120 | } |
---|
| 1121 | default: |
---|
| 1122 | Tcl_Panic("Tcl_PackageObjCmd: bad option index to pkgOptions"); |
---|
| 1123 | } |
---|
| 1124 | return TCL_OK; |
---|
| 1125 | } |
---|
| 1126 | |
---|
| 1127 | /* |
---|
| 1128 | *---------------------------------------------------------------------- |
---|
| 1129 | * |
---|
| 1130 | * FindPackage -- |
---|
| 1131 | * |
---|
| 1132 | * This function finds the Package record for a particular package in a |
---|
| 1133 | * particular interpreter, creating a record if one doesn't already |
---|
| 1134 | * exist. |
---|
| 1135 | * |
---|
| 1136 | * Results: |
---|
| 1137 | * The return value is a pointer to the Package record for the package. |
---|
| 1138 | * |
---|
| 1139 | * Side effects: |
---|
| 1140 | * A new Package record may be created. |
---|
| 1141 | * |
---|
| 1142 | *---------------------------------------------------------------------- |
---|
| 1143 | */ |
---|
| 1144 | |
---|
| 1145 | static Package * |
---|
| 1146 | FindPackage( |
---|
| 1147 | Tcl_Interp *interp, /* Interpreter to use for package lookup. */ |
---|
| 1148 | const char *name) /* Name of package to fine. */ |
---|
| 1149 | { |
---|
| 1150 | Interp *iPtr = (Interp *) interp; |
---|
| 1151 | Tcl_HashEntry *hPtr; |
---|
| 1152 | int isNew; |
---|
| 1153 | Package *pkgPtr; |
---|
| 1154 | |
---|
| 1155 | hPtr = Tcl_CreateHashEntry(&iPtr->packageTable, name, &isNew); |
---|
| 1156 | if (isNew) { |
---|
| 1157 | pkgPtr = (Package *) ckalloc(sizeof(Package)); |
---|
| 1158 | pkgPtr->version = NULL; |
---|
| 1159 | pkgPtr->availPtr = NULL; |
---|
| 1160 | pkgPtr->clientData = NULL; |
---|
| 1161 | Tcl_SetHashValue(hPtr, pkgPtr); |
---|
| 1162 | } else { |
---|
| 1163 | pkgPtr = Tcl_GetHashValue(hPtr); |
---|
| 1164 | } |
---|
| 1165 | return pkgPtr; |
---|
| 1166 | } |
---|
| 1167 | |
---|
| 1168 | /* |
---|
| 1169 | *---------------------------------------------------------------------- |
---|
| 1170 | * |
---|
| 1171 | * TclFreePackageInfo -- |
---|
| 1172 | * |
---|
| 1173 | * This function is called during interpreter deletion to free all of the |
---|
| 1174 | * package-related information for the interpreter. |
---|
| 1175 | * |
---|
| 1176 | * Results: |
---|
| 1177 | * None. |
---|
| 1178 | * |
---|
| 1179 | * Side effects: |
---|
| 1180 | * Memory is freed. |
---|
| 1181 | * |
---|
| 1182 | *---------------------------------------------------------------------- |
---|
| 1183 | */ |
---|
| 1184 | |
---|
| 1185 | void |
---|
| 1186 | TclFreePackageInfo( |
---|
| 1187 | Interp *iPtr) /* Interpereter that is being deleted. */ |
---|
| 1188 | { |
---|
| 1189 | Package *pkgPtr; |
---|
| 1190 | Tcl_HashSearch search; |
---|
| 1191 | Tcl_HashEntry *hPtr; |
---|
| 1192 | PkgAvail *availPtr; |
---|
| 1193 | |
---|
| 1194 | for (hPtr = Tcl_FirstHashEntry(&iPtr->packageTable, &search); |
---|
| 1195 | hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { |
---|
| 1196 | pkgPtr = Tcl_GetHashValue(hPtr); |
---|
| 1197 | if (pkgPtr->version != NULL) { |
---|
| 1198 | ckfree(pkgPtr->version); |
---|
| 1199 | } |
---|
| 1200 | while (pkgPtr->availPtr != NULL) { |
---|
| 1201 | availPtr = pkgPtr->availPtr; |
---|
| 1202 | pkgPtr->availPtr = availPtr->nextPtr; |
---|
| 1203 | Tcl_EventuallyFree((ClientData)availPtr->version, TCL_DYNAMIC); |
---|
| 1204 | Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC); |
---|
| 1205 | ckfree((char *) availPtr); |
---|
| 1206 | } |
---|
| 1207 | ckfree((char *) pkgPtr); |
---|
| 1208 | } |
---|
| 1209 | Tcl_DeleteHashTable(&iPtr->packageTable); |
---|
| 1210 | if (iPtr->packageUnknown != NULL) { |
---|
| 1211 | ckfree(iPtr->packageUnknown); |
---|
| 1212 | } |
---|
| 1213 | } |
---|
| 1214 | |
---|
| 1215 | /* |
---|
| 1216 | *---------------------------------------------------------------------- |
---|
| 1217 | * |
---|
| 1218 | * CheckVersionAndConvert -- |
---|
| 1219 | * |
---|
| 1220 | * This function checks to see whether a version number has valid syntax. |
---|
| 1221 | * It also generates a semi-internal representation (string rep of a list |
---|
| 1222 | * of numbers). |
---|
| 1223 | * |
---|
| 1224 | * Results: |
---|
| 1225 | * If string is a properly formed version number the TCL_OK is returned. |
---|
| 1226 | * Otherwise TCL_ERROR is returned and an error message is left in the |
---|
| 1227 | * interp's result. |
---|
| 1228 | * |
---|
| 1229 | * Side effects: |
---|
| 1230 | * None. |
---|
| 1231 | * |
---|
| 1232 | *---------------------------------------------------------------------- |
---|
| 1233 | */ |
---|
| 1234 | |
---|
| 1235 | static int |
---|
| 1236 | CheckVersionAndConvert( |
---|
| 1237 | Tcl_Interp *interp, /* Used for error reporting. */ |
---|
| 1238 | const char *string, /* Supposedly a version number, which is |
---|
| 1239 | * groups of decimal digits separated by |
---|
| 1240 | * dots. */ |
---|
| 1241 | char **internal, /* Internal normalized representation */ |
---|
| 1242 | int *stable) /* Flag: Version is (un)stable. */ |
---|
| 1243 | { |
---|
| 1244 | const char *p = string; |
---|
| 1245 | char prevChar; |
---|
| 1246 | int hasunstable = 0; |
---|
| 1247 | /* |
---|
| 1248 | * 4* assuming that each char is a separator (a,b become ' -x '). |
---|
| 1249 | * 4+ to have spce for an additional -2 at the end |
---|
| 1250 | */ |
---|
| 1251 | char *ibuf = ckalloc(4 + 4*strlen(string)); |
---|
| 1252 | char *ip = ibuf; |
---|
| 1253 | |
---|
| 1254 | /* |
---|
| 1255 | * Basic rules |
---|
| 1256 | * (1) First character has to be a digit. |
---|
| 1257 | * (2) All other characters have to be a digit or '.' |
---|
| 1258 | * (3) Two '.'s may not follow each other. |
---|
| 1259 | * |
---|
| 1260 | * TIP 268, Modified rules |
---|
| 1261 | * (1) s.a. |
---|
| 1262 | * (2) All other characters have to be a digit, 'a', 'b', or '.' |
---|
| 1263 | * (3) s.a. |
---|
| 1264 | * (4) Only one of 'a' or 'b' may occur. |
---|
| 1265 | * (5) Neither 'a', nor 'b' may occur before or after a '.' |
---|
| 1266 | */ |
---|
| 1267 | |
---|
| 1268 | if (!isdigit(UCHAR(*p))) { /* INTL: digit */ |
---|
| 1269 | goto error; |
---|
| 1270 | } |
---|
| 1271 | |
---|
| 1272 | *ip++ = *p; |
---|
| 1273 | |
---|
| 1274 | for (prevChar = *p, p++; *p != 0; p++) { |
---|
| 1275 | if (!isdigit(UCHAR(*p)) && /* INTL: digit */ |
---|
| 1276 | ((*p!='.' && *p!='a' && *p!='b') || |
---|
| 1277 | ((hasunstable && (*p=='a' || *p=='b')) || |
---|
| 1278 | ((prevChar=='a' || prevChar=='b' || prevChar=='.') |
---|
| 1279 | && (*p=='.')) || |
---|
| 1280 | ((*p=='a' || *p=='b' || *p=='.') && prevChar=='.')))) { |
---|
| 1281 | goto error; |
---|
| 1282 | } |
---|
| 1283 | |
---|
| 1284 | if (*p == 'a' || *p == 'b') { |
---|
| 1285 | hasunstable = 1; |
---|
| 1286 | } |
---|
| 1287 | |
---|
| 1288 | /* |
---|
| 1289 | * Translation to the internal rep. Regular version chars are copied |
---|
| 1290 | * as is. The separators are translated to numerics. The new separator |
---|
| 1291 | * for all parts is space. |
---|
| 1292 | */ |
---|
| 1293 | |
---|
| 1294 | if (*p == '.') { |
---|
| 1295 | *ip++ = ' '; |
---|
| 1296 | *ip++ = '0'; |
---|
| 1297 | *ip++ = ' '; |
---|
| 1298 | } else if (*p == 'a') { |
---|
| 1299 | *ip++ = ' '; |
---|
| 1300 | *ip++ = '-'; |
---|
| 1301 | *ip++ = '2'; |
---|
| 1302 | *ip++ = ' '; |
---|
| 1303 | } else if (*p == 'b') { |
---|
| 1304 | *ip++ = ' '; |
---|
| 1305 | *ip++ = '-'; |
---|
| 1306 | *ip++ = '1'; |
---|
| 1307 | *ip++ = ' '; |
---|
| 1308 | } else { |
---|
| 1309 | *ip++ = *p; |
---|
| 1310 | } |
---|
| 1311 | |
---|
| 1312 | prevChar = *p; |
---|
| 1313 | } |
---|
| 1314 | if (prevChar!='.' && prevChar!='a' && prevChar!='b') { |
---|
| 1315 | *ip = '\0'; |
---|
| 1316 | if (internal != NULL) { |
---|
| 1317 | *internal = ibuf; |
---|
| 1318 | } else { |
---|
| 1319 | ckfree(ibuf); |
---|
| 1320 | } |
---|
| 1321 | if (stable != NULL) { |
---|
| 1322 | *stable = !hasunstable; |
---|
| 1323 | } |
---|
| 1324 | return TCL_OK; |
---|
| 1325 | } |
---|
| 1326 | |
---|
| 1327 | error: |
---|
| 1328 | ckfree(ibuf); |
---|
| 1329 | Tcl_AppendResult(interp, "expected version number but got \"", string, |
---|
| 1330 | "\"", NULL); |
---|
| 1331 | return TCL_ERROR; |
---|
| 1332 | } |
---|
| 1333 | |
---|
| 1334 | /* |
---|
| 1335 | *---------------------------------------------------------------------- |
---|
| 1336 | * |
---|
| 1337 | * CompareVersions -- |
---|
| 1338 | * |
---|
| 1339 | * This function compares two version numbers (in internal rep). |
---|
| 1340 | * |
---|
| 1341 | * Results: |
---|
| 1342 | * The return value is -1 if v1 is less than v2, 0 if the two version |
---|
| 1343 | * numbers are the same, and 1 if v1 is greater than v2. If *satPtr is |
---|
| 1344 | * non-NULL, the word it points to is filled in with 1 if v2 >= v1 and |
---|
| 1345 | * both numbers have the same major number or 0 otherwise. |
---|
| 1346 | * |
---|
| 1347 | * Side effects: |
---|
| 1348 | * None. |
---|
| 1349 | * |
---|
| 1350 | *---------------------------------------------------------------------- |
---|
| 1351 | */ |
---|
| 1352 | |
---|
| 1353 | static int |
---|
| 1354 | CompareVersions( |
---|
| 1355 | char *v1, char *v2, /* Versions strings, of form 2.1.3 (any number |
---|
| 1356 | * of version numbers). */ |
---|
| 1357 | int *isMajorPtr) /* If non-null, the word pointed to is filled |
---|
| 1358 | * in with a 0/1 value. 1 means that the |
---|
| 1359 | * difference occured in the first element. */ |
---|
| 1360 | { |
---|
| 1361 | int thisIsMajor, res, flip; |
---|
| 1362 | char *s1, *e1, *s2, *e2, o1, o2; |
---|
| 1363 | |
---|
| 1364 | /* |
---|
| 1365 | * Each iteration of the following loop processes one number from each |
---|
| 1366 | * string, terminated by a " " (space). If those numbers don't match then |
---|
| 1367 | * the comparison is over; otherwise, we loop back for the next number. |
---|
| 1368 | * |
---|
| 1369 | * TIP 268. |
---|
| 1370 | * This is identical the function 'ComparePkgVersion', but using the new |
---|
| 1371 | * space separator as used by the internal rep of version numbers. The |
---|
| 1372 | * special separators 'a' and 'b' have already been dealt with in |
---|
| 1373 | * 'CheckVersionAndConvert', they were translated into numbers as well. |
---|
| 1374 | * This keeps the comparison sane. Otherwise we would have to compare |
---|
| 1375 | * numerics, the separators, and also deal with the special case of |
---|
| 1376 | * end-of-string compared to separators. The semi-list rep we get here is |
---|
| 1377 | * much easier to handle, as it is still regular. |
---|
| 1378 | * |
---|
| 1379 | * Rewritten to not compute a numeric value for the extracted version |
---|
| 1380 | * number, but do string comparison. Skip any leading zeros for that to |
---|
| 1381 | * work. This change breaks through the 32bit-limit on version numbers. |
---|
| 1382 | */ |
---|
| 1383 | |
---|
| 1384 | thisIsMajor = 1; |
---|
| 1385 | s1 = v1; |
---|
| 1386 | s2 = v2; |
---|
| 1387 | |
---|
| 1388 | while (1) { |
---|
| 1389 | /* |
---|
| 1390 | * Parse one decimal number from the front of each string. Skip |
---|
| 1391 | * leading zeros. Terminate found number for upcoming string-wise |
---|
| 1392 | * comparison, if needed. |
---|
| 1393 | */ |
---|
| 1394 | |
---|
| 1395 | while ((*s1 != 0) && (*s1 == '0')) { |
---|
| 1396 | s1++; |
---|
| 1397 | } |
---|
| 1398 | while ((*s2 != 0) && (*s2 == '0')) { |
---|
| 1399 | s2++; |
---|
| 1400 | } |
---|
| 1401 | |
---|
| 1402 | /* |
---|
| 1403 | * s1, s2 now point to the beginnings of the numbers to compare. Test |
---|
| 1404 | * for their signs first, as shortcut to the result (different signs), |
---|
| 1405 | * or determines if result has to be flipped (both negative). If there |
---|
| 1406 | * is no shortcut we have to insert terminators later to limit the |
---|
| 1407 | * strcmp. |
---|
| 1408 | */ |
---|
| 1409 | |
---|
| 1410 | if ((*s1 == '-') && (*s2 != '-')) { |
---|
| 1411 | /* s1 < 0, s2 >= 0 => s1 < s2 */ |
---|
| 1412 | res = -1; |
---|
| 1413 | break; |
---|
| 1414 | } |
---|
| 1415 | if ((*s1 != '-') && (*s2 == '-')) { |
---|
| 1416 | /* s1 >= 0, s2 < 0 => s1 > s2 */ |
---|
| 1417 | res = 1; |
---|
| 1418 | break; |
---|
| 1419 | } |
---|
| 1420 | |
---|
| 1421 | if ((*s1 == '-') && (*s2 == '-')) { |
---|
| 1422 | /* a < b => -a > -b, etc. */ |
---|
| 1423 | s1++; |
---|
| 1424 | s2++; |
---|
| 1425 | flip = 1; |
---|
| 1426 | } else { |
---|
| 1427 | flip = 0; |
---|
| 1428 | } |
---|
| 1429 | |
---|
| 1430 | /* |
---|
| 1431 | * The string comparison is needed, so now we determine where the |
---|
| 1432 | * numbers end. |
---|
| 1433 | */ |
---|
| 1434 | |
---|
| 1435 | e1 = s1; |
---|
| 1436 | while ((*e1 != 0) && (*e1 != ' ')) { |
---|
| 1437 | e1++; |
---|
| 1438 | } |
---|
| 1439 | e2 = s2; |
---|
| 1440 | while ((*e2 != 0) && (*e2 != ' ')) { |
---|
| 1441 | e2++; |
---|
| 1442 | } |
---|
| 1443 | |
---|
| 1444 | /* |
---|
| 1445 | * s1 .. e1 and s2 .. e2 now bracket the numbers to compare. Insert |
---|
| 1446 | * terminators, compare, and restore actual contents. First however |
---|
| 1447 | * another shortcut. Compare lengths. Shorter string is smaller |
---|
| 1448 | * number! Thus we strcmp only strings of identical length. |
---|
| 1449 | */ |
---|
| 1450 | |
---|
| 1451 | if ((e1-s1) < (e2-s2)) { |
---|
| 1452 | res = -1; |
---|
| 1453 | } else if ((e2-s2) < (e1-s1)) { |
---|
| 1454 | res = 1; |
---|
| 1455 | } else { |
---|
| 1456 | o1 = *e1; |
---|
| 1457 | *e1 = '\0'; |
---|
| 1458 | o2 = *e2; |
---|
| 1459 | *e2 = '\0'; |
---|
| 1460 | |
---|
| 1461 | res = strcmp(s1, s2); |
---|
| 1462 | res = (res < 0) ? -1 : (res ? 1 : 0); |
---|
| 1463 | |
---|
| 1464 | *e1 = o1; |
---|
| 1465 | *e2 = o2; |
---|
| 1466 | } |
---|
| 1467 | |
---|
| 1468 | /* |
---|
| 1469 | * Stop comparing segments when a difference has been found. Here we |
---|
| 1470 | * may have to flip the result to account for signs. |
---|
| 1471 | */ |
---|
| 1472 | |
---|
| 1473 | if (res != 0) { |
---|
| 1474 | if (flip) { |
---|
| 1475 | res = -res; |
---|
| 1476 | } |
---|
| 1477 | break; |
---|
| 1478 | } |
---|
| 1479 | |
---|
| 1480 | /* |
---|
| 1481 | * Go on to the next version number if the current numbers match. |
---|
| 1482 | * However stop processing if the end of both numbers has been |
---|
| 1483 | * reached. |
---|
| 1484 | */ |
---|
| 1485 | |
---|
| 1486 | s1 = e1; |
---|
| 1487 | s2 = e2; |
---|
| 1488 | |
---|
| 1489 | if (*s1 != 0) { |
---|
| 1490 | s1++; |
---|
| 1491 | } else if (*s2 == 0) { |
---|
| 1492 | /* |
---|
| 1493 | * s1, s2 both at the end => identical |
---|
| 1494 | */ |
---|
| 1495 | |
---|
| 1496 | res = 0; |
---|
| 1497 | break; |
---|
| 1498 | } |
---|
| 1499 | if (*s2 != 0) { |
---|
| 1500 | s2++; |
---|
| 1501 | } |
---|
| 1502 | thisIsMajor = 0; |
---|
| 1503 | } |
---|
| 1504 | |
---|
| 1505 | if (isMajorPtr != NULL) { |
---|
| 1506 | *isMajorPtr = thisIsMajor; |
---|
| 1507 | } |
---|
| 1508 | |
---|
| 1509 | return res; |
---|
| 1510 | } |
---|
| 1511 | |
---|
| 1512 | /* |
---|
| 1513 | *---------------------------------------------------------------------- |
---|
| 1514 | * |
---|
| 1515 | * CheckAllRequirements -- |
---|
| 1516 | * |
---|
| 1517 | * This function checks to see whether all requirements in a set have |
---|
| 1518 | * valid syntax. |
---|
| 1519 | * |
---|
| 1520 | * Results: |
---|
| 1521 | * TCL_OK is returned if all requirements are valid. Otherwise TCL_ERROR |
---|
| 1522 | * is returned and an error message is left in the interp's result. |
---|
| 1523 | * |
---|
| 1524 | * Side effects: |
---|
| 1525 | * May modify the interpreter result. |
---|
| 1526 | * |
---|
| 1527 | *---------------------------------------------------------------------- |
---|
| 1528 | */ |
---|
| 1529 | |
---|
| 1530 | static int |
---|
| 1531 | CheckAllRequirements( |
---|
| 1532 | Tcl_Interp *interp, |
---|
| 1533 | int reqc, /* Requirements to check. */ |
---|
| 1534 | Tcl_Obj *const reqv[]) |
---|
| 1535 | { |
---|
| 1536 | int i; |
---|
| 1537 | |
---|
| 1538 | for (i = 0; i < reqc; i++) { |
---|
| 1539 | if ((CheckRequirement(interp, TclGetString(reqv[i])) != TCL_OK)) { |
---|
| 1540 | return TCL_ERROR; |
---|
| 1541 | } |
---|
| 1542 | } |
---|
| 1543 | return TCL_OK; |
---|
| 1544 | } |
---|
| 1545 | |
---|
| 1546 | /* |
---|
| 1547 | *---------------------------------------------------------------------- |
---|
| 1548 | * |
---|
| 1549 | * CheckRequirement -- |
---|
| 1550 | * |
---|
| 1551 | * This function checks to see whether a requirement has valid syntax. |
---|
| 1552 | * |
---|
| 1553 | * Results: |
---|
| 1554 | * If string is a properly formed requirement then TCL_OK is returned. |
---|
| 1555 | * Otherwise TCL_ERROR is returned and an error message is left in the |
---|
| 1556 | * interp's result. |
---|
| 1557 | * |
---|
| 1558 | * Side effects: |
---|
| 1559 | * None. |
---|
| 1560 | * |
---|
| 1561 | *---------------------------------------------------------------------- |
---|
| 1562 | */ |
---|
| 1563 | |
---|
| 1564 | static int |
---|
| 1565 | CheckRequirement( |
---|
| 1566 | Tcl_Interp *interp, /* Used for error reporting. */ |
---|
| 1567 | const char *string) /* Supposedly a requirement. */ |
---|
| 1568 | { |
---|
| 1569 | /* |
---|
| 1570 | * Syntax of requirement = version |
---|
| 1571 | * = version-version |
---|
| 1572 | * = version- |
---|
| 1573 | */ |
---|
| 1574 | |
---|
| 1575 | char *dash = NULL, *buf; |
---|
| 1576 | |
---|
| 1577 | dash = strchr(string, '-'); |
---|
| 1578 | if (dash == NULL) { |
---|
| 1579 | /* |
---|
| 1580 | * No dash found, has to be a simple version. |
---|
| 1581 | */ |
---|
| 1582 | |
---|
| 1583 | return CheckVersionAndConvert(interp, string, NULL, NULL); |
---|
| 1584 | } |
---|
| 1585 | |
---|
| 1586 | if (strchr(dash+1, '-') != NULL) { |
---|
| 1587 | /* |
---|
| 1588 | * More dashes found after the first. This is wrong. |
---|
| 1589 | */ |
---|
| 1590 | |
---|
| 1591 | Tcl_AppendResult(interp, "expected versionMin-versionMax but got \"", |
---|
| 1592 | string, "\"", NULL); |
---|
| 1593 | return TCL_ERROR; |
---|
| 1594 | } |
---|
| 1595 | |
---|
| 1596 | /* |
---|
| 1597 | * Exactly one dash is present. Copy the string, split at the location of |
---|
| 1598 | * dash and check that both parts are versions. Note that the max part can |
---|
| 1599 | * be empty. Also note that the string allocated with strdup() must be |
---|
| 1600 | * freed with free() and not ckfree(). |
---|
| 1601 | */ |
---|
| 1602 | |
---|
| 1603 | DupString(buf, string); |
---|
| 1604 | dash = buf + (dash - string); |
---|
| 1605 | *dash = '\0'; /* buf now <=> min part */ |
---|
| 1606 | dash++; /* dash now <=> max part */ |
---|
| 1607 | |
---|
| 1608 | if ((CheckVersionAndConvert(interp, buf, NULL, NULL) != TCL_OK) || |
---|
| 1609 | ((*dash != '\0') && |
---|
| 1610 | (CheckVersionAndConvert(interp, dash, NULL, NULL) != TCL_OK))) { |
---|
| 1611 | ckfree(buf); |
---|
| 1612 | return TCL_ERROR; |
---|
| 1613 | } |
---|
| 1614 | |
---|
| 1615 | ckfree(buf); |
---|
| 1616 | return TCL_OK; |
---|
| 1617 | } |
---|
| 1618 | |
---|
| 1619 | /* |
---|
| 1620 | *---------------------------------------------------------------------- |
---|
| 1621 | * |
---|
| 1622 | * AddRequirementsToResult -- |
---|
| 1623 | * |
---|
| 1624 | * This function accumulates requirements in the interpreter result. |
---|
| 1625 | * |
---|
| 1626 | * Results: |
---|
| 1627 | * None. |
---|
| 1628 | * |
---|
| 1629 | * Side effects: |
---|
| 1630 | * The interpreter result is extended. |
---|
| 1631 | * |
---|
| 1632 | *---------------------------------------------------------------------- |
---|
| 1633 | */ |
---|
| 1634 | |
---|
| 1635 | static void |
---|
| 1636 | AddRequirementsToResult( |
---|
| 1637 | Tcl_Interp *interp, |
---|
| 1638 | int reqc, /* Requirements constraining the desired |
---|
| 1639 | * version. */ |
---|
| 1640 | Tcl_Obj *const reqv[]) /* 0 means to use the latest version |
---|
| 1641 | * available. */ |
---|
| 1642 | { |
---|
| 1643 | if (reqc > 0) { |
---|
| 1644 | int i; |
---|
| 1645 | |
---|
| 1646 | for (i = 0; i < reqc; i++) { |
---|
| 1647 | int length; |
---|
| 1648 | char *v = Tcl_GetStringFromObj(reqv[i], &length); |
---|
| 1649 | |
---|
| 1650 | if ((length & 0x1) && (v[length/2] == '-') |
---|
| 1651 | && (strncmp(v, v+((length+1)/2), length/2) == 0)) { |
---|
| 1652 | Tcl_AppendResult(interp, " exactly ", v+((length+1)/2), NULL); |
---|
| 1653 | } else { |
---|
| 1654 | Tcl_AppendResult(interp, " ", v, NULL); |
---|
| 1655 | } |
---|
| 1656 | } |
---|
| 1657 | } |
---|
| 1658 | } |
---|
| 1659 | |
---|
| 1660 | /* |
---|
| 1661 | *---------------------------------------------------------------------- |
---|
| 1662 | * |
---|
| 1663 | * AddRequirementsToDString -- |
---|
| 1664 | * |
---|
| 1665 | * This function accumulates requirements in a DString. |
---|
| 1666 | * |
---|
| 1667 | * Results: |
---|
| 1668 | * None. |
---|
| 1669 | * |
---|
| 1670 | * Side effects: |
---|
| 1671 | * The DString argument is extended. |
---|
| 1672 | * |
---|
| 1673 | *---------------------------------------------------------------------- |
---|
| 1674 | */ |
---|
| 1675 | |
---|
| 1676 | static void |
---|
| 1677 | AddRequirementsToDString( |
---|
| 1678 | Tcl_DString *dsPtr, |
---|
| 1679 | int reqc, /* Requirements constraining the desired |
---|
| 1680 | * version. */ |
---|
| 1681 | Tcl_Obj *const reqv[]) /* 0 means to use the latest version |
---|
| 1682 | * available. */ |
---|
| 1683 | { |
---|
| 1684 | if (reqc > 0) { |
---|
| 1685 | int i; |
---|
| 1686 | |
---|
| 1687 | for (i = 0; i < reqc; i++) { |
---|
| 1688 | Tcl_DStringAppend(dsPtr, " ", 1); |
---|
| 1689 | Tcl_DStringAppend(dsPtr, TclGetString(reqv[i]), -1); |
---|
| 1690 | } |
---|
| 1691 | } else { |
---|
| 1692 | Tcl_DStringAppend(dsPtr, " 0-", -1); |
---|
| 1693 | } |
---|
| 1694 | } |
---|
| 1695 | |
---|
| 1696 | /* |
---|
| 1697 | *---------------------------------------------------------------------- |
---|
| 1698 | * |
---|
| 1699 | * SomeRequirementSatisfied -- |
---|
| 1700 | * |
---|
| 1701 | * This function checks to see whether a version satisfies at least one |
---|
| 1702 | * of a set of requirements. |
---|
| 1703 | * |
---|
| 1704 | * Results: |
---|
| 1705 | * If the requirements are satisfied 1 is returned. Otherwise 0 is |
---|
| 1706 | * returned. The function assumes that all pieces have valid syntax. And |
---|
| 1707 | * is allowed to make that assumption. |
---|
| 1708 | * |
---|
| 1709 | * Side effects: |
---|
| 1710 | * None. |
---|
| 1711 | * |
---|
| 1712 | *---------------------------------------------------------------------- |
---|
| 1713 | */ |
---|
| 1714 | |
---|
| 1715 | static int |
---|
| 1716 | SomeRequirementSatisfied( |
---|
| 1717 | char *availVersionI, /* Candidate version to check against the |
---|
| 1718 | * requirements. */ |
---|
| 1719 | int reqc, /* Requirements constraining the desired |
---|
| 1720 | * version. */ |
---|
| 1721 | Tcl_Obj *const reqv[]) /* 0 means to use the latest version |
---|
| 1722 | * available. */ |
---|
| 1723 | { |
---|
| 1724 | int i; |
---|
| 1725 | |
---|
| 1726 | for (i = 0; i < reqc; i++) { |
---|
| 1727 | if (RequirementSatisfied(availVersionI, TclGetString(reqv[i]))) { |
---|
| 1728 | return 1; |
---|
| 1729 | } |
---|
| 1730 | } |
---|
| 1731 | return 0; |
---|
| 1732 | } |
---|
| 1733 | |
---|
| 1734 | /* |
---|
| 1735 | *---------------------------------------------------------------------- |
---|
| 1736 | * |
---|
| 1737 | * RequirementSatisfied -- |
---|
| 1738 | * |
---|
| 1739 | * This function checks to see whether a version satisfies a requirement. |
---|
| 1740 | * |
---|
| 1741 | * Results: |
---|
| 1742 | * If the requirement is satisfied 1 is returned. Otherwise 0 is |
---|
| 1743 | * returned. The function assumes that all pieces have valid syntax, and |
---|
| 1744 | * is allowed to make that assumption. |
---|
| 1745 | * |
---|
| 1746 | * Side effects: |
---|
| 1747 | * None. |
---|
| 1748 | * |
---|
| 1749 | *---------------------------------------------------------------------- |
---|
| 1750 | */ |
---|
| 1751 | |
---|
| 1752 | static int |
---|
| 1753 | RequirementSatisfied( |
---|
| 1754 | char *havei, /* Version string, of candidate package we |
---|
| 1755 | * have. */ |
---|
| 1756 | const char *req) /* Requirement string the candidate has to |
---|
| 1757 | * satisfy. */ |
---|
| 1758 | { |
---|
| 1759 | /* |
---|
| 1760 | * The have candidate is already in internal rep. |
---|
| 1761 | */ |
---|
| 1762 | |
---|
| 1763 | int satisfied, res; |
---|
| 1764 | char *dash = NULL, *buf, *min, *max; |
---|
| 1765 | |
---|
| 1766 | dash = strchr(req, '-'); |
---|
| 1767 | if (dash == NULL) { |
---|
| 1768 | /* |
---|
| 1769 | * No dash found, is a simple version, fallback to regular check. The |
---|
| 1770 | * 'CheckVersionAndConvert' cannot fail. We pad the requirement with |
---|
| 1771 | * 'a0', i.e '-2' before doing the comparison to properly accept |
---|
| 1772 | * unstables as well. |
---|
| 1773 | */ |
---|
| 1774 | |
---|
| 1775 | char *reqi = NULL; |
---|
| 1776 | int thisIsMajor; |
---|
| 1777 | |
---|
| 1778 | CheckVersionAndConvert(NULL, req, &reqi, NULL); |
---|
| 1779 | strcat(reqi, " -2"); |
---|
| 1780 | res = CompareVersions(havei, reqi, &thisIsMajor); |
---|
| 1781 | satisfied = (res == 0) || ((res == 1) && !thisIsMajor); |
---|
| 1782 | ckfree(reqi); |
---|
| 1783 | return satisfied; |
---|
| 1784 | } |
---|
| 1785 | |
---|
| 1786 | /* |
---|
| 1787 | * Exactly one dash is present (Assumption of valid syntax). Copy the req, |
---|
| 1788 | * split at the location of dash and check that both parts are versions. |
---|
| 1789 | * Note that the max part can be empty. |
---|
| 1790 | */ |
---|
| 1791 | |
---|
| 1792 | DupString(buf, req); |
---|
| 1793 | dash = buf + (dash - req); |
---|
| 1794 | *dash = '\0'; /* buf now <=> min part */ |
---|
| 1795 | dash++; /* dash now <=> max part */ |
---|
| 1796 | |
---|
| 1797 | if (*dash == '\0') { |
---|
| 1798 | /* |
---|
| 1799 | * We have a min, but no max. For the comparison we generate the |
---|
| 1800 | * internal rep, padded with 'a0' i.e. '-2'. |
---|
| 1801 | */ |
---|
| 1802 | |
---|
| 1803 | CheckVersionAndConvert(NULL, buf, &min, NULL); |
---|
| 1804 | strcat(min, " -2"); |
---|
| 1805 | satisfied = (CompareVersions(havei, min, NULL) >= 0); |
---|
| 1806 | ckfree(min); |
---|
| 1807 | ckfree(buf); |
---|
| 1808 | return satisfied; |
---|
| 1809 | } |
---|
| 1810 | |
---|
| 1811 | /* |
---|
| 1812 | * We have both min and max, and generate their internal reps. When |
---|
| 1813 | * identical we compare as is, otherwise we pad with 'a0' to ove the range |
---|
| 1814 | * a bit. |
---|
| 1815 | */ |
---|
| 1816 | |
---|
| 1817 | CheckVersionAndConvert(NULL, buf, &min, NULL); |
---|
| 1818 | CheckVersionAndConvert(NULL, dash, &max, NULL); |
---|
| 1819 | |
---|
| 1820 | if (CompareVersions(min, max, NULL) == 0) { |
---|
| 1821 | satisfied = (CompareVersions(min, havei, NULL) == 0); |
---|
| 1822 | } else { |
---|
| 1823 | strcat(min, " -2"); |
---|
| 1824 | strcat(max, " -2"); |
---|
| 1825 | satisfied = ((CompareVersions(min, havei, NULL) <= 0) && |
---|
| 1826 | (CompareVersions(havei, max, NULL) < 0)); |
---|
| 1827 | } |
---|
| 1828 | |
---|
| 1829 | ckfree(min); |
---|
| 1830 | ckfree(max); |
---|
| 1831 | ckfree(buf); |
---|
| 1832 | return satisfied; |
---|
| 1833 | } |
---|
| 1834 | |
---|
| 1835 | /* |
---|
| 1836 | *---------------------------------------------------------------------- |
---|
| 1837 | * |
---|
| 1838 | * Tcl_PkgInitStubsCheck -- |
---|
| 1839 | * |
---|
| 1840 | * This is a replacement routine for Tcl_InitStubs() that is called |
---|
| 1841 | * from code where -DUSE_TCL_STUBS has not been enabled. |
---|
| 1842 | * |
---|
| 1843 | * Results: |
---|
| 1844 | * Returns the version of a conforming stubs table, or NULL, if |
---|
| 1845 | * the table version doesn't satisfy the requested requirements, |
---|
| 1846 | * according to historical practice. |
---|
| 1847 | * |
---|
| 1848 | * Side effects: |
---|
| 1849 | * None. |
---|
| 1850 | * |
---|
| 1851 | *---------------------------------------------------------------------- |
---|
| 1852 | */ |
---|
| 1853 | |
---|
| 1854 | const char * |
---|
| 1855 | Tcl_PkgInitStubsCheck( |
---|
| 1856 | Tcl_Interp *interp, |
---|
| 1857 | const char * version, |
---|
| 1858 | int exact) |
---|
| 1859 | { |
---|
| 1860 | const char *actualVersion = Tcl_PkgPresent(interp, "Tcl", version, 0); |
---|
| 1861 | |
---|
| 1862 | if (exact && actualVersion) { |
---|
| 1863 | const char *p = version; |
---|
| 1864 | int count = 0; |
---|
| 1865 | |
---|
| 1866 | while (*p) { |
---|
| 1867 | count += !isdigit(*p++); |
---|
| 1868 | } |
---|
| 1869 | if (count == 1) { |
---|
| 1870 | if (0 != strncmp(version, actualVersion, strlen(version))) { |
---|
| 1871 | return NULL; |
---|
| 1872 | } |
---|
| 1873 | } else { |
---|
| 1874 | return Tcl_PkgPresent(interp, "Tcl", version, 1); |
---|
| 1875 | } |
---|
| 1876 | } |
---|
| 1877 | return actualVersion; |
---|
| 1878 | } |
---|
| 1879 | /* |
---|
| 1880 | * Local Variables: |
---|
| 1881 | * mode: c |
---|
| 1882 | * c-basic-offset: 4 |
---|
| 1883 | * fill-column: 78 |
---|
| 1884 | * End: |
---|
| 1885 | */ |
---|