Logo Search packages:      
Sourcecode: tcl8.4 version File versions  Download package

tclPkg.c

/* 
 * tclPkg.c --
 *
 *    This file implements package and version control for Tcl via
 *    the "package" command and a few C APIs.
 *
 * Copyright (c) 1996 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclPkg.c,v 1.9.2.2 2005/11/18 19:27:19 dgp Exp $
 */

#include "tclInt.h"

/*
 * Each invocation of the "package ifneeded" command creates a structure
 * of the following type, which is used to load the package into the
 * interpreter if it is requested with a "package require" command.
 */

typedef struct PkgAvail {
    char *version;            /* Version string; malloc'ed. */
    char *script;       /* Script to invoke to provide this version
                         * of the package.  Malloc'ed and protected
                         * by Tcl_Preserve and Tcl_Release. */
    struct PkgAvail *nextPtr; /* Next in list of available versions of
                         * the same package. */
} PkgAvail;

/*
 * For each package that is known in any way to an interpreter, there
 * is one record of the following type.  These records are stored in
 * the "packageTable" hash table in the interpreter, keyed by
 * package name such as "Tk" (no version number).
 */

typedef struct Package {
    char *version;            /* Version that has been supplied in this
                         * interpreter via "package provide"
                         * (malloc'ed).  NULL means the package doesn't
                         * exist in this interpreter yet. */
    PkgAvail *availPtr;       /* First in list of all available versions
                         * of this package. */
    ClientData clientData;    /* Client data. */
} Package;

/*
 * Prototypes for procedures defined in this file:
 */

static int        CheckVersion _ANSI_ARGS_((Tcl_Interp *interp,
                      CONST char *string));
static int        ComparePkgVersions _ANSI_ARGS_((CONST char *v1, 
                            CONST char *v2,
                      int *satPtr));
static Package *  FindPackage _ANSI_ARGS_((Tcl_Interp *interp,
                      CONST char *name));

/*
 *----------------------------------------------------------------------
 *
 * Tcl_PkgProvide / Tcl_PkgProvideEx --
 *
 *    This procedure is invoked to declare that a particular version
 *    of a particular package is now present in an interpreter.  There
 *    must not be any other version of this package already
 *    provided in the interpreter.
 *
 * Results:
 *    Normally returns TCL_OK;  if there is already another version
 *    of the package loaded then TCL_ERROR is returned and an error
 *    message is left in the interp's result.
 *
 * Side effects:
 *    The interpreter remembers that this package is available,
 *    so that no other version of the package may be provided for
 *    the interpreter.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_PkgProvide(interp, name, version)
    Tcl_Interp *interp;       /* Interpreter in which package is now
                         * available. */
    CONST char *name;         /* Name of package. */
    CONST char *version;      /* Version string for package. */
{
    return Tcl_PkgProvideEx(interp, name, version, (ClientData) NULL);
}

int
Tcl_PkgProvideEx(interp, name, version, clientData)
    Tcl_Interp *interp;       /* Interpreter in which package is now
                         * available. */
    CONST char *name;         /* Name of package. */
    CONST char *version;      /* Version string for package. */
    ClientData clientData;      /* clientdata for this package (normally
                                 * used for C callback function table) */
{
    Package *pkgPtr;

    pkgPtr = FindPackage(interp, name);
    if (pkgPtr->version == NULL) {
      pkgPtr->version = ckalloc((unsigned) (strlen(version) + 1));
      strcpy(pkgPtr->version, version);
      pkgPtr->clientData = clientData;
      return TCL_OK;
    }
    if (ComparePkgVersions(pkgPtr->version, version, (int *) NULL) == 0) {
      if (clientData != NULL) {
          pkgPtr->clientData = clientData;
      }
      return TCL_OK;
    }
    Tcl_AppendResult(interp, "conflicting versions provided for package \"",
          name, "\": ", pkgPtr->version, ", then ", version, (char *) NULL);
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_PkgRequire / Tcl_PkgRequireEx --
 *
 *    This procedure is called by code that depends on a particular
 *    version of a particular package.  If the package is not already
 *    provided in the interpreter, this procedure invokes a Tcl script
 *    to provide it.  If the package is already provided, this
 *    procedure makes sure that the caller's needs don't conflict with
 *    the version that is present.
 *
 * Results:
 *    If successful, returns the version string for the currently
 *    provided version of the package, which may be different from
 *    the "version" argument.  If the caller's requirements
 *    cannot be met (e.g. the version requested conflicts with
 *    a currently provided version, or the required version cannot
 *    be found, or the script to provide the required version
 *    generates an error), NULL is returned and an error
 *    message is left in the interp's result.
 *
 * Side effects:
 *    The script from some previous "package ifneeded" command may
 *    be invoked to provide the package.
 *
 *----------------------------------------------------------------------
 */

CONST char *
Tcl_PkgRequire(interp, name, version, exact)
    Tcl_Interp *interp;       /* Interpreter in which package is now
                         * available. */
    CONST char *name;         /* Name of desired package. */
    CONST char *version;      /* Version string for desired version;
                         * NULL means use the latest version
                         * available. */
    int exact;                /* Non-zero means that only the particular
                         * version given is acceptable. Zero means
                         * use the latest compatible version. */
{
    return Tcl_PkgRequireEx(interp, name, version, exact, (ClientData *) NULL);
}

CONST char *
Tcl_PkgRequireEx(interp, name, version, exact, clientDataPtr)
    Tcl_Interp *interp;       /* Interpreter in which package is now
                         * available. */
    CONST char *name;         /* Name of desired package. */
    CONST char *version;      /* Version string for desired version;
                         * NULL means use the latest version
                         * available. */
    int exact;                /* Non-zero means that only the particular
                         * version given is acceptable. Zero means
                         * use the latest compatible version. */
    ClientData *clientDataPtr;      /* Used to return the client data for this
                         * package. If it is NULL then the client
                         * data is not returned. This is unchanged
                         * if this call fails for any reason. */
{
    Package *pkgPtr;
    PkgAvail *availPtr, *bestPtr;
    char *script;
    int code, satisfies, result, pass;
    Tcl_DString command;

    /*
     * If an attempt is being made to load this into a standalone executable
     * on a platform where backlinking is not supported then this must be
     * a shared version of Tcl (Otherwise the load would have failed).
     * Detect this situation by checking that this library has been correctly
     * initialised. If it has not been then return immediately as nothing will
     * work.
     */
    
    if (tclEmptyStringRep == NULL) {

      /*
       * OK, so what's going on here?
       *
       * First, what are we doing?  We are performing a check on behalf of
       * one particular caller, Tcl_InitStubs().  When a package is
       * stub-enabled, it is statically linked to libtclstub.a, which
       * contains a copy of Tcl_InitStubs().  When a stub-enabled package
       * is loaded, its *_Init() function is supposed to call
       * Tcl_InitStubs() before calling any other functions in the Tcl
       * library.  The first Tcl function called by Tcl_InitStubs() through
       * the stub table is Tcl_PkgRequireEx(), so this code right here is
       * the first code that is part of the original Tcl library in the
       * executable that gets executed on behalf of a newly loaded
       * stub-enabled package.
       *
       * One easy error for the developer/builder of a stub-enabled package
       * to make is to forget to define USE_TCL_STUBS when compiling the
       * package.  When that happens, the package will contain symbols
       * that are references to the Tcl library, rather than function
       * pointers referencing the stub table.  On platforms that lack
       * backlinking, those unresolved references may cause the loading
       * of the package to also load a second copy of the Tcl library,
       * leading to all kinds of trouble.  We would like to catch that
       * error and report a useful message back to the user.  That's
       * what we're doing.
       *
       * Second, how does this work?  If we reach this point, then the
       * global variable tclEmptyStringRep has the value NULL.  Compare
       * that with the definition of tclEmptyStringRep near the top of
       * the file generic/tclObj.c.  It clearly should not have the value
       * NULL; it should point to the char tclEmptyString.  If we see it
       * having the value NULL, then somehow we are seeing a Tcl library
       * that isn't completely initialized, and that's an indicator for the
       * error condition described above.  (Further explanation is welcome.)
       *
       * Third, so what do we do about it?  This situation indicates
       * the package we just loaded wasn't properly compiled to be
       * stub-enabled, yet it thinks it is stub-enabled (it called
       * Tcl_InitStubs()).  We want to report that the package just
       * loaded is broken, so we want to place an error message in
       * the interpreter result and return NULL to indicate failure
       * to Tcl_InitStubs() so that it will also fail.  (Further
       * explanation why we don't want to Tcl_Panic() is welcome.
       * After all, two Tcl libraries can't be a good thing!)
       *
       * Trouble is that's going to be tricky.  We're now using a Tcl
       * library that's not fully initialized.  In particular, it 
       * doesn't have a proper value for tclEmptyStringRep.  The
       * Tcl_Obj system heavily depends on the value of tclEmptyStringRep
       * and all of Tcl depends (increasingly) on the Tcl_Obj system, we
       * need to correct that flaw before making the calls to set the 
       * interpreter result to the error message.  That's the only flaw
       * corrected; other problems with initialization of the Tcl library
       * are not remedied, so be very careful about adding any other calls
       * here without checking how they behave when initialization is
       * incomplete.
       */

      tclEmptyStringRep = &tclEmptyString;
        Tcl_AppendResult(interp, "Cannot load package \"", name, 
                "\" in standalone executable: This package is not ",
                "compiled with stub support", NULL);
        return NULL;
    }

    /*
     * It can take up to three passes to find the package:  one pass to
     * run the "package unknown" script, one to run the "package ifneeded"
     * script for a specific version, and a final pass to lookup the
     * package loaded by the "package ifneeded" script.
     */

    for (pass = 1; ; pass++) {
      pkgPtr = FindPackage(interp, name);
      if (pkgPtr->version != NULL) {
          break;
      }

      /* 
       * Check whether we're already attempting to load some version
       * of this package (circular dependency detection).
       */

      if (pkgPtr->clientData != NULL) {
          Tcl_AppendResult(interp, "circular package dependency: ",
                "attempt to provide ", name, " ",
                (char *)(pkgPtr->clientData), " requires ", name, NULL);
          if (version != NULL) {
            Tcl_AppendResult(interp, " ", version, NULL);
          }
          return NULL;
      }

      /*
       * The package isn't yet present.  Search the list of available
       * versions and invoke the script for the best available version.
       */
    
      bestPtr = NULL;
      for (availPtr = pkgPtr->availPtr; availPtr != NULL;
            availPtr = availPtr->nextPtr) {
          if ((bestPtr != NULL) && (ComparePkgVersions(availPtr->version,
                bestPtr->version, (int *) NULL) <= 0)) {
            continue;
          }
          if (version != NULL) {
            result = ComparePkgVersions(availPtr->version, version,
                  &satisfies);
            if ((result != 0) && exact) {
                continue;
            }
            if (!satisfies) {
                continue;
            }
          }
          bestPtr = availPtr;
      }
      if (bestPtr != NULL) {
          /*
           * We found an ifneeded script for the package.  Be careful while
           * executing it:  this could cause reentrancy, so (a) protect the
           * script itself from deletion and (b) don't assume that bestPtr
           * will still exist when the script completes.
           */

          CONST char *versionToProvide = bestPtr->version;
          script = bestPtr->script;
          pkgPtr->clientData = (ClientData) versionToProvide;
          Tcl_Preserve((ClientData) script);
          Tcl_Preserve((ClientData) versionToProvide);
          code = Tcl_GlobalEval(interp, script);
          Tcl_Release((ClientData) script);
          pkgPtr = FindPackage(interp, name);
          if (code == TCL_OK) {
            if (pkgPtr->version == NULL) {
                Tcl_ResetResult(interp);
                code = TCL_ERROR;
                Tcl_AppendResult(interp, "attempt to provide package ",
                      name, " ", versionToProvide,
                      " failed: no version of package ", name,
                      " provided", NULL);
            } else if (0 != ComparePkgVersions(
                  pkgPtr->version, versionToProvide, NULL)) {
                /* At this point, it is clear that a prior
                 * [package ifneeded] command lied to us.  It said
                 * that to get a particular version of a particular
                 * package, we needed to evaluate a particular script.
                 * However, we evaluated that script and got a different
                 * version than we were told.  This is an error, and we
                 * ought to report it.
                 *
                 * However, we've been letting this type of error slide
                 * for a long time, and as a result, a lot of packages
                 * suffer from them.
                 *
                 * It's a bit too harsh to make a large number of
                 * existing packages start failing by releasing a
                 * new patch release, so we forgive this type of error
                 * for the rest of the Tcl 8.4 series, and only report
                 * a warning.  We limit the error reporting to only
                 * the situation where a broken ifneeded script leads
                 * to a failure to satisfy the requirement.
                 */
                if (version) {
                  result = ComparePkgVersions(
                        pkgPtr->version, version, &satisfies);
                  if (result && (exact || !satisfies)) {
                      Tcl_ResetResult(interp);
                      code = TCL_ERROR;
                      Tcl_AppendResult(interp,
                            "attempt to provide package ", name, " ",
                            versionToProvide, " failed: package ",
                            name, " ", pkgPtr->version,
                            " provided instead", NULL);
                  }
                }
                if (code == TCL_OK) {
                  /* Forgiving the error, report warning instead */
                  Tcl_Obj *msg = Tcl_NewStringObj(
                        "attempt to provide package ", -1);
                  Tcl_Obj *cmdPtr = Tcl_NewListObj(0, NULL);
                  Tcl_ListObjAppendElement(NULL, cmdPtr,
                        Tcl_NewStringObj("tclLog", -1));
                  Tcl_AppendStringsToObj(msg, name, " ", versionToProvide,
                        " failed: package ", name, " ",
                        pkgPtr->version, " provided instead", NULL);
                  Tcl_ListObjAppendElement(NULL, cmdPtr, msg);
                  Tcl_IncrRefCount(cmdPtr);
                  Tcl_GlobalEvalObj(interp, cmdPtr);
                  Tcl_DecrRefCount(cmdPtr);
                  Tcl_ResetResult(interp);
                }
            }
          } else if (code != TCL_ERROR) {
            Tcl_Obj *codePtr = Tcl_NewIntObj(code);
            Tcl_ResetResult(interp);
            Tcl_AppendResult(interp, "attempt to provide package ",
                  name, " ", versionToProvide, " failed: ",
                  "bad return code: ", Tcl_GetString(codePtr), NULL);
            Tcl_DecrRefCount(codePtr);
            code = TCL_ERROR;
          }
          Tcl_Release((ClientData) versionToProvide);

          if (code != TCL_OK) {
            /*
             * Take a non-TCL_OK code from the script as an
             * indication the package wasn't loaded properly,
             * so the package system should not remember an
             * improper load.
             *
             * This is consistent with our returning NULL.
             * If we're not willing to tell our caller we
             * got a particular version, we shouldn't store
             * that version for telling future callers either.
             */
            Tcl_AddErrorInfo(interp, "\n    (\"package ifneeded\" script)");
            if (pkgPtr->version != NULL) {
                ckfree(pkgPtr->version);
                pkgPtr->version = NULL;
            }
            pkgPtr->clientData = NULL;
            return NULL;
          }
          break;
      }

      /*
       * Package not in the database.  If there is a "package unknown"
       * command, invoke it (but only on the first pass;  after that,
       * we should not get here in the first place).
       */

      if (pass > 1) {
          break;
      }
      script = ((Interp *) interp)->packageUnknown;
      if (script != NULL) {
          Tcl_DStringInit(&command);
          Tcl_DStringAppend(&command, script, -1);
          Tcl_DStringAppendElement(&command, name);
          Tcl_DStringAppend(&command, " ", 1);
          Tcl_DStringAppend(&command, (version != NULL) ? version : "{}",
                -1);
          if (exact) {
            Tcl_DStringAppend(&command, " -exact", 7);
          }
          code = Tcl_GlobalEval(interp, Tcl_DStringValue(&command));
          Tcl_DStringFree(&command);
          if ((code != TCL_OK) && (code != TCL_ERROR)) {
            Tcl_Obj *codePtr = Tcl_NewIntObj(code);
            Tcl_ResetResult(interp);
            Tcl_AppendResult(interp, "bad return code: ",
                  Tcl_GetString(codePtr), NULL);
            Tcl_DecrRefCount(codePtr);
            code = TCL_ERROR;
          }
          if (code == TCL_ERROR) {
            Tcl_AddErrorInfo(interp, "\n    (\"package unknown\" script)");
            return NULL;
          }
          Tcl_ResetResult(interp);
      }
    }

    if (pkgPtr->version == NULL) {
      Tcl_AppendResult(interp, "can't find package ", name,
            (char *) NULL);
      if (version != NULL) {
          Tcl_AppendResult(interp, " ", version, (char *) NULL);
      }
      return NULL;
    }

    /*
     * At this point we know that the package is present.  Make sure that the
     * provided version meets the current requirement.
     */

    if (version == NULL) {
        if (clientDataPtr) {
          *clientDataPtr = pkgPtr->clientData;
      }
      return pkgPtr->version;
    }
    result = ComparePkgVersions(pkgPtr->version, version, &satisfies);
    if ((satisfies && !exact) || (result == 0)) {
      if (clientDataPtr) {
          *clientDataPtr = pkgPtr->clientData;
      }
      return pkgPtr->version;
    }
    Tcl_AppendResult(interp, "version conflict for package \"",
          name, "\": have ", pkgPtr->version, ", need ", version,
          (char *) NULL);
    return NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_PkgPresent / Tcl_PkgPresentEx --
 *
 *    Checks to see whether the specified package is present. If it
 *    is not then no additional action is taken.
 *
 * Results:
 *    If successful, returns the version string for the currently
 *    provided version of the package, which may be different from
 *    the "version" argument.  If the caller's requirements
 *    cannot be met (e.g. the version requested conflicts with
 *    a currently provided version), NULL is returned and an error
 *    message is left in interp->result.
 *
 * Side effects:
 *    None.
 *
 *----------------------------------------------------------------------
 */

CONST char *
Tcl_PkgPresent(interp, name, version, exact)
    Tcl_Interp *interp;       /* Interpreter in which package is now
                         * available. */
    CONST char *name;         /* Name of desired package. */
    CONST char *version;      /* Version string for desired version;
                         * NULL means use the latest version
                         * available. */
    int exact;                /* Non-zero means that only the particular
                         * version given is acceptable. Zero means
                         * use the latest compatible version. */
{
    return Tcl_PkgPresentEx(interp, name, version, exact, (ClientData *) NULL);
}

CONST char *
Tcl_PkgPresentEx(interp, name, version, exact, clientDataPtr)
    Tcl_Interp *interp;       /* Interpreter in which package is now
                         * available. */
    CONST char *name;         /* Name of desired package. */
    CONST char *version;      /* Version string for desired version;
                         * NULL means use the latest version
                         * available. */
    int exact;                /* Non-zero means that only the particular
                         * version given is acceptable. Zero means
                         * use the latest compatible version. */
    ClientData *clientDataPtr;      /* Used to return the client data for this
                         * package. If it is NULL then the client
                         * data is not returned. This is unchanged
                         * if this call fails for any reason. */
{
    Interp *iPtr = (Interp *) interp;
    Tcl_HashEntry *hPtr;
    Package *pkgPtr;
    int satisfies, result;

    hPtr = Tcl_FindHashEntry(&iPtr->packageTable, name);
    if (hPtr) {
      pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
      if (pkgPtr->version != NULL) {
          
          /*
           * At this point we know that the package is present.  Make sure
           * that the provided version meets the current requirement.
           */

          if (version == NULL) {
            if (clientDataPtr) {
                *clientDataPtr = pkgPtr->clientData;
            }
            
            return pkgPtr->version;
          }
          result = ComparePkgVersions(pkgPtr->version, version, &satisfies);
          if ((satisfies && !exact) || (result == 0)) {
            if (clientDataPtr) {
                *clientDataPtr = pkgPtr->clientData;
            }
    
            return pkgPtr->version;
          }
          Tcl_AppendResult(interp, "version conflict for package \"",
                       name, "\": have ", pkgPtr->version,
                       ", need ", version, (char *) NULL);
          return NULL;
      }
    }

    if (version != NULL) {
      Tcl_AppendResult(interp, "package ", name, " ", version,
                   " is not present", (char *) NULL);
    } else {
      Tcl_AppendResult(interp, "package ", name, " is not present",
                   (char *) NULL);
    }
    return NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_PackageObjCmd --
 *
 *    This procedure is invoked to process the "package" Tcl command.
 *    See the user documentation for details on what it does.
 *
 * Results:
 *    A standard Tcl result.
 *
 * Side effects:
 *    See the user documentation.
 *
 *----------------------------------------------------------------------
 */

      /* ARGSUSED */
int
Tcl_PackageObjCmd(dummy, interp, objc, objv)
    ClientData dummy;               /* Not used. */
    Tcl_Interp *interp;             /* Current interpreter. */
    int objc;                       /* Number of arguments. */
    Tcl_Obj *CONST objv[];    /* Argument objects. */
{
    static CONST char *pkgOptions[] = {
      "forget", "ifneeded", "names", "present", "provide", "require",
      "unknown", "vcompare", "versions", "vsatisfies", (char *) NULL
    };
    enum pkgOptions {
      PKG_FORGET, PKG_IFNEEDED, PKG_NAMES, PKG_PRESENT,
      PKG_PROVIDE, PKG_REQUIRE, PKG_UNKNOWN, PKG_VCOMPARE,
      PKG_VERSIONS, PKG_VSATISFIES
    };
    Interp *iPtr = (Interp *) interp;
    int optionIndex, exact, i, satisfies;
    PkgAvail *availPtr, *prevPtr;
    Package *pkgPtr;
    Tcl_HashEntry *hPtr;
    Tcl_HashSearch search;
    Tcl_HashTable *tablePtr;
    CONST char *version;
    char *argv2, *argv3, *argv4;

    if (objc < 2) {
        Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?");
      return TCL_ERROR;
    }

    if (Tcl_GetIndexFromObj(interp, objv[1], pkgOptions, "option", 0,
          &optionIndex) != TCL_OK) {
      return TCL_ERROR;
    }
    switch ((enum pkgOptions) optionIndex) {
      case PKG_FORGET: {
          char *keyString;
          for (i = 2; i < objc; i++) {
            keyString = Tcl_GetString(objv[i]);
            hPtr = Tcl_FindHashEntry(&iPtr->packageTable, keyString);
            if (hPtr == NULL) {
                continue;     
            }
            pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
            Tcl_DeleteHashEntry(hPtr);
            if (pkgPtr->version != NULL) {
                ckfree(pkgPtr->version);
            }
            while (pkgPtr->availPtr != NULL) {
                availPtr = pkgPtr->availPtr;
                pkgPtr->availPtr = availPtr->nextPtr;
                Tcl_EventuallyFree((ClientData)availPtr->version, TCL_DYNAMIC);
                Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC);
                ckfree((char *) availPtr);
            }
            ckfree((char *) pkgPtr);
          }
          break;
      }
      case PKG_IFNEEDED: {
          int length;
          if ((objc != 4) && (objc != 5)) {
            Tcl_WrongNumArgs(interp, 2, objv, "package version ?script?");
            return TCL_ERROR;
          }
          argv3 = Tcl_GetString(objv[3]);
          if (CheckVersion(interp, argv3) != TCL_OK) {
            return TCL_ERROR;
          }
          argv2 = Tcl_GetString(objv[2]);
          if (objc == 4) {
            hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2);
            if (hPtr == NULL) {
                return TCL_OK;
            }
            pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
          } else {
            pkgPtr = FindPackage(interp, argv2);
          }
          argv3 = Tcl_GetStringFromObj(objv[3], &length);
          for (availPtr = pkgPtr->availPtr, prevPtr = NULL; availPtr != NULL;
             prevPtr = availPtr, availPtr = availPtr->nextPtr) {
            if (ComparePkgVersions(availPtr->version, argv3, (int *) NULL)
                  == 0) {
                if (objc == 4) {
                  Tcl_SetResult(interp, availPtr->script, TCL_VOLATILE);
                  return TCL_OK;
                }
                Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC);
                break;
            }
          }
          if (objc == 4) {
            return TCL_OK;
          }
          if (availPtr == NULL) {
            availPtr = (PkgAvail *) ckalloc(sizeof(PkgAvail));
            availPtr->version = ckalloc((unsigned) (length + 1));
            strcpy(availPtr->version, argv3);
            if (prevPtr == NULL) {
                availPtr->nextPtr = pkgPtr->availPtr;
                pkgPtr->availPtr = availPtr;
            } else {
                availPtr->nextPtr = prevPtr->nextPtr;
                prevPtr->nextPtr = availPtr;
            }
          }
          argv4 = Tcl_GetStringFromObj(objv[4], &length);
          availPtr->script = ckalloc((unsigned) (length + 1));
          strcpy(availPtr->script, argv4);
          break;
      }
      case PKG_NAMES: {
          if (objc != 2) {
            Tcl_WrongNumArgs(interp, 2, objv, NULL);
            return TCL_ERROR;
          }
          tablePtr = &iPtr->packageTable;
          for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL;
             hPtr = Tcl_NextHashEntry(&search)) {
            pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
            if ((pkgPtr->version != NULL) || (pkgPtr->availPtr != NULL)) {
                Tcl_AppendElement(interp, Tcl_GetHashKey(tablePtr, hPtr));
            }
          }
          break;
      }
      case PKG_PRESENT: {
          if (objc < 3) {
            presentSyntax:
            Tcl_WrongNumArgs(interp, 2, objv, "?-exact? package ?version?");
            return TCL_ERROR;
          }
          argv2 = Tcl_GetString(objv[2]);
          if ((argv2[0] == '-') && (strcmp(argv2, "-exact") == 0)) {
            exact = 1;
          } else {
            exact = 0;
          }
          version = NULL;
          if (objc == (4 + exact)) {
            version =  Tcl_GetString(objv[3 + exact]);
            if (CheckVersion(interp, version) != TCL_OK) {
                return TCL_ERROR;
            }
          } else if ((objc != 3) || exact) {
            goto presentSyntax;
          }
          if (exact) {
            argv3 =  Tcl_GetString(objv[3]);
            version = Tcl_PkgPresent(interp, argv3, version, exact);
          } else {
            version = Tcl_PkgPresent(interp, argv2, version, exact);
          }
          if (version == NULL) {
            return TCL_ERROR;
          }
          Tcl_SetObjResult( interp, Tcl_NewStringObj( version, -1 ) );
          break;
      }
      case PKG_PROVIDE: {
          if ((objc != 3) && (objc != 4)) {
            Tcl_WrongNumArgs(interp, 2, objv, "package ?version?");
            return TCL_ERROR;
          }
          argv2 = Tcl_GetString(objv[2]);
          if (objc == 3) {
            hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2);
            if (hPtr != NULL) {
                pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
                if (pkgPtr->version != NULL) {
                  Tcl_SetResult(interp, pkgPtr->version, TCL_VOLATILE);
                }
            }
            return TCL_OK;
          }
          argv3 = Tcl_GetString(objv[3]);
          if (CheckVersion(interp, argv3) != TCL_OK) {
            return TCL_ERROR;
          }
          return Tcl_PkgProvide(interp, argv2, argv3);
      }
      case PKG_REQUIRE: {
          if (objc < 3) {
            requireSyntax:
            Tcl_WrongNumArgs(interp, 2, objv, "?-exact? package ?version?");
            return TCL_ERROR;
          }
          argv2 = Tcl_GetString(objv[2]);
          if ((argv2[0] == '-') && (strcmp(argv2, "-exact") == 0)) {
            exact = 1;
          } else {
            exact = 0;
          }
          version = NULL;
          if (objc == (4 + exact)) {
            version =  Tcl_GetString(objv[3 + exact]);
            if (CheckVersion(interp, version) != TCL_OK) {
                return TCL_ERROR;
            }
          } else if ((objc != 3) || exact) {
            goto requireSyntax;
          }
          if (exact) {
            argv3 =  Tcl_GetString(objv[3]);
            version = Tcl_PkgRequire(interp, argv3, version, exact);
          } else {
            version = Tcl_PkgRequire(interp, argv2, version, exact);
          }
          if (version == NULL) {
            return TCL_ERROR;
          }
          Tcl_SetObjResult( interp, Tcl_NewStringObj( version, -1 ) );
          break;
      }
      case PKG_UNKNOWN: {
          int length;
          if (objc == 2) {
            if (iPtr->packageUnknown != NULL) {
                Tcl_SetResult(interp, iPtr->packageUnknown, TCL_VOLATILE);
            }
          } else if (objc == 3) {
            if (iPtr->packageUnknown != NULL) {
                ckfree(iPtr->packageUnknown);
            }
            argv2 = Tcl_GetStringFromObj(objv[2], &length);
            if (argv2[0] == 0) {
                iPtr->packageUnknown = NULL;
            } else {
                iPtr->packageUnknown = (char *) ckalloc((unsigned)
                      (length + 1));
                strcpy(iPtr->packageUnknown, argv2);
            }
          } else {
            Tcl_WrongNumArgs(interp, 2, objv, "?command?");
            return TCL_ERROR;
          }
          break;
      }
      case PKG_VCOMPARE: {
          if (objc != 4) {
            Tcl_WrongNumArgs(interp, 2, objv, "version1 version2");
            return TCL_ERROR;
          }
          argv3 = Tcl_GetString(objv[3]);
          argv2 = Tcl_GetString(objv[2]);
          if ((CheckVersion(interp, argv2) != TCL_OK)
                || (CheckVersion(interp, argv3) != TCL_OK)) {
            return TCL_ERROR;
          }
          Tcl_SetIntObj(Tcl_GetObjResult(interp),
                ComparePkgVersions(argv2, argv3, (int *) NULL));
          break;
      }
      case PKG_VERSIONS: {
          if (objc != 3) {
            Tcl_WrongNumArgs(interp, 2, objv, "package");
            return TCL_ERROR;
          }
          argv2 = Tcl_GetString(objv[2]);
          hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2);
          if (hPtr != NULL) {
            pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
            for (availPtr = pkgPtr->availPtr; availPtr != NULL;
                 availPtr = availPtr->nextPtr) {
                Tcl_AppendElement(interp, availPtr->version);
            }
          }
          break;
      }
      case PKG_VSATISFIES: {
          if (objc != 4) {
            Tcl_WrongNumArgs(interp, 2, objv, "version1 version2");
            return TCL_ERROR;
          }
          argv3 = Tcl_GetString(objv[3]);
          argv2 = Tcl_GetString(objv[2]);
          if ((CheckVersion(interp, argv2) != TCL_OK)
                || (CheckVersion(interp, argv3) != TCL_OK)) {
            return TCL_ERROR;
          }
          ComparePkgVersions(argv2, argv3, &satisfies);
          Tcl_SetIntObj(Tcl_GetObjResult(interp), satisfies);
          break;
      }
      default: {
          panic("Tcl_PackageObjCmd: bad option index to pkgOptions");
      }
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * FindPackage --
 *
 *    This procedure finds the Package record for a particular package
 *    in a particular interpreter, creating a record if one doesn't
 *    already exist.
 *
 * Results:
 *    The return value is a pointer to the Package record for the
 *    package.
 *
 * Side effects:
 *    A new Package record may be created.
 *
 *----------------------------------------------------------------------
 */

static Package *
FindPackage(interp, name)
    Tcl_Interp *interp;       /* Interpreter to use for package lookup. */
    CONST char *name;         /* Name of package to fine. */
{
    Interp *iPtr = (Interp *) interp;
    Tcl_HashEntry *hPtr;
    int new;
    Package *pkgPtr;

    hPtr = Tcl_CreateHashEntry(&iPtr->packageTable, name, &new);
    if (new) {
      pkgPtr = (Package *) ckalloc(sizeof(Package));
      pkgPtr->version = NULL;
      pkgPtr->availPtr = NULL;
      pkgPtr->clientData = NULL;
      Tcl_SetHashValue(hPtr, pkgPtr);
    } else {
      pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
    }
    return pkgPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * TclFreePackageInfo --
 *
 *    This procedure is called during interpreter deletion to
 *    free all of the package-related information for the
 *    interpreter.
 *
 * Results:
 *    None.
 *
 * Side effects:
 *    Memory is freed.
 *
 *----------------------------------------------------------------------
 */

void
TclFreePackageInfo(iPtr)
    Interp *iPtr;       /* Interpereter that is being deleted. */
{
    Package *pkgPtr;
    Tcl_HashSearch search;
    Tcl_HashEntry *hPtr;
    PkgAvail *availPtr;

    for (hPtr = Tcl_FirstHashEntry(&iPtr->packageTable, &search);
          hPtr != NULL;  hPtr = Tcl_NextHashEntry(&search)) {
      pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
      if (pkgPtr->version != NULL) {
          ckfree(pkgPtr->version);
      }
      while (pkgPtr->availPtr != NULL) {
          availPtr = pkgPtr->availPtr;
          pkgPtr->availPtr = availPtr->nextPtr;
          Tcl_EventuallyFree((ClientData)availPtr->version, TCL_DYNAMIC);
          Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC);
          ckfree((char *) availPtr);
      }
      ckfree((char *) pkgPtr);
    }
    Tcl_DeleteHashTable(&iPtr->packageTable);
    if (iPtr->packageUnknown != NULL) {
      ckfree(iPtr->packageUnknown);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * CheckVersion --
 *
 *    This procedure checks to see whether a version number has
 *    valid syntax.
 *
 * Results:
 *    If string is a properly formed version number the TCL_OK
 *    is returned.  Otherwise TCL_ERROR is returned and an error
 *    message is left in the interp's result.
 *
 * Side effects:
 *    None.
 *
 *----------------------------------------------------------------------
 */

static int
CheckVersion(interp, string)
    Tcl_Interp *interp;       /* Used for error reporting. */
    CONST char *string;       /* Supposedly a version number, which is
                         * groups of decimal digits separated
                         * by dots. */
{
    CONST char *p = string;
    char prevChar;
    
    if (!isdigit(UCHAR(*p))) {      /* INTL: digit */
      goto error;
    }
    for (prevChar = *p, p++; *p != 0; p++) {
      if (!isdigit(UCHAR(*p)) &&
            ((*p != '.') || (prevChar == '.'))) { /* INTL: digit */
          goto error;
      }
      prevChar = *p;
    }
    if (prevChar != '.') {
      return TCL_OK;
    }

    error:
    Tcl_AppendResult(interp, "expected version number but got \"",
          string, "\"", (char *) NULL);
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * ComparePkgVersions --
 *
 *    This procedure compares two version numbers.
 *
 * Results:
 *    The return value is -1 if v1 is less than v2, 0 if the two
 *    version numbers are the same, and 1 if v1 is greater than v2.
 *    If *satPtr is non-NULL, the word it points to is filled in
 *    with 1 if v2 >= v1 and both numbers have the same major number
 *    or 0 otherwise.
 *
 * Side effects:
 *    None.
 *
 *----------------------------------------------------------------------
 */

static int
ComparePkgVersions(v1, v2, satPtr)
    CONST char *v1;
    CONST char *v2;           /* Versions strings, of form 2.1.3 (any
                         * number of version numbers). */
    int *satPtr;        /* If non-null, the word pointed to is
                         * filled in with a 0/1 value.  1 means
                         * v1 "satisfies" v2:  v1 is greater than
                         * or equal to v2 and both version numbers
                         * have the same major number. */
{
    int thisIsMajor, n1, n2;

    /*
     * Each iteration of the following loop processes one number from
     * each string, terminated by a ".".  If those numbers don't match
     * then the comparison is over;  otherwise, we loop back for the
     * next number.
     */

    thisIsMajor = 1;
    while (1) {
      /*
       * Parse one decimal number from the front of each string.
       */

      n1 = n2 = 0;
      while ((*v1 != 0) && (*v1 != '.')) {
          n1 = 10*n1 + (*v1 - '0');
          v1++;
      }
      while ((*v2 != 0) && (*v2 != '.')) {
          n2 = 10*n2 + (*v2 - '0');
          v2++;
      }

      /*
       * Compare and go on to the next version number if the
       * current numbers match.
       */

      if (n1 != n2) {
          break;
      }
      if (*v1 != 0) {
          v1++;
      } else if (*v2 == 0) {
          break;
      }
      if (*v2 != 0) {
          v2++;
      }
      thisIsMajor = 0;
    }
    if (satPtr != NULL) {
      *satPtr = (n1 == n2) || ((n1 > n2) && !thisIsMajor);
    }
    if (n1 > n2) {
      return 1;
    } else if (n1 == n2) {
      return 0;
    } else {
      return -1;
    }
}

Generated by  Doxygen 1.6.0   Back to index