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