l4/pkg/ocaml/contrib/otherlibs/labltk/support/cltkVar.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: cltkVar.c 5029 2002-07-23 14:12:03Z doligez $ */
  18
  19 /* Alternative to tkwait variable */
  20 #include <string.h>
  21 #include <tcl.h>
  22 #include <tk.h>
  23 #include <mlvalues.h>
  24 #include <memory.h>
  25 #include <alloc.h>
  26 #include <callback.h>
  27 #include "camltk.h"
  28
  29 CAMLprim value camltk_getvar(value var)
  30 {
  31   char *s;
  32   char *stable_var = NULL;
  33   CheckInit();
  34
  35   stable_var = string_to_c(var);
  36   s = Tcl_GetVar(cltclinterp,stable_var,
  37                    TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG);
  38   stat_free(stable_var);
  39
  40   if (s == NULL)
  41     tk_error(cltclinterp->result);
  42   else
  43     return(tcl_string_to_caml(s));
  44 }
  45
  46 CAMLprim value camltk_setvar(value var, value contents)
  47 {
  48   char *s;
  49   char *stable_var = NULL;
  50   char *utf_contents;
  51   CheckInit();
  52
  53   /* SetVar makes a copy of the contents. */
  54   /* In case we have write traces in Caml, it's better to make sure that
  55      var doesn't move... */
  56   stable_var = string_to_c(var);
  57   utf_contents = caml_string_to_tcl(contents);
  58   s = Tcl_SetVar(cltclinterp,stable_var, utf_contents,
  59                    TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG);
  60   stat_free(stable_var);
  61   if( s == utf_contents ){
  62     tk_error("camltk_setvar: Tcl_SetVar returned strange result. Call the author of mlTk!");
  63   }
  64   stat_free(utf_contents);
  65
  66   if (s == NULL)
  67     tk_error(cltclinterp->result);
  68   else
  69     return(Val_unit);
  70 }
  71
  72
  73 /* The appropriate type is
  74 typedef char *(Tcl_VarTraceProc) _ANSI_ARGS_((ClientData clientData,
  75         Tcl_Interp *interp, char *part1, char *part2, int flags));
  76  */
  77 static char * tracevar(clientdata, interp, name1, name2, flags)
  78      ClientData clientdata;
  79      Tcl_Interp *interp;        /* Interpreter containing variable. */
  80      char *name1;               /* Name of variable. */
  81      char *name2;               /* Second part of variable name. */
  82      int flags;                 /* Information about what happened. */
  83 {
  84   Tcl_UntraceVar2(interp, name1, name2,
  85                 TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
  86                 tracevar, clientdata);
  87   callback2(*handler_code,Val_int(clientdata),Val_unit);
  88   return (char *)NULL;
  89 }
  90
  91 /* Sets up a callback upon modification of a variable */
  92 CAMLprim value camltk_trace_var(value var, value cbid)
  93 {
  94   char *cvar = NULL;
  95
  96   CheckInit();
  97   /* Make a copy of var, since Tcl will modify it in place, and we
  98    * don't trust that much what it will do here
  99    */
 100   cvar = string_to_c(var);
 101   if (Tcl_TraceVar(cltclinterp, cvar,
 102                    TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
 103                    tracevar,
 104                    (ClientData) (Long_val(cbid)))
 105                    != TCL_OK) {
 106     stat_free(cvar);
 107     tk_error(cltclinterp->result);
 108   };
 109   stat_free(cvar);
 110   return Val_unit;
 111 }
 112
 113 CAMLprim value camltk_untrace_var(value var, value cbid)
 114 {
 115   char *cvar = NULL;
 116
 117   CheckInit();
 118   /* Make a copy of var, since Tcl will modify it in place, and we
 119    * don't trust that much what it will do here
 120    */
 121   cvar = string_to_c(var);
 122   Tcl_UntraceVar(cltclinterp, cvar,
 123                  TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
 124                  tracevar,
 125                  (ClientData) (Long_val(cbid)));
 126   stat_free(cvar);
 127   return Val_unit;
 128 }