245 lines
6.9 KiB
C
245 lines
6.9 KiB
C
/***********************************************************************/
|
|
/* */
|
|
/* MLTk, Tcl/Tk interface of Objective Caml */
|
|
/* */
|
|
/* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis */
|
|
/* projet Cristal, INRIA Rocquencourt */
|
|
/* Jacques Garrigue, Kyoto University RIMS */
|
|
/* */
|
|
/* Copyright 2002 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 found in the Objective Caml source tree. */
|
|
/* */
|
|
/***********************************************************************/
|
|
|
|
/* $Id$ */
|
|
|
|
#include <stdlib.h>
|
|
#include <string.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)
|
|
{
|
|
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);
|
|
}
|
|
|
|
/*
|
|
* 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(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 = 0;
|
|
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:
|
|
tk_error("argv_size: illegal tag");
|
|
}
|
|
}
|
|
|
|
/* 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");
|
|
}
|
|
}
|
|
|
|
/* 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 (cltclinterp->result);
|
|
case TCL_ERROR:
|
|
tk_error(cltclinterp->result);
|
|
default: /* TCL_BREAK, TCL_CONTINUE, TCL_RETURN */
|
|
tk_error("bad tcl result");
|
|
}
|
|
}
|