Symaptic: os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclStubLib.c@bde4ae8d615e

     1 /*

     2  * tclStubLib.c --

     3  *

     4  *	Stub object that will be statically linked into extensions that wish

     5  *	to access Tcl.

     6  *

     7  * Copyright (c) 1998-1999 by Scriptics Corporation.

     8  * Copyright (c) 1998 Paul Duffin.

     9  *

    10  * See the file "license.terms" for information on usage and redistribution

    11  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.

    12  *

    13  * RCS: @(#) $Id: tclStubLib.c,v 1.6.2.1 2005/11/20 18:23:03 jenglish Exp $

    14  */

    16 /*

    17  * We need to ensure that we use the stub macros so that this file contains

    18  * no references to any of the stub functions.  This will make it possible

    19  * to build an extension that references Tcl_InitStubs but doesn't end up

    20  * including the rest of the stub functions.

    21  */

    23 #ifndef USE_TCL_STUBS

    24 #define USE_TCL_STUBS

    25 #endif

    26 #undef USE_TCL_STUB_PROCS

    28 #include "tclInt.h"

    29 #include "tclPort.h"

    31 /*

    32  * Ensure that Tcl_InitStubs is built as an exported symbol.  The other stub

    33  * functions should be built as non-exported symbols.

    34  */

    36 TclStubs *tclStubsPtr = NULL;

    37 TclPlatStubs *tclPlatStubsPtr = NULL;

    38 TclIntStubs *tclIntStubsPtr = NULL;

    39 TclIntPlatStubs *tclIntPlatStubsPtr = NULL;

    41 static TclStubs *	HasStubSupport _ANSI_ARGS_((Tcl_Interp *interp));

    43 static TclStubs *

    44 HasStubSupport (interp)

    45     Tcl_Interp *interp;

    46 {

    47     Interp *iPtr = (Interp *) interp;

    49     if (iPtr->stubTable && (iPtr->stubTable->magic == TCL_STUB_MAGIC)) {

    50 	return iPtr->stubTable;

    51     }

    52     interp->result = "This interpreter does not support stubs-enabled extensions.";

    53     interp->freeProc = TCL_STATIC;

    55     return NULL;

    56 }

    58 /*

    59  *----------------------------------------------------------------------

    60  *

    61  * Tcl_InitStubs --

    62  *

    63  *	Tries to initialise the stub table pointers and ensures that

    64  *	the correct version of Tcl is loaded.

    65  *

    66  * Results:

    67  *	The actual version of Tcl that satisfies the request, or

    68  *	NULL to indicate that an error occurred.

    69  *

    70  * Side effects:

    71  *	Sets the stub table pointers.

    72  *

    73  *----------------------------------------------------------------------

    74  */

    76 #ifdef Tcl_InitStubs

    77 #undef Tcl_InitStubs

    78 #endif

    80 CONST char *

    81 Tcl_InitStubs (interp, version, exact)

    82     Tcl_Interp *interp;

    83     CONST char *version;

    84     int exact;

    85 {

    86     CONST char *actualVersion = NULL;

    87     ClientData pkgData = NULL;

    89     /*

    90      * We can't optimize this check by caching tclStubsPtr because

    91      * that prevents apps from being able to load/unload Tcl dynamically

    92      * multiple times. [Bug 615304]

    93      */

    95     tclStubsPtr = HasStubSupport(interp);

    96     if (!tclStubsPtr) {

    97 	return NULL;

    98     }

   100     actualVersion = Tcl_PkgRequireEx(interp, "Tcl", version, exact, &pkgData);

   101     if (actualVersion == NULL) {

   102 	return NULL;

   103     }

   104     tclStubsPtr = (TclStubs*)pkgData;

   106     if (tclStubsPtr->hooks) {

   107 	tclPlatStubsPtr = tclStubsPtr->hooks->tclPlatStubs;

   108 	tclIntStubsPtr = tclStubsPtr->hooks->tclIntStubs;

   109 	tclIntPlatStubsPtr = tclStubsPtr->hooks->tclIntPlatStubs;

   110     } else {

   111 	tclPlatStubsPtr = NULL;

   112 	tclIntStubsPtr = NULL;

   113 	tclIntPlatStubsPtr = NULL;

   114     }

   116     return actualVersion;

   117 }

author	sl@SLION-WIN7.fritz.box
	Fri, 15 Jun 2012 03:10:57 +0200
changeset 0	bde4ae8d615e
permissions	-rw-r--r--