l4/pkg/ocaml/contrib/otherlibs/labltk/support/cltkEval.c

   1 /***********************************************************************/
   2 /*                                                                     */
   3 /*                 MLTk, Tcl/Tk interface of Objective Caml            */
   4 /*                                                                     */
   5 /*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    */
   6 /*               projet Cristal, INRIA Rocquencourt                    */
   7 /*            Jacques Garrigue, Kyoto University RIMS                  */
   8 /*                                                                     */
   9 /*  Copyright 2002 Institut National de Recherche en Informatique et   */
  10 /*  en Automatique and Kyoto University.  All rights reserved.         */
  11 /*  This file is distributed under the terms of the GNU Library        */
  12 /*  General Public License, with the special exception on linking      */
  13 /*  described in file LICENSE found in the Objective Caml source tree. */
  14 /*                                                                     */
  15 /***********************************************************************/
  16
  17 /* $Id: cltkEval.c 8899 2008-07-01 09:55:52Z weis $ */
  18
  19 #include <stdlib.h>
  20 #include <string.h>
  21
  22 #include <tcl.h>
  23 #include <tk.h>
  24 #include <mlvalues.h>
  25 #include <alloc.h>
  26 #include <memory.h>
  27 #ifdef HAS_UNISTD
  28 #include <unistd.h>
  29 #endif
  30 #include "camltk.h"
  31
  32 /* The Tcl interpretor */
  33 Tcl_Interp *cltclinterp = NULL;
  34
  35 /* Copy a list of strings from the C heap to Caml */
  36 value copy_string_list(int argc, char **argv)
  37 {
  38   CAMLparam0();
  39   CAMLlocal3( res, oldres, str );
  40   int i;
  41   oldres = Val_unit;
  42   str = Val_unit;
  43
  44   res = Val_int(0); /* [] */
  45   for (i = argc-1; i >= 0; i--) {
  46     oldres = res;
  47     str = tcl_string_to_caml(argv[i]);
  48     res = alloc(2, 0);
  49     Field(res, 0) = str;
  50     Field(res, 1) = oldres;
  51   }
  52   CAMLreturn(res);
  53 }
  54
  55 /*
  56  * Calling Tcl from Caml
  57  *   this version works on an arbitrary Tcl command,
  58  *   and does parsing and substitution
  59  */
  60 CAMLprim value camltk_tcl_eval(value str)
  61 {
  62   int code;
  63   char *cmd = NULL;
  64
  65   CheckInit();
  66
  67   /* Tcl_Eval may write to its argument, so we take a copy
  68    * If the evaluation raises a Caml exception, we have a space
  69    * leak
  70    */
  71   Tcl_ResetResult(cltclinterp);
  72   cmd = caml_string_to_tcl(str);
  73   code = Tcl_Eval(cltclinterp, cmd);
  74   stat_free(cmd);
  75
  76   switch (code) {
  77   case TCL_OK:
  78     return tcl_string_to_caml(cltclinterp->result);
  79   case TCL_ERROR:
  80     tk_error(cltclinterp->result);
  81   default:  /* TCL_BREAK, TCL_CONTINUE, TCL_RETURN */
  82     tk_error("bad tcl result");
  83   }
  84 }
  85
  86 /*
  87  * Calling Tcl from Caml
  88  *   direct call, argument is TkArgs vect
  89   type TkArgs =
  90       TkToken of string
  91     | TkTokenList of TkArgs list                (* to be expanded *)
  92     | TkQuote of TkArgs                         (* mapped to Tcl list *)
  93  * NO PARSING, NO SUBSTITUTION
  94  */
  95
  96 /*
  97  * Compute the size of the argument (of type TkArgs).
  98  * TkTokenList must be expanded,
  99  * TkQuote count for one.
 100  */
 101 int argv_size(value v)
 102 {
 103   switch (Tag_val(v)) {
 104   case 0:                       /* TkToken */
 105     return 1;
 106   case 1:                       /* TkTokenList */
 107     { int n = 0;
 108       value l;
 109       for (l=Field(v,0), n=0; Is_block(l); l=Field(l,1))
 110         n+=argv_size(Field(l,0));
 111       return n;
 112     }
 113   case 2:                       /* TkQuote */
 114     return 1;
 115   default:
 116     tk_error("argv_size: illegal tag");
 117   }
 118 }
 119
 120 /* Fill a preallocated vector arguments, doing expansion and all.
 121  * Assumes Tcl will
 122  *  not tamper with our strings
 123  *  make copies if strings are "persistent"
 124  */
 125 int fill_args (char **argv, int where, value v)
 126 {
 127   value l;
 128
 129   switch (Tag_val(v)) {
 130   case 0:
 131     argv[where] = caml_string_to_tcl(Field(v,0)); /* must free by stat_free */
 132     return (where + 1);
 133   case 1:
 134     for (l=Field(v,0); Is_block(l); l=Field(l,1))
 135       where = fill_args(argv,where,Field(l,0));
 136     return where;
 137   case 2:
 138     { char **tmpargv;
 139       char *merged;
 140       int i;
 141       int size = argv_size(Field(v,0));
 142       tmpargv = (char **)stat_alloc((size + 1) * sizeof(char *));
 143       fill_args(tmpargv,0,Field(v,0));
 144       tmpargv[size] = NULL;
 145       merged = Tcl_Merge(size,tmpargv);
 146       for(i = 0; i<size; i++){ stat_free(tmpargv[i]); }
 147       stat_free((char *)tmpargv);
 148       /* must be freed by stat_free */
 149       argv[where] = (char*)stat_alloc(strlen(merged)+1);
 150       strcpy(argv[where], merged);
 151       Tcl_Free(merged);
 152       return (where + 1);
 153     }
 154   default:
 155     tk_error("fill_args: illegal tag");
 156   }
 157 }
 158
 159 /* v is an array of TkArg */
 160 CAMLprim value camltk_tcl_direct_eval(value v)
 161 {
 162   int i;
 163   int size;                     /* size of argv */
 164   char **argv, **allocated;
 165   int result;
 166   Tcl_CmdInfo info;
 167
 168   CheckInit();
 169
 170   /* walk the array to compute final size for Tcl */
 171   for(i=0, size=0; i<Wosize_val(v); i++)
 172     size += argv_size(Field(v,i));
 173
 174   /* +2: one slot for NULL
 175          one slot for "unknown" if command not found */
 176   argv = (char **)stat_alloc((size + 2) * sizeof(char *));
 177   allocated = (char **)stat_alloc(size * sizeof(char *));
 178
 179   /* Copy -- argv[i] must be freed by stat_free */
 180   {
 181     int where;
 182     for(i=0, where=0; i<Wosize_val(v); i++){
 183       where = fill_args(argv,where,Field(v,i));
 184     }
 185     if( size != where ){ tk_error("fill_args error!!! Call the CamlTk maintainer!"); }
 186     for(i=0; i<where; i++){ allocated[i] = argv[i]; }
 187     argv[size] = NULL;
 188     argv[size + 1] = NULL;
 189   }
 190
 191   /* Eval */
 192   Tcl_ResetResult(cltclinterp);
 193   if (Tcl_GetCommandInfo(cltclinterp,argv[0],&info)) { /* command found */
 194 #if (TCL_MAJOR_VERSION >= 8)
 195     /* info.proc might be a NULL pointer
 196      * We should probably attempt an Obj invocation, but the following quick
 197      * hack is easier.
 198      */
 199     if (info.proc == NULL) {
 200       Tcl_DString buf;
 201       Tcl_DStringInit(&buf);
 202       Tcl_DStringAppend(&buf, argv[0], -1);
 203       for (i=1; i<size; i++) {
 204         Tcl_DStringAppend(&buf, " ", -1);
 205         Tcl_DStringAppend(&buf, argv[i], -1);
 206       }
 207       result = Tcl_Eval(cltclinterp, Tcl_DStringValue(&buf));
 208       Tcl_DStringFree(&buf);
 209     } else {
 210       result = (*info.proc)(info.clientData,cltclinterp,size,argv);
 211     }
 212 #else
 213     result = (*info.proc)(info.clientData,cltclinterp,size,argv);
 214 #endif
 215   } else { /* implement the autoload stuff */
 216     if (Tcl_GetCommandInfo(cltclinterp,"unknown",&info)) { /* unknown found */
 217       for (i = size; i >= 0; i--)
 218         argv[i+1] = argv[i];
 219       argv[0] = "unknown";
 220       result = (*info.proc)(info.clientData,cltclinterp,size+1,argv);
 221     } else { /* ah, it isn't there at all */
 222       result = TCL_ERROR;
 223       Tcl_AppendResult(cltclinterp, "Unknown command \"",
 224                        argv[0], "\"", NULL);
 225     }
 226   }
 227
 228   /* Free the various things we allocated */
 229   for(i=0; i< size; i ++){
 230     stat_free((char *) allocated[i]);
 231   }
 232   stat_free((char *)argv);
 233   stat_free((char *)allocated);
 234
 235   switch (result) {
 236   case TCL_OK:
 237     return tcl_string_to_caml (cltclinterp->result);
 238   case TCL_ERROR:
 239     tk_error(cltclinterp->result);
 240   default:  /* TCL_BREAK, TCL_CONTINUE, TCL_RETURN */
 241     tk_error("bad tcl result");
 242   }
 243 }