Import Tcl 8.6.12

pkgs/tdbc1.1.3/generic/tdbcStubLib.c

@@ -0,0 +1,104 @@
+/*
+ * tdbcStubLib.c --
+ *
+ *	Stubs table initialization wrapper for Tcl DataBase Connectivity
+ *	(TDBC).
+ *
+ * Copyright (c) 2008 by Kevin B. Kenny.
+ *
+ * Please refer to the file, 'license.terms' for the conditions on
+ * redistribution of this file and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * RCS: @(#) $Id$
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+#include <tcl.h>
+
+#define USE_TDBC_STUBS 1
+#include "tdbc.h"
+
+MODULE_SCOPE const TdbcStubs *tdbcStubsPtr;
+
+const TdbcStubs *tdbcStubsPtr = NULL;
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * TdbcInitializeStubs --
+ *
+ *	Loads the Tdbc package and initializes its Stubs table pointer.
+ *
+ * Client code should not call this function directly; instead, it should
+ * use the Tdbc_InitStubs macro.
+ *
+ * Results:
+ *	Returns the actual version of the Tdbc package that has been
+ *	loaded, or NULL if an error occurs.
+ *
+ * Side effects:
+ *	Sets the Stubs table pointer, or stores an error message in the
+ *	interpreter's result.
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+const char*
+TdbcInitializeStubs(
+    Tcl_Interp* interp,		/* Tcl interpreter */
+    const char* version,	/* Version of TDBC requested */
+    int epoch,			/* Epoch number of the Stubs table */
+    int revision		/* Revision number within the epoch */
+) {
+    const int exact = 0;	/* Set this to 1 to require exact version */
+    const char* packageName = "tdbc";
+				/* Name of the package */
+    const char* errorMsg = NULL;
+				/* Error message if an error occurs */
+    ClientData clientData = NULL;
+				/* Client data for the package */
+    const char* actualVersion;  /* Actual version of the package */
+    const TdbcStubs* stubsPtr;	/* Stubs table for the public API */
+
+    /* Load the package */
+
+    actualVersion =
+	Tcl_PkgRequireEx(interp, packageName, version, exact, &clientData);
+
+    if (clientData == NULL) {
+	Tcl_ResetResult(interp);
+	Tcl_AppendResult(interp, "Error loading ", packageName, " package: "
+			 "package not present, incomplete or misconfigured.",
+			 (char*) NULL);
+	return NULL;
+    }
+
+    /* Test that all version information matches the request */
+
+    if (actualVersion == NULL) {
+	return NULL;
+    } else {
+	stubsPtr = (const TdbcStubs*) clientData;
+	if (stubsPtr->epoch != epoch) {
+	    errorMsg = "mismatched epoch number";
+	} else if (stubsPtr->revision < revision) {
+	    errorMsg = "Stubs table provides too early a revision";
+	} else {
+
+	    /* Everything is ok. Return the package information */
+
+	    tdbcStubsPtr = stubsPtr;
+	    return actualVersion;
+	}
+    }
+
+    /* Try to explain what went wrong when a mismatched version is found. */
+
+    Tcl_ResetResult(interp);
+    Tcl_AppendResult(interp, "Error loading ", packageName, " package "
+		     "(requested version \"", version, "\", loaded version \"",
+		     actualVersion, "\"): ", errorMsg, (char*) NULL);
+    return NULL;
+
+}