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