Posted to tcl by colin at Wed May 23 06:02:01 GMT 2012view raw

  1. # InitScript - interface to TclSetPreInitScript
  2. package provide InitScript 1.0
  3.  
  4. if {[info commands ::InitScript] ne ""} {
  5. return
  6. }
  7.  
  8. package require critcl
  9. ::critcl::tsources InitScript.tcl
  10.  
  11. critcl::ccode {
  12. #include <stdlib.h>
  13. #include <tcl.h>
  14. #include <errno.h>
  15. #include <stdio.h>
  16. }
  17.  
  18. critcl::cproc ::InitScript {Tcl_Interp* interp Tcl_Obj* script} ok {
  19. static char *initscript = NULL;
  20. int len;
  21. char *strptr;
  22.  
  23. strptr = Tcl_GetStringFromObj(script, &len);
  24. if (initscript != NULL) {
  25. free((void*)initscript);
  26. }
  27. initscript = calloc(len+1,1);
  28. if (initscript == NULL) {
  29. return TCL_ERROR;
  30. }
  31. memcpy(initscript, strptr, len);
  32. strptr = TclSetPreInitScript(initscript);
  33. Tcl_SetObjResult(interp, Tcl_NewStringObj(strptr,-1));
  34. return TCL_OK;
  35. }