/*
* 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_getvar(value var)
{
char *s;
char *stable_var = NULL;
CheckInit();
stable_var = string_to_c(var);
s = (char *)Tcl_GetVar(cltclinterp,stable_var,
TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG);
stat_free(stable_var);
if (s == NULL)
tk_error(Tcl_GetStringResult(cltclinterp));
else
return(tcl_string_to_caml(s));
}
/* Copy a list of strings from the C heap to Caml */
value copy_string_list(int argc, char **argv)
{
CAMLparam0();
CAMLlocal3( res, oldres, str );
int i;
oldres = Val_unit;
str = Val_unit;
res = Val_int(0); /* [] */
for (i = argc-1; i >= 0; i--) {
oldres = res;
str = tcl_string_to_caml(argv[i]);
res = alloc(2, 0);
Field(res, 0) = str;
Field(res, 1) = oldres;
}
CAMLreturn(res);
}
/* v is an array of TkArg */
CAMLprim value camltk_tcl_direct_eval(value v)
{
int i;
int size; /* size of argv */
char **argv, **allocated;
int result;
Tcl_CmdInfo info;
CheckInit();
/* walk the array to compute final size for Tcl */
for(i=0, size=0; i<Wosize_val(v); i++)
size += argv_size(Field(v,i));
/* +2: one slot for NULL
one slot for "unknown" if command not found */
argv = (char **)stat_alloc((size + 2) * sizeof(char *));
allocated = (char **)stat_alloc(size * sizeof(char *));
/* Copy -- argv[i] must be freed by stat_free */
{
int where;
for(i=0, where=0; i<Wosize_val(v); i++){
where = fill_args(argv,where,Field(v,i));
}
if( size != where ){ tk_error("fill_args error!!! Call the CamlTk maintainer!"); }
for(i=0; i<where; i++){ allocated[i] = argv[i]; }
argv[size] = NULL;
argv[size + 1] = NULL;
}
/* Eval */
Tcl_ResetResult(cltclinterp);
if (Tcl_GetCommandInfo(cltclinterp,argv[0],&info)) { /* command found */
#if (TCL_MAJOR_VERSION >= 8)
/* info.proc might be a NULL pointer
* We should probably attempt an Obj invocation, but the following quick
* hack is easier.
*/
if (info.proc == NULL) {
Tcl_DString buf;
Tcl_DStringInit(&buf);
Tcl_DStringAppend(&buf, argv[0], -1);
for (i=1; i<size; i++) {
Tcl_DStringAppend(&buf, " ", -1);
Tcl_DStringAppend(&buf, argv[i], -1);
}
result = Tcl_Eval(cltclinterp, Tcl_DStringValue(&buf));
Tcl_DStringFree(&buf);
} else {
result = (*info.proc)(info.clientData,cltclinterp,size,argv);
}
#else
result = (*info.proc)(info.clientData,cltclinterp,size,argv);
#endif
} else { /* implement the autoload stuff */
if (Tcl_GetCommandInfo(cltclinterp,"unknown",&info)) { /* unknown found */
for (i = size; i >= 0; i--)
argv[i+1] = argv[i];
argv[0] = "unknown";
result = (*info.proc)(info.clientData,cltclinterp,size+1,argv);
} else { /* ah, it isn't there at all */
result = TCL_ERROR;
Tcl_AppendResult(cltclinterp, "Unknown command \"",
argv[0], "\"", NULL);
}
}
/* Free the various things we allocated */
for(i=0; i< size; i ++){
stat_free((char *) allocated[i]);
}
stat_free((char *)argv);
stat_free((char *)allocated);
switch (result) {
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");
}
}
