diff options
Diffstat (limited to 'generic/tclPkg.c')
| -rw-r--r-- | generic/tclPkg.c | 836 |
1 files changed, 409 insertions, 427 deletions
diff --git a/generic/tclPkg.c b/generic/tclPkg.c index a58feb4..397acd9 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -1,48 +1,48 @@ -/* +/* * tclPkg.c -- * - * This file implements package and version control for Tcl via - * the "package" command and a few C APIs. + * 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. + * 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.11 2004/10/06 15:59:25 dgp Exp $ + * RCS: @(#) $Id: tclPkg.c,v 1.12 2005/07/19 22:45:35 dkf 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. + * 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. */ + 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). + * 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. */ + * (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; @@ -52,9 +52,8 @@ typedef struct Package { 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 int ComparePkgVersions _ANSI_ARGS_((CONST char *v1, + CONST char *v2, int *satPtr)); static Package * FindPackage _ANSI_ARGS_((Tcl_Interp *interp, CONST char *name)); @@ -63,20 +62,18 @@ static Package * FindPackage _ANSI_ARGS_((Tcl_Interp *interp, * * 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. + * 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. + * 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. + * The interpreter remembers that this package is available, so that no + * other version of the package may be provided for the interpreter. * *---------------------------------------------------------------------- */ @@ -97,8 +94,8 @@ Tcl_PkgProvideEx(interp, name, version, clientData) * 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) */ + ClientData clientData; /* clientdata for this package (normally used + * for C callback function table) */ { Package *pkgPtr; @@ -125,26 +122,24 @@ Tcl_PkgProvideEx(interp, name, version, clientData) * * 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. + * 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. + * 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. + * The script from some previous "package ifneeded" command may be + * invoked to provide the package. * *---------------------------------------------------------------------- */ @@ -154,12 +149,11 @@ 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. */ + 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. */ + * version given is acceptable. Zero means use + * the latest compatible version. */ { return Tcl_PkgRequireEx(interp, name, version, exact, (ClientData *) NULL); } @@ -169,16 +163,15 @@ 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. */ + 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. */ + * 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. 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; @@ -188,85 +181,81 @@ Tcl_PkgRequireEx(interp, name, version, exact, clientDataPtr) /* * 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 + * 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. + * 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. + * 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.) + * 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. + * 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. + * 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; + 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. + * 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++) { @@ -279,7 +268,7 @@ Tcl_PkgRequireEx(interp, name, version, exact, clientDataPtr) * 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) { @@ -302,11 +291,11 @@ Tcl_PkgRequireEx(interp, name, version, exact, clientDataPtr) if (bestPtr != NULL) { /* * We found an ifneeded script for the package. Be careful while - * executing it: this could cause reentrancy, so (a) protect the + * 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); @@ -325,8 +314,8 @@ Tcl_PkgRequireEx(interp, name, version, exact, clientDataPtr) /* * 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). + * command, invoke it (but only on the first pass; after that, we + * should not get here in the first place). */ if (pass > 1) { @@ -371,7 +360,7 @@ Tcl_PkgRequireEx(interp, name, version, exact, clientDataPtr) */ if (version == NULL) { - if (clientDataPtr) { + if (clientDataPtr) { *clientDataPtr = pkgPtr->clientData; } return pkgPtr->version; @@ -391,19 +380,18 @@ Tcl_PkgRequireEx(interp, name, version, exact, clientDataPtr) /* *---------------------------------------------------------------------- - * + *q * Tcl_PkgPresent / Tcl_PkgPresentEx -- * - * Checks to see whether the specified package is present. If it - * is not then no additional action is taken. + * 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. + * 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. @@ -416,12 +404,11 @@ 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. */ + 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. */ + * version given is acceptable. Zero means use + * the latest compatible version. */ { return Tcl_PkgPresentEx(interp, name, version, exact, (ClientData *) NULL); } @@ -431,16 +418,15 @@ 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. */ + 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. */ + * 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. 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; @@ -451,9 +437,8 @@ Tcl_PkgPresentEx(interp, name, version, exact, clientDataPtr) if (hPtr) { pkgPtr = (Package *) Tcl_GetHashValue(hPtr); if (pkgPtr->version != NULL) { - /* - * At this point we know that the package is present. Make sure + * At this point we know that the package is present. Make sure * that the provided version meets the current requirement. */ @@ -461,7 +446,7 @@ Tcl_PkgPresentEx(interp, name, version, exact, clientDataPtr) if (clientDataPtr) { *clientDataPtr = pkgPtr->clientData; } - + return pkgPtr->version; } result = ComparePkgVersions(pkgPtr->version, version, &satisfies); @@ -469,22 +454,22 @@ Tcl_PkgPresentEx(interp, name, version, exact, clientDataPtr) if (clientDataPtr) { *clientDataPtr = pkgPtr->clientData; } - + return pkgPtr->version; } - Tcl_AppendResult(interp, "version conflict for package \"", - name, "\": have ", pkgPtr->version, - ", need ", version, (char *) NULL); + 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); + " is not present", (char *) NULL); } else { Tcl_AppendResult(interp, "package ", name, " is not present", - (char *) NULL); + (char *) NULL); } return NULL; } @@ -494,8 +479,8 @@ Tcl_PkgPresentEx(interp, name, version, exact, clientDataPtr) * * Tcl_PackageObjCmd -- * - * This procedure is invoked to process the "package" Tcl command. - * See the user documentation for details on what it does. + * 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. @@ -509,9 +494,9 @@ Tcl_PkgPresentEx(interp, name, version, exact, clientDataPtr) /* ARGSUSED */ int Tcl_PackageObjCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { static CONST char *pkgOptions[] = { @@ -534,7 +519,7 @@ Tcl_PackageObjCmd(dummy, interp, objc, objv) char *argv2, *argv3, *argv4; if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?"); + Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?"); return TCL_ERROR; } @@ -543,259 +528,252 @@ Tcl_PackageObjCmd(dummy, interp, objc, objv) 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; - 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; - } + 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; } - if (objc == 4) { - return TCL_OK; + pkgPtr = (Package *) Tcl_GetHashValue(hPtr); + Tcl_DeleteHashEntry(hPtr); + if (pkgPtr->version != NULL) { + ckfree(pkgPtr->version); } - 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; - } + while (pkgPtr->availPtr != NULL) { + availPtr = pkgPtr->availPtr; + pkgPtr->availPtr = availPtr->nextPtr; + ckfree(availPtr->version); + Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC); + ckfree((char *) availPtr); } - argv4 = Tcl_GetStringFromObj(objv[4], &length); - availPtr->script = ckalloc((unsigned) (length + 1)); - strcpy(availPtr->script, argv4); - break; + ckfree((char *) pkgPtr); } - 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; + break; + } + case PKG_IFNEEDED: { + int length; + + if ((objc != 4) && (objc != 5)) { + Tcl_WrongNumArgs(interp, 2, objv, "package version ?script?"); + return TCL_ERROR; } - 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; + argv3 = Tcl_GetString(objv[3]); + if (CheckVersion(interp, argv3) != TCL_OK) { + return TCL_ERROR; } - 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); - } - } + argv2 = Tcl_GetString(objv[2]); + if (objc == 4) { + hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2); + if (hPtr == NULL) { return TCL_OK; } - argv3 = Tcl_GetString(objv[3]); - if (CheckVersion(interp, argv3) != TCL_OK) { - return TCL_ERROR; - } - return Tcl_PkgProvide(interp, argv2, argv3); + pkgPtr = (Package *) Tcl_GetHashValue(hPtr); + } else { + pkgPtr = FindPackage(interp, argv2); } - 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; + 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; } - } else if ((objc != 3) || exact) { - goto requireSyntax; + Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC); + break; } - 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); - } + 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 { - Tcl_WrongNumArgs(interp, 2, objv, "?command?"); - return TCL_ERROR; + availPtr->nextPtr = prevPtr->nextPtr; + prevPtr->nextPtr = availPtr; } - 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; + 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)); } - Tcl_SetObjResult(interp, Tcl_NewIntObj( - ComparePkgVersions(argv2, argv3, (int *) NULL))); - break; } - case PKG_VERSIONS: { - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "package"); + 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; } - argv2 = Tcl_GetString(objv[2]); + } 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); - for (availPtr = pkgPtr->availPtr; availPtr != NULL; - availPtr = availPtr->nextPtr) { - Tcl_AppendElement(interp, availPtr->version); + if (pkgPtr->version != NULL) { + Tcl_SetResult(interp, pkgPtr->version, TCL_VOLATILE); } } - break; + 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; } - case PKG_VSATISFIES: { - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "version1 version2"); + version = NULL; + if (objc == (4 + exact)) { + version = Tcl_GetString(objv[3 + exact]); + if (CheckVersion(interp, version) != TCL_OK) { 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; + } 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); } - ComparePkgVersions(argv2, argv3, &satisfies); - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(satisfies)); - break; + } 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_SetObjResult(interp, Tcl_NewIntObj( + ComparePkgVersions(argv2, argv3, (int *) NULL))); + break; + case PKG_VERSIONS: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "package"); + return TCL_ERROR; } - default: { - Tcl_Panic("Tcl_PackageObjCmd: bad option index to pkgOptions"); + 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_SetObjResult(interp, Tcl_NewBooleanObj(satisfies)); + break; + default: + Tcl_Panic("Tcl_PackageObjCmd: bad option index to pkgOptions"); } return TCL_OK; } @@ -805,13 +783,12 @@ Tcl_PackageObjCmd(dummy, interp, objc, objv) * * FindPackage -- * - * This procedure finds the Package record for a particular package - * in a particular interpreter, creating a record if one doesn't - * already exist. + * 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. + * The return value is a pointer to the Package record for the package. * * Side effects: * A new Package record may be created. @@ -847,9 +824,8 @@ FindPackage(interp, name) * * TclFreePackageInfo -- * - * This procedure is called during interpreter deletion to - * free all of the package-related information for the - * interpreter. + * This procedure is called during interpreter deletion to free all of + * the package-related information for the interpreter. * * Results: * None. @@ -895,13 +871,13 @@ TclFreePackageInfo(iPtr) * * CheckVersion -- * - * This procedure checks to see whether a version number has - * valid syntax. + * 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. + * 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. @@ -913,12 +889,12 @@ 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. */ + * groups of decimal digits separated by + * dots. */ { CONST char *p = string; char prevChar; - + if (!isdigit(UCHAR(*p))) { /* INTL: digit */ goto error; } @@ -933,9 +909,9 @@ CheckVersion(interp, string) return TCL_OK; } - error: - Tcl_AppendResult(interp, "expected version number but got \"", - string, "\"", (char *) NULL); + error: + Tcl_AppendResult(interp, "expected version number but got \"", string, + "\"", (char *) NULL); return TCL_ERROR; } @@ -947,11 +923,10 @@ CheckVersion(interp, string) * 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. + * 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. @@ -962,21 +937,20 @@ CheckVersion(interp, string) 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. */ + 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. + * 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; @@ -996,8 +970,8 @@ ComparePkgVersions(v1, v2, satPtr) } /* - * Compare and go on to the next version number if the - * current numbers match. + * Compare and go on to the next version number if the current numbers + * match. */ if (n1 != n2) { @@ -1024,3 +998,11 @@ ComparePkgVersions(v1, v2, satPtr) return -1; } } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ |