/[dtapublic]/projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclpkg.c
ViewVC logotype

Diff of /projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclpkg.c

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

projs/trunk/shared_source/tcl_base/tclpkg.c revision 42 by dashley, Fri Oct 14 01:50:00 2016 UTC projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclpkg.c revision 71 by dashley, Sat Nov 5 11:07:06 2016 UTC
# Line 1  Line 1 
 /* $Header: /cvsroot/esrg/sfesrg/esrgpcpj/shared/tcl_base/tclpkg.c,v 1.1.1.1 2001/06/13 04:45:00 dtashley Exp $ */  
   
 /*  
  * 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.1.1.1 2001/06/13 04:45:00 dtashley 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,  
                             char *string));  
 static int              ComparePkgVersions _ANSI_ARGS_((char *v1, char *v2,  
                             int *satPtr));  
 static Package *        FindPackage _ANSI_ARGS_((Tcl_Interp *interp,  
                             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. */  
     char *name;                 /* Name of package. */  
     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. */  
     char *name;                 /* Name of package. */  
     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.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 char *  
 Tcl_PkgRequire(interp, name, version, exact)  
     Tcl_Interp *interp;         /* Interpreter in which package is now  
                                  * available. */  
     char *name;                 /* Name of desired package. */  
     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);  
 }  
   
 char *  
 Tcl_PkgRequireEx(interp, name, version, exact, clientDataPtr)  
     Tcl_Interp *interp;         /* Interpreter in which package is now  
                                  * available. */  
     char *name;                 /* Name of desired package. */  
     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 standalong 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) {  
         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;  
         }  
   
         /*  
          * 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.  
              */  
           
             script = bestPtr->script;  
             Tcl_Preserve((ClientData) script);  
             code = Tcl_GlobalEval(interp, script);  
             Tcl_Release((ClientData) script);  
             if (code != TCL_OK) {  
                 if (code == TCL_ERROR) {  
                     Tcl_AddErrorInfo(interp,  
                             "\n    (\"package ifneeded\" script)");  
                 }  
                 return NULL;  
             }  
             Tcl_ResetResult(interp);  
             pkgPtr = FindPackage(interp, name);  
             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) {  
                 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.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 char *  
 Tcl_PkgPresent(interp, name, version, exact)  
     Tcl_Interp *interp;         /* Interpreter in which package is now  
                                  * available. */  
     char *name;                 /* Name of desired package. */  
     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);  
 }  
   
 char *  
 Tcl_PkgPresentEx(interp, name, version, exact, clientDataPtr)  
     Tcl_Interp *interp;         /* Interpreter in which package is now  
                                  * available. */  
     char *name;                 /* Name of desired package. */  
     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;  
   
     /*  
      * 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) {  
         Tcl_AppendResult(interp, "Cannot load package \"", name,  
                 "\" in standalone executable: This package is not ",  
                 "compiled with stub support", NULL);  
         return NULL;  
     }  
   
     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 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;  
     char *version, *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) {  
                     return TCL_OK;  
                 }  
                 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;  
                     ckfree(availPtr->version);  
                     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_SetResult(interp, version, TCL_VOLATILE);  
             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_SetResult(interp, version, TCL_VOLATILE);  
             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. */  
     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;  
             ckfree(availPtr->version);  
             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. */  
     char *string;               /* Supposedly a version number, which is  
                                  * groups of decimal digits separated  
                                  * by dots. */  
 {  
     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)  
     char *v1, *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;  
     }  
 }  
   
   
 /* $History: tclpkg.c $  
  *  
  * *****************  Version 1  *****************  
  * User: Dtashley     Date: 1/02/01    Time: 1:37a  
  * Created in $/IjuScripter, IjuConsole/Source/Tcl Base  
  * Initial check-in.  
  */  
   
 /* End of TCLPKG.C */  
1    /* $Header$ */
2    /*
3     * tclPkg.c --
4     *
5     *      This file implements package and version control for Tcl via
6     *      the "package" command and a few C APIs.
7     *
8     * Copyright (c) 1996 Sun Microsystems, Inc.
9     *
10     * See the file "license.terms" for information on usage and redistribution
11     * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
12     *
13     * RCS: @(#) $Id: tclpkg.c,v 1.1.1.1 2001/06/13 04:45:00 dtashley Exp $
14     */
15    
16    #include "tclInt.h"
17    
18    /*
19     * Each invocation of the "package ifneeded" command creates a structure
20     * of the following type, which is used to load the package into the
21     * interpreter if it is requested with a "package require" command.
22     */
23    
24    typedef struct PkgAvail {
25        char *version;              /* Version string; malloc'ed. */
26        char *script;               /* Script to invoke to provide this version
27                                     * of the package.  Malloc'ed and protected
28                                     * by Tcl_Preserve and Tcl_Release. */
29        struct PkgAvail *nextPtr;   /* Next in list of available versions of
30                                     * the same package. */
31    } PkgAvail;
32    
33    /*
34     * For each package that is known in any way to an interpreter, there
35     * is one record of the following type.  These records are stored in
36     * the "packageTable" hash table in the interpreter, keyed by
37     * package name such as "Tk" (no version number).
38     */
39    
40    typedef struct Package {
41        char *version;              /* Version that has been supplied in this
42                                     * interpreter via "package provide"
43                                     * (malloc'ed).  NULL means the package doesn't
44                                     * exist in this interpreter yet. */
45        PkgAvail *availPtr;         /* First in list of all available versions
46                                     * of this package. */
47        ClientData clientData;      /* Client data. */
48    } Package;
49    
50    /*
51     * Prototypes for procedures defined in this file:
52     */
53    
54    static int              CheckVersion _ANSI_ARGS_((Tcl_Interp *interp,
55                                char *string));
56    static int              ComparePkgVersions _ANSI_ARGS_((char *v1, char *v2,
57                                int *satPtr));
58    static Package *        FindPackage _ANSI_ARGS_((Tcl_Interp *interp,
59                                char *name));
60    
61    /*
62     *----------------------------------------------------------------------
63     *
64     * Tcl_PkgProvide / Tcl_PkgProvideEx --
65     *
66     *      This procedure is invoked to declare that a particular version
67     *      of a particular package is now present in an interpreter.  There
68     *      must not be any other version of this package already
69     *      provided in the interpreter.
70     *
71     * Results:
72     *      Normally returns TCL_OK;  if there is already another version
73     *      of the package loaded then TCL_ERROR is returned and an error
74     *      message is left in the interp's result.
75     *
76     * Side effects:
77     *      The interpreter remembers that this package is available,
78     *      so that no other version of the package may be provided for
79     *      the interpreter.
80     *
81     *----------------------------------------------------------------------
82     */
83    
84    int
85    Tcl_PkgProvide(interp, name, version)
86        Tcl_Interp *interp;         /* Interpreter in which package is now
87                                     * available. */
88        char *name;                 /* Name of package. */
89        char *version;              /* Version string for package. */
90    {
91        return Tcl_PkgProvideEx(interp, name, version, (ClientData) NULL);
92    }
93    
94    int
95    Tcl_PkgProvideEx(interp, name, version, clientData)
96        Tcl_Interp *interp;         /* Interpreter in which package is now
97                                     * available. */
98        char *name;                 /* Name of package. */
99        char *version;              /* Version string for package. */
100        ClientData clientData;      /* clientdata for this package (normally
101                                     * used for C callback function table) */
102    {
103        Package *pkgPtr;
104    
105        pkgPtr = FindPackage(interp, name);
106        if (pkgPtr->version == NULL) {
107            pkgPtr->version = ckalloc((unsigned) (strlen(version) + 1));
108            strcpy(pkgPtr->version, version);
109            pkgPtr->clientData = clientData;
110            return TCL_OK;
111        }
112        if (ComparePkgVersions(pkgPtr->version, version, (int *) NULL) == 0) {
113            if (clientData != NULL) {
114                pkgPtr->clientData = clientData;
115            }
116            return TCL_OK;
117        }
118        Tcl_AppendResult(interp, "conflicting versions provided for package \"",
119                name, "\": ", pkgPtr->version, ", then ", version, (char *) NULL);
120        return TCL_ERROR;
121    }
122    
123    /*
124     *----------------------------------------------------------------------
125     *
126     * Tcl_PkgRequire / Tcl_PkgRequireEx --
127     *
128     *      This procedure is called by code that depends on a particular
129     *      version of a particular package.  If the package is not already
130     *      provided in the interpreter, this procedure invokes a Tcl script
131     *      to provide it.  If the package is already provided, this
132     *      procedure makes sure that the caller's needs don't conflict with
133     *      the version that is present.
134     *
135     * Results:
136     *      If successful, returns the version string for the currently
137     *      provided version of the package, which may be different from
138     *      the "version" argument.  If the caller's requirements
139     *      cannot be met (e.g. the version requested conflicts with
140     *      a currently provided version, or the required version cannot
141     *      be found, or the script to provide the required version
142     *      generates an error), NULL is returned and an error
143     *      message is left in the interp's result.
144     *
145     * Side effects:
146     *      The script from some previous "package ifneeded" command may
147     *      be invoked to provide the package.
148     *
149     *----------------------------------------------------------------------
150     */
151    
152    char *
153    Tcl_PkgRequire(interp, name, version, exact)
154        Tcl_Interp *interp;         /* Interpreter in which package is now
155                                     * available. */
156        char *name;                 /* Name of desired package. */
157        char *version;              /* Version string for desired version;
158                                     * NULL means use the latest version
159                                     * available. */
160        int exact;                  /* Non-zero means that only the particular
161                                     * version given is acceptable. Zero means
162                                     * use the latest compatible version. */
163    {
164        return Tcl_PkgRequireEx(interp, name, version, exact, (ClientData *) NULL);
165    }
166    
167    char *
168    Tcl_PkgRequireEx(interp, name, version, exact, clientDataPtr)
169        Tcl_Interp *interp;         /* Interpreter in which package is now
170                                     * available. */
171        char *name;                 /* Name of desired package. */
172        char *version;              /* Version string for desired version;
173                                     * NULL means use the latest version
174                                     * available. */
175        int exact;                  /* Non-zero means that only the particular
176                                     * version given is acceptable. Zero means
177                                     * use the latest compatible version. */
178        ClientData *clientDataPtr;  /* Used to return the client data for this
179                                     * package. If it is NULL then the client
180                                     * data is not returned. This is unchanged
181                                     * if this call fails for any reason. */
182    {
183        Package *pkgPtr;
184        PkgAvail *availPtr, *bestPtr;
185        char *script;
186        int code, satisfies, result, pass;
187        Tcl_DString command;
188    
189        /*
190         * If an attempt is being made to load this into a standalong executable
191         * on a platform where backlinking is not supported then this must be
192         * a shared version of Tcl (Otherwise the load would have failed).
193         * Detect this situation by checking that this library has been correctly
194         * initialised. If it has not been then return immediately as nothing will
195         * work.
196         */
197        
198        if (!tclEmptyStringRep) {
199            Tcl_AppendResult(interp, "Cannot load package \"", name,
200                    "\" in standalone executable: This package is not ",
201                    "compiled with stub support", NULL);
202            return NULL;
203        }
204    
205        /*
206         * It can take up to three passes to find the package:  one pass to
207         * run the "package unknown" script, one to run the "package ifneeded"
208         * script for a specific version, and a final pass to lookup the
209         * package loaded by the "package ifneeded" script.
210         */
211    
212        for (pass = 1; ; pass++) {
213            pkgPtr = FindPackage(interp, name);
214            if (pkgPtr->version != NULL) {
215                break;
216            }
217    
218            /*
219             * The package isn't yet present.  Search the list of available
220             * versions and invoke the script for the best available version.
221             */
222        
223            bestPtr = NULL;
224            for (availPtr = pkgPtr->availPtr; availPtr != NULL;
225                    availPtr = availPtr->nextPtr) {
226                if ((bestPtr != NULL) && (ComparePkgVersions(availPtr->version,
227                        bestPtr->version, (int *) NULL) <= 0)) {
228                    continue;
229                }
230                if (version != NULL) {
231                    result = ComparePkgVersions(availPtr->version, version,
232                            &satisfies);
233                    if ((result != 0) && exact) {
234                        continue;
235                    }
236                    if (!satisfies) {
237                        continue;
238                    }
239                }
240                bestPtr = availPtr;
241            }
242            if (bestPtr != NULL) {
243                /*
244                 * We found an ifneeded script for the package.  Be careful while
245                 * executing it:  this could cause reentrancy, so (a) protect the
246                 * script itself from deletion and (b) don't assume that bestPtr
247                 * will still exist when the script completes.
248                 */
249            
250                script = bestPtr->script;
251                Tcl_Preserve((ClientData) script);
252                code = Tcl_GlobalEval(interp, script);
253                Tcl_Release((ClientData) script);
254                if (code != TCL_OK) {
255                    if (code == TCL_ERROR) {
256                        Tcl_AddErrorInfo(interp,
257                                "\n    (\"package ifneeded\" script)");
258                    }
259                    return NULL;
260                }
261                Tcl_ResetResult(interp);
262                pkgPtr = FindPackage(interp, name);
263                break;
264            }
265    
266            /*
267             * Package not in the database.  If there is a "package unknown"
268             * command, invoke it (but only on the first pass;  after that,
269             * we should not get here in the first place).
270             */
271    
272            if (pass > 1) {
273                break;
274            }
275            script = ((Interp *) interp)->packageUnknown;
276            if (script != NULL) {
277                Tcl_DStringInit(&command);
278                Tcl_DStringAppend(&command, script, -1);
279                Tcl_DStringAppendElement(&command, name);
280                Tcl_DStringAppend(&command, " ", 1);
281                Tcl_DStringAppend(&command, (version != NULL) ? version : "{}",
282                        -1);
283                if (exact) {
284                    Tcl_DStringAppend(&command, " -exact", 7);
285                }
286                code = Tcl_GlobalEval(interp, Tcl_DStringValue(&command));
287                Tcl_DStringFree(&command);
288                if (code != TCL_OK) {
289                    if (code == TCL_ERROR) {
290                        Tcl_AddErrorInfo(interp,
291                                "\n    (\"package unknown\" script)");
292                    }
293                    return NULL;
294                }
295                Tcl_ResetResult(interp);
296            }
297        }
298    
299        if (pkgPtr->version == NULL) {
300            Tcl_AppendResult(interp, "can't find package ", name,
301                    (char *) NULL);
302            if (version != NULL) {
303                Tcl_AppendResult(interp, " ", version, (char *) NULL);
304            }
305            return NULL;
306        }
307    
308        /*
309         * At this point we know that the package is present.  Make sure that the
310         * provided version meets the current requirement.
311         */
312    
313        if (version == NULL) {
314            if (clientDataPtr) {
315                *clientDataPtr = pkgPtr->clientData;
316            }
317            return pkgPtr->version;
318        }
319        result = ComparePkgVersions(pkgPtr->version, version, &satisfies);
320        if ((satisfies && !exact) || (result == 0)) {
321            if (clientDataPtr) {
322                *clientDataPtr = pkgPtr->clientData;
323            }
324            return pkgPtr->version;
325        }
326        Tcl_AppendResult(interp, "version conflict for package \"",
327                name, "\": have ", pkgPtr->version, ", need ", version,
328                (char *) NULL);
329        return NULL;
330    }
331    
332    /*
333     *----------------------------------------------------------------------
334     *
335     * Tcl_PkgPresent / Tcl_PkgPresentEx --
336     *
337     *      Checks to see whether the specified package is present. If it
338     *      is not then no additional action is taken.
339     *
340     * Results:
341     *      If successful, returns the version string for the currently
342     *      provided version of the package, which may be different from
343     *      the "version" argument.  If the caller's requirements
344     *      cannot be met (e.g. the version requested conflicts with
345     *      a currently provided version), NULL is returned and an error
346     *      message is left in interp->result.
347     *
348     * Side effects:
349     *      None.
350     *
351     *----------------------------------------------------------------------
352     */
353    
354    char *
355    Tcl_PkgPresent(interp, name, version, exact)
356        Tcl_Interp *interp;         /* Interpreter in which package is now
357                                     * available. */
358        char *name;                 /* Name of desired package. */
359        char *version;              /* Version string for desired version;
360                                     * NULL means use the latest version
361                                     * available. */
362        int exact;                  /* Non-zero means that only the particular
363                                     * version given is acceptable. Zero means
364                                     * use the latest compatible version. */
365    {
366        return Tcl_PkgPresentEx(interp, name, version, exact, (ClientData *) NULL);
367    }
368    
369    char *
370    Tcl_PkgPresentEx(interp, name, version, exact, clientDataPtr)
371        Tcl_Interp *interp;         /* Interpreter in which package is now
372                                     * available. */
373        char *name;                 /* Name of desired package. */
374        char *version;              /* Version string for desired version;
375                                     * NULL means use the latest version
376                                     * available. */
377        int exact;                  /* Non-zero means that only the particular
378                                     * version given is acceptable. Zero means
379                                     * use the latest compatible version. */
380        ClientData *clientDataPtr;  /* Used to return the client data for this
381                                     * package. If it is NULL then the client
382                                     * data is not returned. This is unchanged
383                                     * if this call fails for any reason. */
384    {
385        Interp *iPtr = (Interp *) interp;
386        Tcl_HashEntry *hPtr;
387        Package *pkgPtr;
388        int satisfies, result;
389    
390        /*
391         * If an attempt is being made to load this into a standalone executable
392         * on a platform where backlinking is not supported then this must be
393         * a shared version of Tcl (Otherwise the load would have failed).
394         * Detect this situation by checking that this library has been correctly
395         * initialised. If it has not been then return immediately as nothing will
396         * work.
397         */
398        
399        if (!tclEmptyStringRep) {
400            Tcl_AppendResult(interp, "Cannot load package \"", name,
401                    "\" in standalone executable: This package is not ",
402                    "compiled with stub support", NULL);
403            return NULL;
404        }
405    
406        hPtr = Tcl_FindHashEntry(&iPtr->packageTable, name);
407        if (hPtr) {
408            pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
409            if (pkgPtr->version != NULL) {
410                
411                /*
412                 * At this point we know that the package is present.  Make sure
413                 * that the provided version meets the current requirement.
414                 */
415    
416                if (version == NULL) {
417                    if (clientDataPtr) {
418                        *clientDataPtr = pkgPtr->clientData;
419                    }
420                    
421                    return pkgPtr->version;
422                }
423                result = ComparePkgVersions(pkgPtr->version, version, &satisfies);
424                if ((satisfies && !exact) || (result == 0)) {
425                    if (clientDataPtr) {
426                        *clientDataPtr = pkgPtr->clientData;
427                    }
428        
429                    return pkgPtr->version;
430                }
431                Tcl_AppendResult(interp, "version conflict for package \"",
432                                 name, "\": have ", pkgPtr->version,
433                                 ", need ", version, (char *) NULL);
434                return NULL;
435            }
436        }
437    
438        if (version != NULL) {
439            Tcl_AppendResult(interp, "package ", name, " ", version,
440                             " is not present", (char *) NULL);
441        } else {
442            Tcl_AppendResult(interp, "package ", name, " is not present",
443                             (char *) NULL);
444        }
445        return NULL;
446    }
447    
448    /*
449     *----------------------------------------------------------------------
450     *
451     * Tcl_PackageObjCmd --
452     *
453     *      This procedure is invoked to process the "package" Tcl command.
454     *      See the user documentation for details on what it does.
455     *
456     * Results:
457     *      A standard Tcl result.
458     *
459     * Side effects:
460     *      See the user documentation.
461     *
462     *----------------------------------------------------------------------
463     */
464    
465            /* ARGSUSED */
466    int
467    Tcl_PackageObjCmd(dummy, interp, objc, objv)
468        ClientData dummy;                   /* Not used. */
469        Tcl_Interp *interp;                 /* Current interpreter. */
470        int objc;                           /* Number of arguments. */
471        Tcl_Obj *CONST objv[];      /* Argument objects. */
472    {
473        static char *pkgOptions[] = {
474            "forget", "ifneeded", "names", "present", "provide", "require",
475            "unknown", "vcompare", "versions", "vsatisfies", (char *) NULL
476        };
477        enum pkgOptions {
478            PKG_FORGET, PKG_IFNEEDED, PKG_NAMES, PKG_PRESENT,
479            PKG_PROVIDE, PKG_REQUIRE, PKG_UNKNOWN, PKG_VCOMPARE,
480            PKG_VERSIONS, PKG_VSATISFIES
481        };
482        Interp *iPtr = (Interp *) interp;
483        int optionIndex, exact, i, satisfies;
484        PkgAvail *availPtr, *prevPtr;
485        Package *pkgPtr;
486        Tcl_HashEntry *hPtr;
487        Tcl_HashSearch search;
488        Tcl_HashTable *tablePtr;
489        char *version, *argv2, *argv3, *argv4;
490    
491        if (objc < 2) {
492            Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?");
493            return TCL_ERROR;
494        }
495    
496        if (Tcl_GetIndexFromObj(interp, objv[1], pkgOptions, "option", 0,
497                &optionIndex) != TCL_OK) {
498            return TCL_ERROR;
499        }
500        switch ((enum pkgOptions) optionIndex) {
501            case PKG_FORGET: {
502                char *keyString;
503                for (i = 2; i < objc; i++) {
504                    keyString = Tcl_GetString(objv[i]);
505                    hPtr = Tcl_FindHashEntry(&iPtr->packageTable, keyString);
506                    if (hPtr == NULL) {
507                        return TCL_OK;
508                    }
509                    pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
510                    Tcl_DeleteHashEntry(hPtr);
511                    if (pkgPtr->version != NULL) {
512                        ckfree(pkgPtr->version);
513                    }
514                    while (pkgPtr->availPtr != NULL) {
515                        availPtr = pkgPtr->availPtr;
516                        pkgPtr->availPtr = availPtr->nextPtr;
517                        ckfree(availPtr->version);
518                        Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC);
519                        ckfree((char *) availPtr);
520                    }
521                    ckfree((char *) pkgPtr);
522                }
523                break;
524            }
525            case PKG_IFNEEDED: {
526                int length;
527                if ((objc != 4) && (objc != 5)) {
528                    Tcl_WrongNumArgs(interp, 2, objv, "package version ?script?");
529                    return TCL_ERROR;
530                }
531                argv3 = Tcl_GetString(objv[3]);
532                if (CheckVersion(interp, argv3) != TCL_OK) {
533                    return TCL_ERROR;
534                }
535                argv2 = Tcl_GetString(objv[2]);
536                if (objc == 4) {
537                    hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2);
538                    if (hPtr == NULL) {
539                        return TCL_OK;
540                    }
541                    pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
542                } else {
543                    pkgPtr = FindPackage(interp, argv2);
544                }
545                argv3 = Tcl_GetStringFromObj(objv[3], &length);
546                for (availPtr = pkgPtr->availPtr, prevPtr = NULL; availPtr != NULL;
547                     prevPtr = availPtr, availPtr = availPtr->nextPtr) {
548                    if (ComparePkgVersions(availPtr->version, argv3, (int *) NULL)
549                            == 0) {
550                        if (objc == 4) {
551                            Tcl_SetResult(interp, availPtr->script, TCL_VOLATILE);
552                            return TCL_OK;
553                        }
554                        Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC);
555                        break;
556                    }
557                }
558                if (objc == 4) {
559                    return TCL_OK;
560                }
561                if (availPtr == NULL) {
562                    availPtr = (PkgAvail *) ckalloc(sizeof(PkgAvail));
563                    availPtr->version = ckalloc((unsigned) (length + 1));
564                    strcpy(availPtr->version, argv3);
565                    if (prevPtr == NULL) {
566                        availPtr->nextPtr = pkgPtr->availPtr;
567                        pkgPtr->availPtr = availPtr;
568                    } else {
569                        availPtr->nextPtr = prevPtr->nextPtr;
570                        prevPtr->nextPtr = availPtr;
571                    }
572                }
573                argv4 = Tcl_GetStringFromObj(objv[4], &length);
574                availPtr->script = ckalloc((unsigned) (length + 1));
575                strcpy(availPtr->script, argv4);
576                break;
577            }
578            case PKG_NAMES: {
579                if (objc != 2) {
580                    Tcl_WrongNumArgs(interp, 2, objv, NULL);
581                    return TCL_ERROR;
582                }
583                tablePtr = &iPtr->packageTable;
584                for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL;
585                     hPtr = Tcl_NextHashEntry(&search)) {
586                    pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
587                    if ((pkgPtr->version != NULL) || (pkgPtr->availPtr != NULL)) {
588                        Tcl_AppendElement(interp, Tcl_GetHashKey(tablePtr, hPtr));
589                    }
590                }
591                break;
592            }
593            case PKG_PRESENT: {
594                if (objc < 3) {
595                    presentSyntax:
596                    Tcl_WrongNumArgs(interp, 2, objv, "?-exact? package ?version?");
597                    return TCL_ERROR;
598                }
599                argv2 = Tcl_GetString(objv[2]);
600                if ((argv2[0] == '-') && (strcmp(argv2, "-exact") == 0)) {
601                    exact = 1;
602                } else {
603                    exact = 0;
604                }
605                version = NULL;
606                if (objc == (4 + exact)) {
607                    version =  Tcl_GetString(objv[3 + exact]);
608                    if (CheckVersion(interp, version) != TCL_OK) {
609                        return TCL_ERROR;
610                    }
611                } else if ((objc != 3) || exact) {
612                    goto presentSyntax;
613                }
614                if (exact) {
615                    argv3 =  Tcl_GetString(objv[3]);
616                    version = Tcl_PkgPresent(interp, argv3, version, exact);
617                } else {
618                    version = Tcl_PkgPresent(interp, argv2, version, exact);
619                }
620                if (version == NULL) {
621                    return TCL_ERROR;
622                }
623                Tcl_SetResult(interp, version, TCL_VOLATILE);
624                break;
625            }
626            case PKG_PROVIDE: {
627                if ((objc != 3) && (objc != 4)) {
628                    Tcl_WrongNumArgs(interp, 2, objv, "package ?version?");
629                    return TCL_ERROR;
630                }
631                argv2 = Tcl_GetString(objv[2]);
632                if (objc == 3) {
633                    hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2);
634                    if (hPtr != NULL) {
635                        pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
636                        if (pkgPtr->version != NULL) {
637                            Tcl_SetResult(interp, pkgPtr->version, TCL_VOLATILE);
638                        }
639                    }
640                    return TCL_OK;
641                }
642                argv3 = Tcl_GetString(objv[3]);
643                if (CheckVersion(interp, argv3) != TCL_OK) {
644                    return TCL_ERROR;
645                }
646                return Tcl_PkgProvide(interp, argv2, argv3);
647            }
648            case PKG_REQUIRE: {
649                if (objc < 3) {
650                    requireSyntax:
651                    Tcl_WrongNumArgs(interp, 2, objv, "?-exact? package ?version?");
652                    return TCL_ERROR;
653                }
654                argv2 = Tcl_GetString(objv[2]);
655                if ((argv2[0] == '-') && (strcmp(argv2, "-exact") == 0)) {
656                    exact = 1;
657                } else {
658                    exact = 0;
659                }
660                version = NULL;
661                if (objc == (4 + exact)) {
662                    version =  Tcl_GetString(objv[3 + exact]);
663                    if (CheckVersion(interp, version) != TCL_OK) {
664                        return TCL_ERROR;
665                    }
666                } else if ((objc != 3) || exact) {
667                    goto requireSyntax;
668                }
669                if (exact) {
670                    argv3 =  Tcl_GetString(objv[3]);
671                    version = Tcl_PkgRequire(interp, argv3, version, exact);
672                } else {
673                    version = Tcl_PkgRequire(interp, argv2, version, exact);
674                }
675                if (version == NULL) {
676                    return TCL_ERROR;
677                }
678                Tcl_SetResult(interp, version, TCL_VOLATILE);
679                break;
680            }
681            case PKG_UNKNOWN: {
682                int length;
683                if (objc == 2) {
684                    if (iPtr->packageUnknown != NULL) {
685                        Tcl_SetResult(interp, iPtr->packageUnknown, TCL_VOLATILE);
686                    }
687                } else if (objc == 3) {
688                    if (iPtr->packageUnknown != NULL) {
689                        ckfree(iPtr->packageUnknown);
690                    }
691                    argv2 = Tcl_GetStringFromObj(objv[2], &length);
692                    if (argv2[0] == 0) {
693                        iPtr->packageUnknown = NULL;
694                    } else {
695                        iPtr->packageUnknown = (char *) ckalloc((unsigned)
696                                (length + 1));
697                        strcpy(iPtr->packageUnknown, argv2);
698                    }
699                } else {
700                    Tcl_WrongNumArgs(interp, 2, objv, "?command?");
701                    return TCL_ERROR;
702                }
703                break;
704            }
705            case PKG_VCOMPARE: {
706                if (objc != 4) {
707                    Tcl_WrongNumArgs(interp, 2, objv, "version1 version2");
708                    return TCL_ERROR;
709                }
710                argv3 = Tcl_GetString(objv[3]);
711                argv2 = Tcl_GetString(objv[2]);
712                if ((CheckVersion(interp, argv2) != TCL_OK)
713                        || (CheckVersion(interp, argv3) != TCL_OK)) {
714                    return TCL_ERROR;
715                }
716                Tcl_SetIntObj(Tcl_GetObjResult(interp),
717                        ComparePkgVersions(argv2, argv3, (int *) NULL));
718                break;
719            }
720            case PKG_VERSIONS: {
721                if (objc != 3) {
722                    Tcl_WrongNumArgs(interp, 2, objv, "package");
723                    return TCL_ERROR;
724                }
725                argv2 = Tcl_GetString(objv[2]);
726                hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2);
727                if (hPtr != NULL) {
728                    pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
729                    for (availPtr = pkgPtr->availPtr; availPtr != NULL;
730                         availPtr = availPtr->nextPtr) {
731                        Tcl_AppendElement(interp, availPtr->version);
732                    }
733                }
734                break;
735            }
736            case PKG_VSATISFIES: {
737                if (objc != 4) {
738                    Tcl_WrongNumArgs(interp, 2, objv, "version1 version2");
739                    return TCL_ERROR;
740                }
741                argv3 = Tcl_GetString(objv[3]);
742                argv2 = Tcl_GetString(objv[2]);
743                if ((CheckVersion(interp, argv2) != TCL_OK)
744                        || (CheckVersion(interp, argv3) != TCL_OK)) {
745                    return TCL_ERROR;
746                }
747                ComparePkgVersions(argv2, argv3, &satisfies);
748                Tcl_SetIntObj(Tcl_GetObjResult(interp), satisfies);
749                break;
750            }
751            default: {
752                panic("Tcl_PackageObjCmd: bad option index to pkgOptions");
753            }
754        }
755        return TCL_OK;
756    }
757    
758    /*
759     *----------------------------------------------------------------------
760     *
761     * FindPackage --
762     *
763     *      This procedure finds the Package record for a particular package
764     *      in a particular interpreter, creating a record if one doesn't
765     *      already exist.
766     *
767     * Results:
768     *      The return value is a pointer to the Package record for the
769     *      package.
770     *
771     * Side effects:
772     *      A new Package record may be created.
773     *
774     *----------------------------------------------------------------------
775     */
776    
777    static Package *
778    FindPackage(interp, name)
779        Tcl_Interp *interp;         /* Interpreter to use for package lookup. */
780        char *name;                 /* Name of package to fine. */
781    {
782        Interp *iPtr = (Interp *) interp;
783        Tcl_HashEntry *hPtr;
784        int new;
785        Package *pkgPtr;
786    
787        hPtr = Tcl_CreateHashEntry(&iPtr->packageTable, name, &new);
788        if (new) {
789            pkgPtr = (Package *) ckalloc(sizeof(Package));
790            pkgPtr->version = NULL;
791            pkgPtr->availPtr = NULL;
792            pkgPtr->clientData = NULL;
793            Tcl_SetHashValue(hPtr, pkgPtr);
794        } else {
795            pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
796        }
797        return pkgPtr;
798    }
799    
800    /*
801     *----------------------------------------------------------------------
802     *
803     * TclFreePackageInfo --
804     *
805     *      This procedure is called during interpreter deletion to
806     *      free all of the package-related information for the
807     *      interpreter.
808     *
809     * Results:
810     *      None.
811     *
812     * Side effects:
813     *      Memory is freed.
814     *
815     *----------------------------------------------------------------------
816     */
817    
818    void
819    TclFreePackageInfo(iPtr)
820        Interp *iPtr;               /* Interpereter that is being deleted. */
821    {
822        Package *pkgPtr;
823        Tcl_HashSearch search;
824        Tcl_HashEntry *hPtr;
825        PkgAvail *availPtr;
826    
827        for (hPtr = Tcl_FirstHashEntry(&iPtr->packageTable, &search);
828                hPtr != NULL;  hPtr = Tcl_NextHashEntry(&search)) {
829            pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
830            if (pkgPtr->version != NULL) {
831                ckfree(pkgPtr->version);
832            }
833            while (pkgPtr->availPtr != NULL) {
834                availPtr = pkgPtr->availPtr;
835                pkgPtr->availPtr = availPtr->nextPtr;
836                ckfree(availPtr->version);
837                Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC);
838                ckfree((char *) availPtr);
839            }
840            ckfree((char *) pkgPtr);
841        }
842        Tcl_DeleteHashTable(&iPtr->packageTable);
843        if (iPtr->packageUnknown != NULL) {
844            ckfree(iPtr->packageUnknown);
845        }
846    }
847    
848    /*
849     *----------------------------------------------------------------------
850     *
851     * CheckVersion --
852     *
853     *      This procedure checks to see whether a version number has
854     *      valid syntax.
855     *
856     * Results:
857     *      If string is a properly formed version number the TCL_OK
858     *      is returned.  Otherwise TCL_ERROR is returned and an error
859     *      message is left in the interp's result.
860     *
861     * Side effects:
862     *      None.
863     *
864     *----------------------------------------------------------------------
865     */
866    
867    static int
868    CheckVersion(interp, string)
869        Tcl_Interp *interp;         /* Used for error reporting. */
870        char *string;               /* Supposedly a version number, which is
871                                     * groups of decimal digits separated
872                                     * by dots. */
873    {
874        char *p = string;
875        char prevChar;
876        
877        if (!isdigit(UCHAR(*p))) {  /* INTL: digit */
878            goto error;
879        }
880        for (prevChar = *p, p++; *p != 0; p++) {
881            if (!isdigit(UCHAR(*p)) &&
882                    ((*p != '.') || (prevChar == '.'))) { /* INTL: digit */
883                goto error;
884            }
885            prevChar = *p;
886        }
887        if (prevChar != '.') {
888            return TCL_OK;
889        }
890    
891        error:
892        Tcl_AppendResult(interp, "expected version number but got \"",
893                string, "\"", (char *) NULL);
894        return TCL_ERROR;
895    }
896    
897    /*
898     *----------------------------------------------------------------------
899     *
900     * ComparePkgVersions --
901     *
902     *      This procedure compares two version numbers.
903     *
904     * Results:
905     *      The return value is -1 if v1 is less than v2, 0 if the two
906     *      version numbers are the same, and 1 if v1 is greater than v2.
907     *      If *satPtr is non-NULL, the word it points to is filled in
908     *      with 1 if v2 >= v1 and both numbers have the same major number
909     *      or 0 otherwise.
910     *
911     * Side effects:
912     *      None.
913     *
914     *----------------------------------------------------------------------
915     */
916    
917    static int
918    ComparePkgVersions(v1, v2, satPtr)
919        char *v1, *v2;              /* Versions strings, of form 2.1.3 (any
920                                     * number of version numbers). */
921        int *satPtr;                /* If non-null, the word pointed to is
922                                     * filled in with a 0/1 value.  1 means
923                                     * v1 "satisfies" v2:  v1 is greater than
924                                     * or equal to v2 and both version numbers
925                                     * have the same major number. */
926    {
927        int thisIsMajor, n1, n2;
928    
929        /*
930         * Each iteration of the following loop processes one number from
931         * each string, terminated by a ".".  If those numbers don't match
932         * then the comparison is over;  otherwise, we loop back for the
933         * next number.
934         */
935    
936        thisIsMajor = 1;
937        while (1) {
938            /*
939             * Parse one decimal number from the front of each string.
940             */
941    
942            n1 = n2 = 0;
943            while ((*v1 != 0) && (*v1 != '.')) {
944                n1 = 10*n1 + (*v1 - '0');
945                v1++;
946            }
947            while ((*v2 != 0) && (*v2 != '.')) {
948                n2 = 10*n2 + (*v2 - '0');
949                v2++;
950            }
951    
952            /*
953             * Compare and go on to the next version number if the
954             * current numbers match.
955             */
956    
957            if (n1 != n2) {
958                break;
959            }
960            if (*v1 != 0) {
961                v1++;
962            } else if (*v2 == 0) {
963                break;
964            }
965            if (*v2 != 0) {
966                v2++;
967            }
968            thisIsMajor = 0;
969        }
970        if (satPtr != NULL) {
971            *satPtr = (n1 == n2) || ((n1 > n2) && !thisIsMajor);
972        }
973        if (n1 > n2) {
974            return 1;
975        } else if (n1 == n2) {
976            return 0;
977        } else {
978            return -1;
979        }
980    }
981    
982    /* End of tclpkg.c */
Legend:
Removed from v.42  
changed lines
  Added in v.71
dashley@gmail.com
 ViewVC Help
Powered by ViewVC 1.1.25