Posted to tcl by stevel at Mon Jan 07 22:31:39 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. TCL_DECLARE_MUTEX(packageMutex)
  50.  
  51. static int
  52. Critcl_Preload(
  53. ClientData dummy,
  54. Tcl_Interp *interp,
  55. int objc,
  56. Tcl_Obj *CONST objv[])
  57. {
  58. int code;
  59. Tcl_PackageInitProc *proc1, *proc2;
  60. Tcl_LoadHandle loadHandle;
  61. Tcl_FSUnloadFileProc *unLoadProcPtr = NULL;
  62.  
  63. if (objc != 2) {
  64. Tcl_WrongNumArgs(interp, 1, objv, "fileName");
  65. return TCL_ERROR;
  66. }
  67. if (Tcl_FSConvertToPathType(interp, objv[1]) != TCL_OK) {
  68. return TCL_ERROR;
  69. }
  70. Tcl_MutexLock(&packageMutex);
  71. #ifdef notdef
  72. code = TclpDlopen(interp, objv[1], &loadHandle, &unLoadProcPtr);
  73. if (code == TCL_ERROR) {
  74. code = Tcl_FSLoadFile(interp, objv[1], NULL, NULL, &proc1, &proc2,
  75. &loadHandle, &unLoadProcPtr);
  76. }
  77. #else
  78. code = Tcl_FSLoadFile(interp, objv[1], NULL, NULL, &proc1, &proc2,
  79. &loadHandle, &unLoadProcPtr);
  80. #endif
  81. Tcl_MutexUnlock(&packageMutex);
  82. return code;
  83. }
  84.  
  85. DLLEXPORT int
  86. Preload_Init(Tcl_Interp *interp)
  87. {
  88. if (!MyInitTclStubs(interp))
  89. return TCL_ERROR;
  90. // the Tcl command can't be "preload" because the Tcl source
  91. // might be copied into the target package (so Tcl procs are
  92. // available) and we want critcl::preload to then be a no-op
  93. // because the preloading is done from the loadlib command when
  94. // the target package is loaded
  95. Tcl_CreateObjCommand(interp, "@preload", Critcl_Preload, NULL, 0);
  96. return 0;
  97. }
  98.  
  99. DLLEXPORT int
  100. Preload_SafeInit(Tcl_Interp *interp)
  101. {
  102. if (!MyInitTclStubs(interp))
  103. return TCL_ERROR;
  104. Tcl_CreateObjCommand(interp, "@preload", Critcl_Preload, NULL, 0);
  105. return 0;
  106. }
  107.  
  108. DLLEXPORT int
  109. Preload_Unload(Tcl_Interp *interp) {}
  110.  
  111. DLLEXPORT int
  112. Preload_SafeUnload(Tcl_Interp *interp) {}