Posted to tcl by patthoyts at Tue May 20 14:05:17 GMT 2008view raw

  1. /*
  2. * Test the calling of the cleanup procedures that are registered
  3. * with Tcl_SetAssocData.
  4. *
  5. * It seems that these cleanup procedures are only called when a child
  6. * interpreter is deleted. When the main interpreter is closed in tclsh
  7. * they are not called.
  8. *
  9. * Using the code below I tested this extension with tcl 8.4.15 looking for
  10. * PkgFree to be printed out.
  11. *
  12. * C:\opt\tcl\src>tclsh
  13. * % load demo.dll
  14. * PkgInit
  15. * % exit
  16. *
  17. * C:\opt\tcl\src>tclsh
  18. * % interp create test
  19. * test
  20. * % test eval {load demo.dll}
  21. * PkgInit
  22. * % interp delete test
  23. * PkgFree
  24. *
  25. * It seems that to check for this kind of major interp cleanup you must
  26. * have scripts of the following style:
  27. * load demo.dll
  28. * puts "done"
  29. * rename exit ::tcl::exit
  30. * with this it works correctly in the primary interpreter.
  31. *
  32. * compile this with:
  33. * cl -W3 -MD -I/opt/tcl/include demo.c -link \
  34. * -dll \opt\tcl\lib\tclstub84.lib -out:demo.dll
  35. */
  36.  
  37. #define USE_TCL_STUBS
  38. #include "tcl.h"
  39.  
  40. typedef struct Package {
  41. unsigned long magic;
  42. } Package;
  43.  
  44. static void
  45. PkgFree(ClientData clientData, Tcl_Interp *interp)
  46. {
  47. printf("PkgFree\n");
  48. fflush(stdout);
  49. ckfree((char *)clientData);
  50. }
  51.  
  52. int DLLEXPORT
  53. Demo_Init(Tcl_Interp *interp) {
  54. Package *pkgPtr = NULL;
  55. Tcl_InitStubs(interp, TCL_VERSION, 0);
  56. pkgPtr = (Package *)ckalloc(sizeof(Package));
  57. pkgPtr->magic = 0xCAFEBABE;
  58. printf("PkgInit\n");
  59. Tcl_SetAssocData(interp, "DemoPackage", PkgFree, (ClientData)pkgPtr);
  60. Tcl_PkgProvide(interp, "Demo", "1.0");
  61. return TCL_OK;
  62. }