Posted to tcl by stevel at Sun Jan 13 04:20:21 GMT 2008view raw
- /*
- * pre-load a shared library
- * - for situations where a Tcl package depends on another library
- * - will be superceded by the functionality in TIP #239
- * - based on tclLoad.c from Tcl 8.4.13 and MyInitTclStubs from Critcl
- */
- #include "tcl.h"
- TclStubs *tclStubsPtr;
- TclPlatStubs *tclPlatStubsPtr;
- struct TclIntStubs *tclIntStubsPtr;
- struct TclIntPlatStubs *tclIntPlatStubsPtr;
- static int
- MyInitTclStubs (Tcl_Interp *ip)
- {
- typedef struct {
- char *result;
- Tcl_FreeProc *freeProc;
- int errorLine;
- TclStubs *stubTable;
- } HeadOfInterp;
- HeadOfInterp *hoi = (HeadOfInterp*) ip;
- if (hoi->stubTable == NULL || hoi->stubTable->magic != TCL_STUB_MAGIC) {
- ip->result = "This extension requires stubs-support.";
- ip->freeProc = TCL_STATIC;
- return 0;
- }
- tclStubsPtr = hoi->stubTable;
- if (Tcl_PkgRequire(ip, "Tcl", "8.1", 0) == NULL) {
- tclStubsPtr = NULL;
- return 0;
- }
- if (tclStubsPtr->hooks != NULL) {
- tclPlatStubsPtr = tclStubsPtr->hooks->tclPlatStubs;
- tclIntStubsPtr = tclStubsPtr->hooks->tclIntStubs;
- tclIntPlatStubsPtr = tclStubsPtr->hooks->tclIntPlatStubs;
- }
- return 1;
- }
- #ifdef WIN32
- #include <windows.h>
- typedef struct PreloadInfo {
- Tcl_Obj *dir;
- Tcl_LoadHandle handle;
- } PreloadInfo;
- static void
- removeDLLCopy(ClientData clientData) {
- PreloadInfo *preload = (PreloadInfo *) clientData;
- Tcl_Obj *dir = preload->dir;
- Tcl_LoadHandle handle = preload->handle;
- Tcl_Obj *errorPtr;
- if (FreeLibrary((HINSTANCE) handle) \
- && (Tcl_FSRemoveDirectory(dir, 1, &errorPtr) != TCL_OK)) {
- fprintf(stderr, "error removing dir = %s\n", Tcl_GetString(errorPtr));
- }
- }
- #endif
- TCL_DECLARE_MUTEX(packageMutex)
- static int
- Critcl_Preload(
- ClientData dummy,
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *objv[])
- {
- int code;
- Tcl_PackageInitProc *proc1, *proc2;
- Tcl_LoadHandle loadHandle;
- Tcl_FSUnloadFileProc *unLoadProcPtr = NULL;
- Tcl_Filesystem *fsPtr;
- PreloadInfo *preload = NULL;
- if (objc != 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "fileName");
- return TCL_ERROR;
- }
- if (Tcl_FSConvertToPathType(interp, objv[1]) != TCL_OK) {
- return TCL_ERROR;
- }
- #ifdef WIN32
- // if the filesystem holding the dll doesn't support direct loading
- // we need to copy it to a temporary directory and load it from there
- // - critcl2::precopy is defined in critcl/lib/app-critcl/runtime.tcl
- if ((fsPtr = Tcl_FSGetFileSystemForPath(objv[1])) != NULL \
- && fsPtr->loadFileProc == NULL) {
- int len;
- Tcl_Obj *dirs;
- objv[0] = Tcl_NewStringObj("::critcl2::precopy", -1);
- if ((code = Tcl_EvalObjv(interp, 2, objv, 0)) != TCL_OK) {
- Tcl_SetErrorCode(interp, "could not preload ",
- Tcl_GetString(objv[1]), 0);
- return TCL_ERROR;
- }
- objv[1] = Tcl_GetObjResult(interp);
- Tcl_IncrRefCount(objv[1]);
- dirs = Tcl_FSSplitPath(objv[1], &len);
- preload = (PreloadInfo *) ckalloc(sizeof(PreloadInfo));
- preload->dir = Tcl_FSJoinPath(dirs, --len);
- Tcl_IncrRefCount(preload->dir);
- }
- #endif
- Tcl_MutexLock(&packageMutex);
- code = Tcl_FSLoadFile(interp, objv[1], NULL, NULL, NULL, NULL,
- &loadHandle, &unLoadProcPtr);
- Tcl_MutexUnlock(&packageMutex);
- #ifdef WIN32
- if (preload) {
- preload->handle = loadHandle;
- Tcl_CreateExitHandler(removeDLLCopy, (ClientData) preload);
- }
- #endif
- return code;
- }
- DLLEXPORT int
- Preload_Init(Tcl_Interp *interp)
- {
- if (!MyInitTclStubs(interp))
- return TCL_ERROR;
- // the Tcl command can't be "preload" because the Tcl source
- // might be copied into the target package (so Tcl procs are
- // available) and we want critcl::preload to then be a no-op
- // because the preloading is done from the loadlib command when
- // the target package is loaded
- Tcl_CreateObjCommand(interp, "::critcl2::preload", Critcl_Preload, NULL, 0);
- return 0;
- }
- DLLEXPORT int
- Preload_SafeInit(Tcl_Interp *interp)
- {
- if (!MyInitTclStubs(interp))
- return TCL_ERROR;
- Tcl_CreateObjCommand(interp, "::critcl2::preload", Critcl_Preload, NULL, 0);
- return 0;
- }
- DLLEXPORT int
- Preload_Unload(Tcl_Interp *interp) {}
- DLLEXPORT int
- Preload_SafeUnload(Tcl_Interp *interp) {}