/*
* Calling Tcl from Caml
* this version works on an arbitrary Tcl command,
* and does parsing and substitution
*/
CAMLprim value camltk_tcl_eval(value str)
{
int code;
char *cmd = NULL;
CheckInit();
/* Tcl_Eval may write to its argument, so we take a copy
* If the evaluation raises a Caml exception, we have a space
* leak
*/
Tcl_ResetResult(cltclinterp);
cmd = caml_string_to_tcl(str);
code = Tcl_Eval(cltclinterp, cmd);
stat_free(cmd);
switch (code) {
case TCL_OK:
return tcl_string_to_caml(Tcl_GetStringResult(cltclinterp));
case TCL_ERROR:
tk_error(Tcl_GetStringResult(cltclinterp));
default: /* TCL_BREAK, TCL_CONTINUE, TCL_RETURN */
tk_error("bad tcl result");
}
}
CAMLprim value camltk_setvar(value var, value contents)
{
char *s;
char *stable_var = NULL;
char *utf_contents;
CheckInit();
/* SetVar makes a copy of the contents. */
/* In case we have write traces in OCaml, it's better to make sure that
var doesn't move... */
stable_var = string_to_c(var);
utf_contents = caml_string_to_tcl(contents);
s = (char *)Tcl_SetVar(cltclinterp,stable_var, utf_contents,
TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG);
stat_free(stable_var);
if( s == utf_contents ){
tk_error("camltk_setvar: Tcl_SetVar returned strange result. Call the author of mlTk!");
}
stat_free(utf_contents);
if (s == NULL)
tk_error(Tcl_GetStringResult(cltclinterp));
else
return(Val_unit);
}
/* Fill a preallocated vector arguments, doing expansion and all.
* Assumes Tcl will
* not tamper with our strings
* make copies if strings are "persistent"
*/
int fill_args (char **argv, int where, value v)
{
value l;
switch (Tag_val(v)) {
case 0:
argv[where] = caml_string_to_tcl(Field(v,0)); /* must free by stat_free */
return (where + 1);
case 1:
for (l=Field(v,0); Is_block(l); l=Field(l,1))
where = fill_args(argv,where,Field(l,0));
return where;
case 2:
{ char **tmpargv;
char *merged;
int i;
int size = argv_size(Field(v,0));
tmpargv = (char **)stat_alloc((size + 1) * sizeof(char *));
fill_args(tmpargv,0,Field(v,0));
tmpargv[size] = NULL;
merged = Tcl_Merge(size,tmpargv);
for(i = 0; i<size; i++){ stat_free(tmpargv[i]); }
stat_free((char *)tmpargv);
/* must be freed by stat_free */
argv[where] = (char*)stat_alloc(strlen(merged)+1);
strcpy(argv[where], merged);
Tcl_Free(merged);
return (where + 1);
}
default:
tk_error("fill_args: illegal tag");
}
}
/* Parsing results */
CAMLprim value camltk_splitlist (value v)
{
int argc;
char **argv;
int result;
char *utf;
CheckInit();
utf = caml_string_to_tcl(v);
/* argv is allocated by Tcl, to be freed by us */
result = Tcl_SplitList(cltclinterp,utf,&argc,&argv);
switch(result) {
case TCL_OK:
{ value res = copy_string_list(argc,argv);
Tcl_Free((char *)argv); /* only one large block was allocated */
/* argv points into utf: utf must be freed after argv are freed */
stat_free( utf );
return res;
}
case TCL_ERROR:
default:
stat_free( utf );
tk_error(Tcl_GetStringResult(cltclinterp));
}
}
