/*************************************************************************/
/* */
/* Objective Caml LablTk library */
/* */
/* Francois Rouaix, Francois Pessaux and Jun Furuse */
/* projet Cristal, INRIA Rocquencourt */
/* Jacques Garrigue, Kyoto University RIMS */
/* */
/* Copyright 1999 Institut National de Recherche en Informatique et */
/* en Automatique and Kyoto University. All rights reserved. */
/* This file is distributed under the terms of the GNU Library */
/* General Public License, with the special exception on linking */
/* described in file ../../../LICENSE. */
/* */
/*************************************************************************/
/* $Id$ */
#include <stdlib.h>
#include <tcl.h>
#include <tk.h>
#include <mlvalues.h>
#include <alloc.h>
#include <memory.h>
#ifdef HAS_UNISTD
#include <unistd.h>
#endif
#include "camltk.h"
/* The Tcl interpretor */
Tcl_Interp *cltclinterp = NULL;
/* Copy a list of strings from the C heap to Caml */
value copy_string_list(int argc, char **argv)
{
value res;
int i;
value oldres = Val_unit, str = Val_unit;
Begin_roots2 (oldres, str);
res = Val_int(0); /* [] */
for (i = argc-1; i >= 0; i--) {
oldres = res;
str = copy_string(argv[i]);
res = alloc(2, 0);
Field(res, 0) = str;
Field(res, 1) = oldres;
}
End_roots();
return res;
}
/*
* 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 = string_to_c(str);
code = Tcl_Eval(cltclinterp, cmd);
stat_free(cmd);
switch (code) {
case TCL_OK:
return copy_string(cltclinterp->result);
case TCL_ERROR:
tk_error(cltclinterp->result);
default: /* TCL_BREAK, TCL_CONTINUE, TCL_RETURN */
tk_error("bad tcl result");
}
}
/*
* Calling Tcl from Caml
* direct call, argument is TkArgs vect
type TkArgs =
TkToken of string
| TkTokenList of TkArgs list (* to be expanded *)
| TkQuote of TkArgs (* mapped to Tcl list *)
* NO PARSING, NO SUBSTITUTION
*/
/*
* Compute the size of the argument (of type TkArgs).
* TkTokenList must be expanded,
* TkQuote count for one.
*/
int argv_size(value v)
{
switch (Tag_val(v)) {
case 0: /* TkToken */
return 1;
case 1: /* TkTokenList */
{ int n;
value l;
for (l=Field(v,0), n=0; Is_block(l); l=Field(l,1))
n+=argv_size(Field(l,0));
return n;
}
case 2: /* TkQuote */
return 1;
default: /* should not happen */
Assert(0);
return 0;
}
}
/*
* Memory of allocated Tcl lists.
* We should not need more than MAX_LIST
*/
#define MAX_LIST 256
static char *tcllists[MAX_LIST];
static int startfree = 0;
/* If size is lower, do not allocate */
static char *quotedargv[16];
/* 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)
{
switch (Tag_val(v)) {
case 0:
argv[where] = String_val(Field(v,0));
return (where + 1);
case 1:
{ value l;
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;
int size = argv_size(Field(v,0));
if (size < 16)
tmpargv = "edargv[0];
else
tmpargv = (char **)stat_alloc((size + 1) * sizeof(char *));
fill_args(tmpargv,0,Field(v,0));
tmpargv[size] = NULL;
argv[where] = Tcl_Merge(size,tmpargv);
tcllists[startfree++] = argv[where]; /* so we can free it later */
if (size >= 16)
stat_free((char *)tmpargv);
return (where + 1);
}
default: /* should not happen */
Assert(0);
return 0;
}
}
/* v is an array of TkArg */
CAMLprim value camltk_tcl_direct_eval(value v)
{
int i;
int size; /* size of argv */
char **argv;
int result;
Tcl_CmdInfo info;
int wherewasi,whereami; /* positions in tcllists array */
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 *));
wherewasi = startfree; /* should be zero except when nested calls */
Assert(startfree < MAX_LIST);
/* Copy */
{
int where;
for(i=0, where=0;i<Wosize_val(v);i++)
where = fill_args(argv,where,Field(v,i));
argv[size] = NULL;
argv[size + 1] = NULL;
}
Begin_roots_block ((value *) argv, size + 2);
whereami = startfree;
/* 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;
char *string;
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);
}
/* fprintf(stderr,"80 compat: %s\n", argv[0]); */
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);
}
}
End_roots ();
/* Free the various things we allocated */
stat_free((char *)argv);
for (i=wherewasi; i<whereami; i++)
free(tcllists[i]);
startfree = wherewasi;
switch (result) {
case TCL_OK:
return copy_string (cltclinterp->result);
case TCL_ERROR:
tk_error(cltclinterp->result);
default: /* TCL_BREAK, TCL_CONTINUE, TCL_RETURN */
tk_error("bad tcl result");
}
}