Posted to tcl by stevel at Sun Jan 13 04:20:21 GMT 2008view raw

  1. /*
  2. * pre-load a shared library
  3. * - for situations where a Tcl package depends on another library
  4. * - will be superceded by the functionality in TIP #239
  5. * - based on tclLoad.c from Tcl 8.4.13 and MyInitTclStubs from Critcl
  6. */
  7.  
  8. #include "tcl.h"
  9.  
  10. TclStubs *tclStubsPtr;
  11. TclPlatStubs *tclPlatStubsPtr;
  12. struct TclIntStubs *tclIntStubsPtr;
  13. struct TclIntPlatStubs *tclIntPlatStubsPtr;
  14.  
  15. static int
  16. MyInitTclStubs (Tcl_Interp *ip)
  17. {
  18. typedef struct {
  19. char *result;
  20. Tcl_FreeProc *freeProc;
  21. int errorLine;
  22. TclStubs *stubTable;
  23. } HeadOfInterp;
  24.  
  25. HeadOfInterp *hoi = (HeadOfInterp*) ip;
  26.  
  27. if (hoi->stubTable == NULL || hoi->stubTable->magic != TCL_STUB_MAGIC) {
  28. ip->result = "This extension requires stubs-support.";
  29. ip->freeProc = TCL_STATIC;
  30. return 0;
  31. }
  32.  
  33. tclStubsPtr = hoi->stubTable;
  34.  
  35. if (Tcl_PkgRequire(ip, "Tcl", "8.1", 0) == NULL) {
  36. tclStubsPtr = NULL;
  37. return 0;
  38. }
  39.  
  40. if (tclStubsPtr->hooks != NULL) {
  41. tclPlatStubsPtr = tclStubsPtr->hooks->tclPlatStubs;
  42. tclIntStubsPtr = tclStubsPtr->hooks->tclIntStubs;
  43. tclIntPlatStubsPtr = tclStubsPtr->hooks->tclIntPlatStubs;
  44. }
  45.  
  46. return 1;
  47. }
  48.  
  49. #ifdef WIN32
  50.  
  51. #include <windows.h>
  52.  
  53. typedef struct PreloadInfo {
  54. Tcl_Obj *dir;
  55. Tcl_LoadHandle handle;
  56. } PreloadInfo;
  57.  
  58. static void
  59. removeDLLCopy(ClientData clientData) {
  60. PreloadInfo *preload = (PreloadInfo *) clientData;
  61. Tcl_Obj *dir = preload->dir;
  62. Tcl_LoadHandle handle = preload->handle;
  63. Tcl_Obj *errorPtr;
  64.  
  65. if (FreeLibrary((HINSTANCE) handle) \
  66. && (Tcl_FSRemoveDirectory(dir, 1, &errorPtr) != TCL_OK)) {
  67. fprintf(stderr, "error removing dir = %s\n", Tcl_GetString(errorPtr));
  68. }
  69. }
  70.  
  71. #endif
  72.  
  73. TCL_DECLARE_MUTEX(packageMutex)
  74.  
  75. static int
  76. Critcl_Preload(
  77. ClientData dummy,
  78. Tcl_Interp *interp,
  79. int objc,
  80. Tcl_Obj *objv[])
  81. {
  82. int code;
  83. Tcl_PackageInitProc *proc1, *proc2;
  84. Tcl_LoadHandle loadHandle;
  85. Tcl_FSUnloadFileProc *unLoadProcPtr = NULL;
  86. Tcl_Filesystem *fsPtr;
  87. PreloadInfo *preload = NULL;
  88.  
  89. if (objc != 2) {
  90. Tcl_WrongNumArgs(interp, 1, objv, "fileName");
  91. return TCL_ERROR;
  92. }
  93. if (Tcl_FSConvertToPathType(interp, objv[1]) != TCL_OK) {
  94. return TCL_ERROR;
  95. }
  96.  
  97. #ifdef WIN32
  98. // if the filesystem holding the dll doesn't support direct loading
  99. // we need to copy it to a temporary directory and load it from there
  100. // - critcl2::precopy is defined in critcl/lib/app-critcl/runtime.tcl
  101.  
  102. if ((fsPtr = Tcl_FSGetFileSystemForPath(objv[1])) != NULL \
  103. && fsPtr->loadFileProc == NULL) {
  104. int len;
  105. Tcl_Obj *dirs;
  106. objv[0] = Tcl_NewStringObj("::critcl2::precopy", -1);
  107. if ((code = Tcl_EvalObjv(interp, 2, objv, 0)) != TCL_OK) {
  108. Tcl_SetErrorCode(interp, "could not preload ",
  109. Tcl_GetString(objv[1]), 0);
  110. return TCL_ERROR;
  111. }
  112. objv[1] = Tcl_GetObjResult(interp);
  113. Tcl_IncrRefCount(objv[1]);
  114. dirs = Tcl_FSSplitPath(objv[1], &len);
  115. preload = (PreloadInfo *) ckalloc(sizeof(PreloadInfo));
  116. preload->dir = Tcl_FSJoinPath(dirs, --len);
  117. Tcl_IncrRefCount(preload->dir);
  118. }
  119. #endif
  120.  
  121. Tcl_MutexLock(&packageMutex);
  122. code = Tcl_FSLoadFile(interp, objv[1], NULL, NULL, NULL, NULL,
  123. &loadHandle, &unLoadProcPtr);
  124. Tcl_MutexUnlock(&packageMutex);
  125. #ifdef WIN32
  126. if (preload) {
  127. preload->handle = loadHandle;
  128. Tcl_CreateExitHandler(removeDLLCopy, (ClientData) preload);
  129. }
  130. #endif
  131. return code;
  132. }
  133.  
  134. DLLEXPORT int
  135. Preload_Init(Tcl_Interp *interp)
  136. {
  137. if (!MyInitTclStubs(interp))
  138. return TCL_ERROR;
  139. // the Tcl command can't be "preload" because the Tcl source
  140. // might be copied into the target package (so Tcl procs are
  141. // available) and we want critcl::preload to then be a no-op
  142. // because the preloading is done from the loadlib command when
  143. // the target package is loaded
  144. Tcl_CreateObjCommand(interp, "::critcl2::preload", Critcl_Preload, NULL, 0);
  145. return 0;
  146. }
  147.  
  148. DLLEXPORT int
  149. Preload_SafeInit(Tcl_Interp *interp)
  150. {
  151. if (!MyInitTclStubs(interp))
  152. return TCL_ERROR;
  153. Tcl_CreateObjCommand(interp, "::critcl2::preload", Critcl_Preload, NULL, 0);
  154. return 0;
  155. }
  156.  
  157. DLLEXPORT int
  158. Preload_Unload(Tcl_Interp *interp) {}
  159.  
  160. DLLEXPORT int
  161. Preload_SafeUnload(Tcl_Interp *interp) {}