Posted to tcl by colin at Wed May 23 06:02:01 GMT 2012view raw
- # InitScript - interface to TclSetPreInitScript
- package provide InitScript 1.0
- if {[info commands ::InitScript] ne ""} {
- return
- }
- package require critcl
- ::critcl::tsources InitScript.tcl
- critcl::ccode {
- #include <stdlib.h>
- #include <tcl.h>
- #include <errno.h>
- #include <stdio.h>
- }
- critcl::cproc ::InitScript {Tcl_Interp* interp Tcl_Obj* script} ok {
- static char *initscript = NULL;
- int len;
- char *strptr;
- strptr = Tcl_GetStringFromObj(script, &len);
- if (initscript != NULL) {
- free((void*)initscript);
- }
- initscript = calloc(len+1,1);
- if (initscript == NULL) {
- return TCL_ERROR;
- }
- memcpy(initscript, strptr, len);
- strptr = TclSetPreInitScript(initscript);
- Tcl_SetObjResult(interp, Tcl_NewStringObj(strptr,-1));
- return TCL_OK;
- }