Merged stubs changes into mainline for 8.0

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);