diff options
Diffstat (limited to 'generic/tclPkg.c')
| -rw-r--r-- | generic/tclPkg.c | 214 |
1 files changed, 208 insertions, 6 deletions
diff --git a/generic/tclPkg.c b/generic/tclPkg.c index 883b092..dec76c7 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -9,7 +9,7 @@ * 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.2 1998/09/14 18:40:01 stanton Exp $ + * RCS: @(#) $Id: tclPkg.c,v 1.2.4.1 1999/03/03 00:38:42 stanton Exp $ */ #include "tclInt.h" @@ -43,6 +43,7 @@ typedef struct Package { * exist in this interpreter yet. */ PkgAvail *availPtr; /* First in list of all available versions * of this package. */ + ClientData clientData; /* Client data. */ } Package; /* @@ -59,7 +60,7 @@ static Package * FindPackage _ANSI_ARGS_((Tcl_Interp *interp, /* *---------------------------------------------------------------------- * - * Tcl_PkgProvide -- + * 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 @@ -86,12 +87,25 @@ Tcl_PkgProvide(interp, name, version) 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) { @@ -105,7 +119,7 @@ Tcl_PkgProvide(interp, name, version) /* *---------------------------------------------------------------------- * - * Tcl_PkgRequire -- + * 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 @@ -143,6 +157,25 @@ Tcl_PkgRequire(interp, name, version, exact) * 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; @@ -150,6 +183,22 @@ Tcl_PkgRequire(interp, name, version, exact) 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 @@ -253,15 +302,23 @@ Tcl_PkgRequire(interp, name, version, exact) } /* - * At this point we now that the package is present. Make sure that the + * 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 \"", @@ -273,6 +330,122 @@ Tcl_PkgRequire(interp, name, version, exact) /* *---------------------------------------------------------------------- * + * 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_PackageCmd -- * * This procedure is invoked to process the "package" Tcl command. @@ -394,7 +567,35 @@ Tcl_PackageCmd(dummy, interp, argc, argv) Tcl_AppendElement(interp, Tcl_GetHashKey(tablePtr, hPtr)); } } - } else if ((c == 'p') && (strncmp(argv[1], "provide", length) == 0)) { + } else if ((c == 'p') && (strncmp(argv[1], "present", length) == 0) + && (length >=3)) { + if (argc < 3) { + presentSyntax: + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " present ?-exact? package ?version?\"", (char *) NULL); + return TCL_ERROR; + } + if ((argv[2][0] == '-') && (strcmp(argv[2], "-exact") == 0)) { + exact = 1; + } else { + exact = 0; + } + version = NULL; + if (argc == (4+exact)) { + version = argv[3+exact]; + if (CheckVersion(interp, version) != TCL_OK) { + return TCL_ERROR; + } + } else if ((argc != 3) || exact) { + goto presentSyntax; + } + version = Tcl_PkgPresent(interp, argv[2+exact], version, exact); + if (version == NULL) { + return TCL_ERROR; + } + Tcl_SetResult(interp, version, TCL_VOLATILE); + } else if ((c == 'p') && (strncmp(argv[1], "provide", length) == 0) + && (length >=3)) { if ((argc != 3) && (argc != 4)) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " provide package ?version?\"", (char *) NULL); @@ -506,7 +707,7 @@ Tcl_PackageCmd(dummy, interp, argc, argv) } else { Tcl_AppendResult(interp, "bad option \"", argv[1], "\": should be forget, ifneeded, names, ", - "provide, require, unknown, vcompare, ", + "present, provide, require, unknown, vcompare, ", "versions, or vsatisfies", (char *) NULL); return TCL_ERROR; } @@ -547,6 +748,7 @@ FindPackage(interp, name) pkgPtr = (Package *) ckalloc(sizeof(Package)); pkgPtr->version = NULL; pkgPtr->availPtr = NULL; + pkgPtr->clientData = NULL; Tcl_SetHashValue(hPtr, pkgPtr); } else { pkgPtr = (Package *) Tcl_GetHashValue(hPtr); |