summaryrefslogtreecommitdiffstats
path: root/generic/tclPkg.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclPkg.c')
-rw-r--r--generic/tclPkg.c214
1 files changed, 208 insertions, 6 deletions
diff --git a/generic/tclPkg.c b/generic/tclPkg.c
index 883b092..97a99e8 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.3 1999/03/10 05:52:49 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);