util/src/TclTk/tcl8.6.12/pkgs/tdbc1.1.3/generic/tdbcStubLib.c

   1 /*
   2  * tdbcStubLib.c --
   3  *
   4  *      Stubs table initialization wrapper for Tcl DataBase Connectivity
   5  *      (TDBC).
   6  *
   7  * Copyright (c) 2008 by Kevin B. Kenny.
   8  *
   9  * Please refer to the file, 'license.terms' for the conditions on
  10  * redistribution of this file and for a DISCLAIMER OF ALL WARRANTIES.
  11  *
  12  * RCS: @(#) $Id$
  13  *
  14  *-----------------------------------------------------------------------------
  15  */
  16
  17 #include <tcl.h>
  18
  19 #define USE_TDBC_STUBS 1
  20 #include "tdbc.h"
  21
  22 MODULE_SCOPE const TdbcStubs *tdbcStubsPtr;
  23
  24 const TdbcStubs *tdbcStubsPtr = NULL;
  25
  26 /*
  27  *-----------------------------------------------------------------------------
  28  *
  29  * TdbcInitializeStubs --
  30  *
  31  *      Loads the Tdbc package and initializes its Stubs table pointer.
  32  *
  33  * Client code should not call this function directly; instead, it should
  34  * use the Tdbc_InitStubs macro.
  35  *
  36  * Results:
  37  *      Returns the actual version of the Tdbc package that has been
  38  *      loaded, or NULL if an error occurs.
  39  *
  40  * Side effects:
  41  *      Sets the Stubs table pointer, or stores an error message in the
  42  *      interpreter's result.
  43  *
  44  *-----------------------------------------------------------------------------
  45  */
  46
  47 const char*
  48 TdbcInitializeStubs(
  49     Tcl_Interp* interp,         /* Tcl interpreter */
  50     const char* version,        /* Version of TDBC requested */
  51     int epoch,                  /* Epoch number of the Stubs table */
  52     int revision                /* Revision number within the epoch */
  53 ) {
  54     const int exact = 0;        /* Set this to 1 to require exact version */
  55     const char* packageName = "tdbc";
  56                                 /* Name of the package */
  57     const char* errorMsg = NULL;
  58                                 /* Error message if an error occurs */
  59     ClientData clientData = NULL;
  60                                 /* Client data for the package */
  61     const char* actualVersion;  /* Actual version of the package */
  62     const TdbcStubs* stubsPtr;  /* Stubs table for the public API */
  63
  64     /* Load the package */
  65
  66     actualVersion =
  67         Tcl_PkgRequireEx(interp, packageName, version, exact, &clientData);
  68
  69     if (clientData == NULL) {
  70         Tcl_ResetResult(interp);
  71         Tcl_AppendResult(interp, "Error loading ", packageName, " package: "
  72                          "package not present, incomplete or misconfigured.",
  73                          (char*) NULL);
  74         return NULL;
  75     }
  76
  77     /* Test that all version information matches the request */
  78
  79     if (actualVersion == NULL) {
  80         return NULL;
  81     } else {
  82         stubsPtr = (const TdbcStubs*) clientData;
  83         if (stubsPtr->epoch != epoch) {
  84             errorMsg = "mismatched epoch number";
  85         } else if (stubsPtr->revision < revision) {
  86             errorMsg = "Stubs table provides too early a revision";
  87         } else {
  88
  89             /* Everything is ok. Return the package information */
  90
  91             tdbcStubsPtr = stubsPtr;
  92             return actualVersion;
  93         }
  94     }
  95
  96     /* Try to explain what went wrong when a mismatched version is found. */
  97
  98     Tcl_ResetResult(interp);
  99     Tcl_AppendResult(interp, "Error loading ", packageName, " package "
 100                      "(requested version \"", version, "\", loaded version \"",
 101                      actualVersion, "\"): ", errorMsg, (char*) NULL);
 102     return NULL;
 103
 104 }