diff options
Diffstat (limited to 'generic/tclStubLib.c')
| -rw-r--r-- | generic/tclStubLib.c | 148 |
1 files changed, 119 insertions, 29 deletions
diff --git a/generic/tclStubLib.c b/generic/tclStubLib.c index 1ab7ff3..1f5b436 100644 --- a/generic/tclStubLib.c +++ b/generic/tclStubLib.c @@ -1,20 +1,20 @@ -/* +/* * tclStubLib.c -- * - * Stub object that will be statically linked into extensions that wish + * Stub object that will be statically linked into extensions that want * to access Tcl. * * Copyright (c) 1998-1999 by Scriptics Corporation. * Copyright (c) 1998 Paul Duffin. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* - * We need to ensure that we use the stub macros so that this file contains - * no references to any of the stub functions. This will make it possible - * to build an extension that references Tcl_InitStubs but doesn't end up + * We need to ensure that we use the stub macros so that this file contains no + * references to any of the stub functions. This will make it possible to + * build an extension that references Tcl_InitStubs but doesn't end up * including the rest of the stub functions. */ @@ -24,46 +24,53 @@ #undef USE_TCL_STUB_PROCS #include "tclInt.h" -#include "tclPort.h" /* - * Ensure that Tcl_InitStubs is built as an exported symbol. The other stub - * functions should be built as non-exported symbols. + * Tcl_InitStubs and stub table pointers are built as exported symbols. */ TclStubs *tclStubsPtr = NULL; TclPlatStubs *tclPlatStubsPtr = NULL; TclIntStubs *tclIntStubsPtr = NULL; TclIntPlatStubs *tclIntPlatStubsPtr = NULL; - -static TclStubs * HasStubSupport _ANSI_ARGS_((Tcl_Interp *interp)); +TclTomMathStubs* tclTomMathStubsPtr = NULL; static TclStubs * -HasStubSupport (interp) - Tcl_Interp *interp; +HasStubSupport( + Tcl_Interp *interp) { Interp *iPtr = (Interp *) interp; if (iPtr->stubTable && (iPtr->stubTable->magic == TCL_STUB_MAGIC)) { return iPtr->stubTable; } - interp->result = "This interpreter does not support stubs-enabled extensions."; - interp->freeProc = TCL_STATIC; + interp->result = + "This interpreter does not support stubs-enabled extensions."; + interp->freeProc = TCL_STATIC; return NULL; } /* + * Use our own isdigit to avoid linking to libc on windows + */ + +static int isDigit(const int c) +{ + return (c >= '0' && c <= '9'); +} + +/* *---------------------------------------------------------------------- * * Tcl_InitStubs -- * - * Tries to initialise the stub table pointers and ensures that - * the correct version of Tcl is loaded. + * Tries to initialise the stub table pointers and ensures that the + * correct version of Tcl is loaded. * * Results: - * The actual version of Tcl that satisfies the request, or - * NULL to indicate that an error occurred. + * The actual version of Tcl that satisfies the request, or NULL to + * indicate that an error occurred. * * Side effects: * Sets the stub table pointers. @@ -76,18 +83,18 @@ HasStubSupport (interp) #endif CONST char * -Tcl_InitStubs (interp, version, exact) - Tcl_Interp *interp; - CONST char *version; - int exact; +Tcl_InitStubs( + Tcl_Interp *interp, + CONST char *version, + int exact) { CONST char *actualVersion = NULL; ClientData pkgData = NULL; /* - * We can't optimize this check by caching tclStubsPtr because - * that prevents apps from being able to load/unload Tcl dynamically - * multiple times. [Bug 615304] + * We can't optimize this check by caching tclStubsPtr because that + * prevents apps from being able to load/unload Tcl dynamically multiple + * times. [Bug 615304] */ tclStubsPtr = HasStubSupport(interp); @@ -95,10 +102,36 @@ Tcl_InitStubs (interp, version, exact) return NULL; } - actualVersion = Tcl_PkgRequireEx(interp, "Tcl", version, exact, &pkgData); + actualVersion = Tcl_PkgRequireEx(interp, "Tcl", version, 0, &pkgData); if (actualVersion == NULL) { return NULL; } + if (exact) { + CONST char *p = version; + int count = 0; + + while (*p) { + count += !isDigit(*p++); + } + if (count == 1) { + CONST char *q = actualVersion; + + p = version; + while (*p && (*p == *q)) { + p++; q++; + } + if (*p) { + /* Construct error message */ + Tcl_PkgRequireEx(interp, "Tcl", version, 1, NULL); + return NULL; + } + } else { + actualVersion = Tcl_PkgRequireEx(interp, "Tcl", version, 1, NULL); + if (actualVersion == NULL) { + return NULL; + } + } + } tclStubsPtr = (TclStubs*)pkgData; if (tclStubsPtr->hooks) { @@ -110,6 +143,63 @@ Tcl_InitStubs (interp, version, exact) tclIntStubsPtr = NULL; tclIntPlatStubsPtr = NULL; } - + return actualVersion; } + +/* + *---------------------------------------------------------------------- + * + * TclTomMathInitStubs -- + * + * Initializes the Stubs table for Tcl's subset of libtommath + * + * Results: + * Returns a standard Tcl result. + * + * This procedure should not be called directly, but rather through + * the TclTomMath_InitStubs macro, to insure that the Stubs table + * matches the header files used in compilation. + * + *---------------------------------------------------------------------- + */ + +#ifdef TclTomMathInitializeStubs +#undef TclTomMathInitializeStubs +#endif + +CONST char* +TclTomMathInitializeStubs( + Tcl_Interp* interp, /* Tcl interpreter */ + CONST char* version, /* Tcl version needed */ + int epoch, /* Stubs table epoch from the header files */ + int revision /* Stubs table revision number from the + * header files */ +) { + int exact = 0; + const char* packageName = "tcl::tommath"; + const char* errMsg = NULL; + ClientData pkgClientData = NULL; + const char* actualVersion = + Tcl_PkgRequireEx(interp, packageName, version, exact, &pkgClientData); + TclTomMathStubs* stubsPtr = (TclTomMathStubs*) pkgClientData; + if (actualVersion == NULL) { + return NULL; + } + if (pkgClientData == NULL) { + errMsg = "missing stub table pointer"; + } else if ((stubsPtr->tclBN_epoch)() != epoch) { + errMsg = "epoch number mismatch"; + } else if ((stubsPtr->tclBN_revision)() != revision) { + errMsg = "requires a later revision"; + } else { + tclTomMathStubsPtr = stubsPtr; + return actualVersion; + } + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "error loading ", packageName, + " (requested version ", version, + ", actual version ", actualVersion, + "): ", errMsg, NULL); + return NULL; +} |