cde/programs/dtdocbook/tcl/tclPkg.c

   1 /*
   2  * CDE - Common Desktop Environment
   3  *
   4  * Copyright (c) 1993-2012, The Open Group. All rights reserved.
   5  *
   6  * These libraries and programs are free software; you can
   7  * redistribute them and/or modify them under the terms of the GNU
   8  * Lesser General Public License as published by the Free Software
   9  * Foundation; either version 2 of the License, or (at your option)
  10  * any later version.
  11  *
  12  * These libraries and programs are distributed in the hope that
  13  * they will be useful, but WITHOUT ANY WARRANTY; without even the
  14  * implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
  15  * PURPOSE. See the GNU Lesser General Public License for more
  16  * details.
  17  *
  18  * You should have received a copy of the GNU Lesser General Public
  19  * License along with these libraries and programs; if not, write
  20  * to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
  21  * Floor, Boston, MA 02110-1301 USA
  22  */
  23 /* $XConsortium: tclPkg.c /main/2 1996/08/08 14:45:54 cde-hp $ */
  24 /*
  25  * tclPkg.c --
  26  *
  27  *      This file implements package and version control for Tcl via
  28  *      the "package" command and a few C APIs.
  29  *
  30  * Copyright (c) 1996 Sun Microsystems, Inc.
  31  *
  32  * See the file "license.terms" for information on usage and redistribution
  33  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  34  *
  35  * SCCS: @(#) tclPkg.c 1.6 96/02/15 11:43:16
  36  */
  37
  38 #include "tclInt.h"
  39
  40 /*
  41  * Each invocation of the "package ifneeded" command creates a structure
  42  * of the following type, which is used to load the package into the
  43  * interpreter if it is requested with a "package require" command.
  44  */
  45
  46 typedef struct PkgAvail {
  47     char *version;              /* Version string; malloc'ed. */
  48     char *script;               /* Script to invoke to provide this version
  49                                  * of the package.  Malloc'ed and protected
  50                                  * by Tcl_Preserve and Tcl_Release. */
  51     struct PkgAvail *nextPtr;   /* Next in list of available versions of
  52                                  * the same package. */
  53 } PkgAvail;
  54
  55 /*
  56  * For each package that is known in any way to an interpreter, there
  57  * is one record of the following type.  These records are stored in
  58  * the "packageTable" hash table in the interpreter, keyed by
  59  * package name such as "Tk" (no version number).
  60  */
  61
  62 typedef struct Package {
  63     char *version;              /* Version that has been supplied in this
  64                                  * interpreter via "package provide"
  65                                  * (malloc'ed).  NULL means the package doesn't
  66                                  * exist in this interpreter yet. */
  67     PkgAvail *availPtr;         /* First in list of all available versions
  68                                  * of this package. */
  69 } Package;
  70
  71 /*
  72  * Prototypes for procedures defined in this file:
  73  */
  74
  75 static int              CheckVersion _ANSI_ARGS_((Tcl_Interp *interp,
  76                             char *string));
  77 static int              ComparePkgVersions _ANSI_ARGS_((char *v1, char *v2,
  78                             int *satPtr));
  79 static Package *        FindPackage _ANSI_ARGS_((Tcl_Interp *interp,
  80                             char *name));
  81 \f
  82 /*
  83  *----------------------------------------------------------------------
  84  *
  85  * Tcl_PkgProvide --
  86  *
  87  *      This procedure is invoked to declare that a particular version
  88  *      of a particular package is now present in an interpreter.  There
  89  *      must not be any other version of this package already
  90  *      provided in the interpreter.
  91  *
  92  * Results:
  93  *      Normally returns TCL_OK;  if there is already another version
  94  *      of the package loaded then TCL_ERROR is returned and an error
  95  *      message is left in interp->result.
  96  *
  97  * Side effects:
  98  *      The interpreter remembers that this package is available,
  99  *      so that no other version of the package may be provided for
 100  *      the interpreter.
 101  *
 102  *----------------------------------------------------------------------
 103  */
 104
 105 int
 106 Tcl_PkgProvide(
 107     Tcl_Interp *interp,         /* Interpreter in which package is now
 108                                  * available. */
 109     char *name,                 /* Name of package. */
 110     char *version               /* Version string for package. */
 111 )
 112 {
 113     Package *pkgPtr;
 114
 115     pkgPtr = FindPackage(interp, name);
 116     if (pkgPtr->version == NULL) {
 117         pkgPtr->version = ckalloc((unsigned) (strlen(version) + 1));
 118         strcpy(pkgPtr->version, version);
 119         return TCL_OK;
 120     }
 121     if (ComparePkgVersions(pkgPtr->version, version, (int *) NULL) == 0) {
 122         return TCL_OK;
 123     }
 124     Tcl_AppendResult(interp, "conflicting versions provided for package \"",
 125             name, "\": ", pkgPtr->version, ", then ", version, (char *) NULL);
 126     return TCL_ERROR;
 127 }
 128 \f
 129 /*
 130  *----------------------------------------------------------------------
 131  *
 132  * Tcl_PkgRequire --
 133  *
 134  *      This procedure is called by code that depends on a particular
 135  *      version of a particular package.  If the package is not already
 136  *      provided in the interpreter, this procedure invokes a Tcl script
 137  *      to provide it.  If the package is already provided, this
 138  *      procedure makes sure that the caller's needs don't conflict with
 139  *      the version that is present.
 140  *
 141  * Results:
 142  *      If successful, returns the version string for the currently
 143  *      provided version of the package, which may be different from
 144  *      the "version" argument.  If the caller's requirements
 145  *      cannot be met (e.g. the version requested conflicts with
 146  *      a currently provided version, or the required version cannot
 147  *      be found, or the script to provide the required version
 148  *      generates an error), NULL is returned and an error
 149  *      message is left in interp->result.
 150  *
 151  * Side effects:
 152  *      The script from some previous "package ifneeded" command may
 153  *      be invoked to provide the package.
 154  *
 155  *----------------------------------------------------------------------
 156  */
 157
 158 char *
 159 Tcl_PkgRequire(
 160     Tcl_Interp *interp,         /* Interpreter in which package is now
 161                                  * available. */
 162     char *name,                 /* Name of desired package. */
 163     char *version,              /* Version string for desired version;
 164                                  * NULL means use the latest version
 165                                  * available. */
 166     int exact                   /* Non-zero means that only the particular
 167                                  * version given is acceptable. Zero means
 168                                  * use the latest compatible version. */
 169 )
 170 {
 171     Package *pkgPtr;
 172     PkgAvail *availPtr, *bestPtr;
 173     char *script;
 174     int code, satisfies, result, pass;
 175     Tcl_DString command;
 176
 177     /*
 178      * It can take up to three passes to find the package:  one pass to
 179      * run the "package unknown" script, one to run the "package ifneeded"
 180      * script for a specific version, and a final pass to lookup the
 181      * package loaded by the "package ifneeded" script.
 182      */
 183
 184     for (pass = 1; ; pass++) {
 185         pkgPtr = FindPackage(interp, name);
 186         if (pkgPtr->version != NULL) {
 187             break;
 188         }
 189
 190         /*
 191          * The package isn't yet present.  Search the list of available
 192          * versions and invoke the script for the best available version.
 193          */
 194
 195         bestPtr = NULL;
 196         for (availPtr = pkgPtr->availPtr; availPtr != NULL;
 197                 availPtr = availPtr->nextPtr) {
 198             if ((bestPtr != NULL) && (ComparePkgVersions(availPtr->version,
 199                     bestPtr->version, (int *) NULL) <= 0)) {
 200                 continue;
 201             }
 202             if (version != NULL) {
 203                 result = ComparePkgVersions(availPtr->version, version,
 204                         &satisfies);
 205                 if ((result != 0) && exact) {
 206                     continue;
 207                 }
 208                 if (!satisfies) {
 209                     continue;
 210                 }
 211             }
 212             bestPtr = availPtr;
 213         }
 214         if (bestPtr != NULL) {
 215             /*
 216              * We found an ifneeded script for the package.  Be careful while
 217              * executing it:  this could cause reentrancy, so (a) protect the
 218              * script itself from deletion and (b) don't assume that bestPtr
 219              * will still exist when the script completes.
 220              */
 221
 222             script = bestPtr->script;
 223             Tcl_Preserve((ClientData) script);
 224             code = Tcl_GlobalEval(interp, script);
 225             Tcl_Release((ClientData) script);
 226             if (code != TCL_OK) {
 227                 if (code == TCL_ERROR) {
 228                     Tcl_AddErrorInfo(interp,
 229                             "\n    (\"package ifneeded\" script)");
 230                 }
 231                 return NULL;
 232             }
 233             Tcl_ResetResult(interp);
 234             pkgPtr = FindPackage(interp, name);
 235             break;
 236         }
 237
 238         /*
 239          * Package not in the database.  If there is a "package unknown"
 240          * command, invoke it (but only on the first pass;  after that,
 241          * we should not get here in the first place).
 242          */
 243
 244         if (pass > 1) {
 245             break;
 246         }
 247         script = ((Interp *) interp)->packageUnknown;
 248         if (script != NULL) {
 249             Tcl_DStringInit(&command);
 250             Tcl_DStringAppend(&command, script, -1);
 251             Tcl_DStringAppendElement(&command, name);
 252             Tcl_DStringAppend(&command, " ", 1);
 253             Tcl_DStringAppend(&command, (version != NULL) ? version : "{}",
 254                     -1);
 255             if (exact) {
 256                 Tcl_DStringAppend(&command, " -exact", 7);
 257             }
 258             code = Tcl_GlobalEval(interp, Tcl_DStringValue(&command));
 259             Tcl_DStringFree(&command);
 260             if (code != TCL_OK) {
 261                 if (code == TCL_ERROR) {
 262                     Tcl_AddErrorInfo(interp,
 263                             "\n    (\"package unknown\" script)");
 264                 }
 265                 return NULL;
 266             }
 267             Tcl_ResetResult(interp);
 268         }
 269     }
 270
 271     if (pkgPtr->version == NULL) {
 272         Tcl_AppendResult(interp, "can't find package ", name,
 273                 (char *) NULL);
 274         if (version != NULL) {
 275             Tcl_AppendResult(interp, " ", version, (char *) NULL);
 276         }
 277         return NULL;
 278     }
 279
 280     /*
 281      * At this point we now that the package is present.  Make sure that the
 282      * provided version meets the current requirement.
 283      */
 284
 285     if (version == NULL) {
 286         return pkgPtr->version;
 287     }
 288     result = ComparePkgVersions(pkgPtr->version, version, &satisfies);
 289     if ((satisfies && !exact) || (result == 0)) {
 290         return pkgPtr->version;
 291     }
 292     Tcl_AppendResult(interp, "version conflict for package \"",
 293             name, "\": have ", pkgPtr->version, ", need ", version,
 294             (char *) NULL);
 295     return NULL;
 296 }
 297 \f
 298 /*
 299  *----------------------------------------------------------------------
 300  *
 301  * Tcl_PackageCmd --
 302  *
 303  *      This procedure is invoked to process the "package" Tcl command.
 304  *      See the user documentation for details on what it does.
 305  *
 306  * Results:
 307  *      A standard Tcl result.
 308  *
 309  * Side effects:
 310  *      See the user documentation.
 311  *
 312  *----------------------------------------------------------------------
 313  */
 314
 315         /* ARGSUSED */
 316 int
 317 Tcl_PackageCmd(
 318     ClientData dummy,                   /* Not used. */
 319     Tcl_Interp *interp,                 /* Current interpreter. */
 320     int argc,                           /* Number of arguments. */
 321     char **argv                         /* Argument strings. */
 322 )
 323 {
 324     Interp *iPtr = (Interp *) interp;
 325     size_t length;
 326     int c, exact, i, satisfies;
 327     PkgAvail *availPtr, *prevPtr;
 328     Package *pkgPtr;
 329     Tcl_HashEntry *hPtr;
 330     Tcl_HashSearch search;
 331     Tcl_HashTable *tablePtr;
 332     char *version;
 333
 334     if (argc < 2) {
 335         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
 336                 " option ?arg arg ...?\"", (char *) NULL);
 337         return TCL_ERROR;
 338     }
 339     c = argv[1][0];
 340     length = strlen(argv[1]);
 341     if ((c == 'f') && (strncmp(argv[1], "forget", length) == 0)) {
 342         for (i = 2; i < argc; i++) {
 343             hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv[i]);
 344             if (hPtr == NULL) {
 345                 return TCL_OK;
 346             }
 347             pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
 348             Tcl_DeleteHashEntry(hPtr);
 349             if (pkgPtr->version != NULL) {
 350                 ckfree(pkgPtr->version);
 351             }
 352             while (pkgPtr->availPtr != NULL) {
 353                 availPtr = pkgPtr->availPtr;
 354                 pkgPtr->availPtr = availPtr->nextPtr;
 355                 ckfree(availPtr->version);
 356                 Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC);
 357                 ckfree((char *) availPtr);
 358             }
 359             ckfree((char *) pkgPtr);
 360         }
 361     } else if ((c == 'i') && (strncmp(argv[1], "ifneeded", length) == 0)) {
 362         if ((argc != 4) && (argc != 5)) {
 363             Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
 364                     " ifneeded package version ?script?\"", (char *) NULL);
 365             return TCL_ERROR;
 366         }
 367         if (CheckVersion(interp, argv[3]) != TCL_OK) {
 368             return TCL_ERROR;
 369         }
 370         if (argc == 4) {
 371             hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv[2]);
 372             if (hPtr == NULL) {
 373                 return TCL_OK;
 374             }
 375             pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
 376         } else {
 377             pkgPtr = FindPackage(interp, argv[2]);
 378         }
 379         for (availPtr = pkgPtr->availPtr, prevPtr = NULL; availPtr != NULL;
 380                 prevPtr = availPtr, availPtr = availPtr->nextPtr) {
 381             if (ComparePkgVersions(availPtr->version, argv[3], (int *) NULL)
 382                     == 0) {
 383                 if (argc == 4) {
 384                     interp->result = availPtr->script;
 385                     return TCL_OK;
 386                 }
 387                 Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC);
 388                 break;
 389             }
 390         }
 391         if (argc == 4) {
 392             return TCL_OK;
 393         }
 394         if (availPtr == NULL) {
 395             availPtr = (PkgAvail *) ckalloc(sizeof(PkgAvail));
 396             availPtr->version = ckalloc((unsigned) (strlen(argv[3]) + 1));
 397             strcpy(availPtr->version, argv[3]);
 398             if (prevPtr == NULL) {
 399                 availPtr->nextPtr = pkgPtr->availPtr;
 400                 pkgPtr->availPtr = availPtr;
 401             } else {
 402                 availPtr->nextPtr = prevPtr->nextPtr;
 403                 prevPtr->nextPtr = availPtr;
 404             }
 405         }
 406         availPtr->script = ckalloc((unsigned) (strlen(argv[4]) + 1));
 407         strcpy(availPtr->script, argv[4]);
 408     } else if ((c == 'n') && (strncmp(argv[1], "names", length) == 0)) {
 409         if (argc != 2) {
 410             Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
 411                     " names\"", (char *) NULL);
 412             return TCL_ERROR;
 413         }
 414         tablePtr = &iPtr->packageTable;
 415         for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL;
 416                 hPtr = Tcl_NextHashEntry(&search)) {
 417             pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
 418             if ((pkgPtr->version != NULL) || (pkgPtr->availPtr != NULL)) {
 419                 Tcl_AppendElement(interp, Tcl_GetHashKey(tablePtr, hPtr));
 420             }
 421         }
 422     } else if ((c == 'p') && (strncmp(argv[1], "provide", length) == 0)) {
 423         if ((argc != 3) && (argc != 4)) {
 424             Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
 425                     " provide package ?version?\"", (char *) NULL);
 426             return TCL_ERROR;
 427         }
 428         if (argc == 3) {
 429             hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv[2]);
 430             if (hPtr != NULL) {
 431                 pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
 432                 if (pkgPtr->version != NULL) {
 433                     interp->result = pkgPtr->version;
 434                 }
 435             }
 436             return TCL_OK;
 437         }
 438         if (CheckVersion(interp, argv[3]) != TCL_OK) {
 439             return TCL_ERROR;
 440         }
 441         return Tcl_PkgProvide(interp, argv[2], argv[3]);
 442     } else if ((c == 'r') && (strncmp(argv[1], "require", length) == 0)) {
 443         if (argc < 3) {
 444             requireSyntax:
 445             Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
 446                     " require ?-exact? package ?version?\"", (char *) NULL);
 447             return TCL_ERROR;
 448         }
 449         if ((argv[2][0] == '-') && (strcmp(argv[2], "-exact") == 0)) {
 450             exact = 1;
 451         } else {
 452             exact = 0;
 453         }
 454         version = NULL;
 455         if (argc == (4+exact)) {
 456             version = argv[3+exact];
 457             if (CheckVersion(interp, version) != TCL_OK) {
 458                 return TCL_ERROR;
 459             }
 460         } else if ((argc != 3) || exact) {
 461             goto requireSyntax;
 462         }
 463         version = Tcl_PkgRequire(interp, argv[2+exact], version, exact);
 464         if (version == NULL) {
 465             return TCL_ERROR;
 466         }
 467         interp->result = version;
 468     } else if ((c == 'u') && (strncmp(argv[1], "unknown", length) == 0)) {
 469         if (argc == 2) {
 470             if (iPtr->packageUnknown != NULL) {
 471                 iPtr->result = iPtr->packageUnknown;
 472             }
 473         } else if (argc == 3) {
 474             if (iPtr->packageUnknown != NULL) {
 475                 ckfree(iPtr->packageUnknown);
 476             }
 477             if (argv[2][0] == 0) {
 478                 iPtr->packageUnknown = NULL;
 479             } else {
 480                 iPtr->packageUnknown = (char *) ckalloc((unsigned)
 481                         (strlen(argv[2]) + 1));
 482                 strcpy(iPtr->packageUnknown, argv[2]);
 483             }
 484         } else {
 485             Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
 486                     " unknown ?command?\"", (char *) NULL);
 487             return TCL_ERROR;
 488         }
 489     } else if ((c == 'v') && (strncmp(argv[1], "vcompare", length) == 0)
 490             && (length >= 2)) {
 491         if (argc != 4) {
 492             Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
 493                     " vcompare version1 version2\"", (char *) NULL);
 494             return TCL_ERROR;
 495         }
 496         if ((CheckVersion(interp, argv[2]) != TCL_OK)
 497                 || (CheckVersion(interp, argv[3]) != TCL_OK)) {
 498             return TCL_ERROR;
 499         }
 500         sprintf(interp->result, "%d", ComparePkgVersions(argv[2], argv[3],
 501                 (int *) NULL));
 502     } else if ((c == 'v') && (strncmp(argv[1], "versions", length) == 0)
 503             && (length >= 2)) {
 504         if (argc != 3) {
 505             Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
 506                     " versions package\"", (char *) NULL);
 507             return TCL_ERROR;
 508         }
 509         hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv[2]);
 510         if (hPtr != NULL) {
 511             pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
 512             for (availPtr = pkgPtr->availPtr; availPtr != NULL;
 513                     availPtr = availPtr->nextPtr) {
 514                 Tcl_AppendElement(interp, availPtr->version);
 515             }
 516         }
 517     } else if ((c == 'v') && (strncmp(argv[1], "vsatisfies", length) == 0)
 518             && (length >= 2)) {
 519         if (argc != 4) {
 520             Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
 521                     " vsatisfies version1 version2\"", (char *) NULL);
 522             return TCL_ERROR;
 523         }
 524         if ((CheckVersion(interp, argv[2]) != TCL_OK)
 525                 || (CheckVersion(interp, argv[3]) != TCL_OK)) {
 526             return TCL_ERROR;
 527         }
 528         ComparePkgVersions(argv[2], argv[3], &satisfies);
 529         sprintf(interp->result, "%d", satisfies);
 530     } else {
 531         Tcl_AppendResult(interp, "bad option \"", argv[1],
 532                 "\": should be forget, ifneeded, names, ",
 533                 "provide, require, unknown, vcompare, ",
 534                 "versions, or vsatisfies", (char *) NULL);
 535         return TCL_ERROR;
 536     }
 537     return TCL_OK;
 538 }
 539 \f
 540 /*
 541  *----------------------------------------------------------------------
 542  *
 543  * FindPackage --
 544  *
 545  *      This procedure finds the Package record for a particular package
 546  *      in a particular interpreter, creating a record if one doesn't
 547  *      already exist.
 548  *
 549  * Results:
 550  *      The return value is a pointer to the Package record for the
 551  *      package.
 552  *
 553  * Side effects:
 554  *      A new Package record may be created.
 555  *
 556  *----------------------------------------------------------------------
 557  */
 558
 559 static Package *
 560 FindPackage(
 561     Tcl_Interp *interp,         /* Interpreter to use for package lookup. */
 562     char *name                  /* Name of package to fine. */
 563 )
 564 {
 565     Interp *iPtr = (Interp *) interp;
 566     Tcl_HashEntry *hPtr;
 567     int new;
 568     Package *pkgPtr;
 569
 570     hPtr = Tcl_CreateHashEntry(&iPtr->packageTable, name, &new);
 571     if (new) {
 572         pkgPtr = (Package *) ckalloc(sizeof(Package));
 573         pkgPtr->version = NULL;
 574         pkgPtr->availPtr = NULL;
 575         Tcl_SetHashValue(hPtr, pkgPtr);
 576     } else {
 577         pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
 578     }
 579     return pkgPtr;
 580 }
 581 \f
 582 /*
 583  *----------------------------------------------------------------------
 584  *
 585  * TclFreePackageInfo --
 586  *
 587  *      This procedure is called during interpreter deletion to
 588  *      free all of the package-related information for the
 589  *      interpreter.
 590  *
 591  * Results:
 592  *      None.
 593  *
 594  * Side effects:
 595  *      Memory is freed.
 596  *
 597  *----------------------------------------------------------------------
 598  */
 599
 600 void
 601 TclFreePackageInfo(
 602     Interp *iPtr                /* Interpereter that is being deleted. */
 603 )
 604 {
 605     Package *pkgPtr;
 606     Tcl_HashSearch search;
 607     Tcl_HashEntry *hPtr;
 608     PkgAvail *availPtr;
 609
 610     for (hPtr = Tcl_FirstHashEntry(&iPtr->packageTable, &search);
 611             hPtr != NULL;  hPtr = Tcl_NextHashEntry(&search)) {
 612         pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
 613         if (pkgPtr->version != NULL) {
 614             ckfree(pkgPtr->version);
 615         }
 616         while (pkgPtr->availPtr != NULL) {
 617             availPtr = pkgPtr->availPtr;
 618             pkgPtr->availPtr = availPtr->nextPtr;
 619             ckfree(availPtr->version);
 620             Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC);
 621             ckfree((char *) availPtr);
 622         }
 623         ckfree((char *) pkgPtr);
 624     }
 625     Tcl_DeleteHashTable(&iPtr->packageTable);
 626     if (iPtr->packageUnknown != NULL) {
 627         ckfree(iPtr->packageUnknown);
 628     }
 629 }
 630 \f
 631 /*
 632  *----------------------------------------------------------------------
 633  *
 634  * CheckVersion --
 635  *
 636  *      This procedure checks to see whether a version number has
 637  *      valid syntax.
 638  *
 639  * Results:
 640  *      If string is a properly formed version number the TCL_OK
 641  *      is returned.  Otherwise TCL_ERROR is returned and an error
 642  *      message is left in interp->result.
 643  *
 644  * Side effects:
 645  *      None.
 646  *
 647  *----------------------------------------------------------------------
 648  */
 649
 650 static int
 651 CheckVersion(
 652     Tcl_Interp *interp,         /* Used for error reporting. */
 653     char *string                /* Supposedly a version number, which is
 654                                  * groups of decimal digits separated
 655                                  * by dots. */
 656 )
 657 {
 658     char *p = string;
 659
 660     if (!isdigit(*p)) {
 661         goto error;
 662     }
 663     for (p++; *p != 0; p++) {
 664         if (!isdigit(*p) && (*p != '.')) {
 665             goto error;
 666         }
 667     }
 668     if (p[-1] != '.') {
 669         return TCL_OK;
 670     }
 671
 672     error:
 673     Tcl_AppendResult(interp, "expected version number but got \"",
 674             string, "\"", (char *) NULL);
 675     return TCL_ERROR;
 676 }
 677 \f
 678 /*
 679  *----------------------------------------------------------------------
 680  *
 681  * ComparePkgVersions --
 682  *
 683  *      This procedure compares two version numbers.
 684  *
 685  * Results:
 686  *      The return value is -1 if v1 is less than v2, 0 if the two
 687  *      version numbers are the same, and 1 if v1 is greater than v2.
 688  *      If *satPtr is non-NULL, the word it points to is filled in
 689  *      with 1 if v2 >= v1 and both numbers have the same major number
 690  *      or 0 otherwise.
 691  *
 692  * Side effects:
 693  *      None.
 694  *
 695  *----------------------------------------------------------------------
 696  */
 697
 698 static int
 699 ComparePkgVersions(
 700     char *v1, char *v2,         /* Versions strings, of form 2.1.3 (any
 701                                  * number of version numbers). */
 702     int *satPtr                 /* If non-null, the word pointed to is
 703                                  * filled in with a 0/1 value.  1 means
 704                                  * v1 "satisfies" v2:  v1 is greater than
 705                                  * or equal to v2 and both version numbers
 706                                  * have the same major number. */
 707 )
 708 {
 709     int thisIsMajor, n1, n2;
 710
 711     /*
 712      * Each iteration of the following loop processes one number from
 713      * each string, terminated by a ".".  If those numbers don't match
 714      * then the comparison is over;  otherwise, we loop back for the
 715      * next number.
 716      */
 717
 718     thisIsMajor = 1;
 719     while (1) {
 720         /*
 721          * Parse one decimal number from the front of each string.
 722          */
 723
 724         n1 = n2 = 0;
 725         while ((*v1 != 0) && (*v1 != '.')) {
 726             n1 = 10*n1 + (*v1 - '0');
 727             v1++;
 728         }
 729         while ((*v2 != 0) && (*v2 != '.')) {
 730             n2 = 10*n2 + (*v2 - '0');
 731             v2++;
 732         }
 733
 734         /*
 735          * Compare and go on to the next version number if the
 736          * current numbers match.
 737          */
 738
 739         if (n1 != n2) {
 740             break;
 741         }
 742         if (*v1 != 0) {
 743             v1++;
 744         } else if (*v2 == 0) {
 745             break;
 746         }
 747         if (*v2 != 0) {
 748             v2++;
 749         }
 750         thisIsMajor = 0;
 751     }
 752     if (satPtr != NULL) {
 753         *satPtr = (n1 == n2) || ((n1 > n2) && !thisIsMajor);
 754     }
 755     if (n1 > n2) {
 756         return 1;
 757     } else if (n1 == n2) {
 758         return 0;
 759     } else {
 760         return -1;
 761     }
 762 }