l4/pkg/ocaml/contrib/otherlibs/labltk/support/protocol.ml

   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: protocol.ml 7283 2005-12-21 05:29:08Z garrigue $ *)
  18
  19 open Support
  20 open Widget
  21
  22 type callback_buffer = string list
  23       (* Buffer for reading callback arguments *)
  24
  25 type tkArgs =
  26     TkToken of string
  27   | TkTokenList of tkArgs list          (* to be expanded *)
  28   | TkQuote of tkArgs                   (* mapped to Tcl list *)
  29
  30 type cbid = int
  31
  32 external opentk_low : string list -> unit
  33         =  "camltk_opentk"
  34 external tcl_eval : string -> string
  35         =  "camltk_tcl_eval"
  36 external tk_mainloop : unit -> unit
  37         =  "camltk_tk_mainloop"
  38 external tcl_direct_eval : tkArgs array -> string
  39         =  "camltk_tcl_direct_eval"
  40 external splitlist : string -> string list
  41         = "camltk_splitlist"
  42 external tkreturn : string -> unit
  43         = "camltk_return"
  44 external callback_init : unit -> unit
  45         = "camltk_init"
  46 external finalizeTk : unit -> unit
  47         = "camltk_finalize"
  48     (* Finalize tcl/tk before exiting. This function will be automatically
  49        called when you call [Pervasives.exit ()] (This is installed at
  50        [install_cleanup ()] *)
  51
  52 let tcl_command s = ignore (tcl_eval s);;
  53
  54 type event_flag =
  55   DONT_WAIT | X_EVENTS | FILE_EVENTS | TIMER_EVENTS | IDLE_EVENTS | ALL_EVENTS
  56 external do_one_event : event_flag list -> bool = "camltk_dooneevent"
  57
  58 let do_pending () = while do_one_event [DONT_WAIT] do () done
  59
  60 exception TkError of string
  61       (* Raised by the communication functions *)
  62 let () = Callback.register_exception "tkerror" (TkError "")
  63
  64 let cltclinterp = ref Nativeint.zero
  65       (* For use in other extensions *)
  66 let () = Callback.register "cltclinterp" cltclinterp
  67
  68 (* Debugging support *)
  69 let debug =
  70  ref (try ignore (Sys.getenv "CAMLTKDEBUG"); true
  71       with Not_found -> false)
  72
  73 (* This is approximative, since we don't quote what needs to be quoted *)
  74 let dump_args args =
  75   let rec print_arg = function
  76     TkToken s -> prerr_string s; prerr_string " "
  77   | TkTokenList l -> List.iter print_arg l
  78   | TkQuote a -> prerr_string "{"; print_arg a; prerr_string "} "
  79  in
  80   Array.iter print_arg args;
  81   prerr_newline()
  82
  83 (*
  84  * Evaluating Tcl code
  85  *   debugging support should not affect performances...
  86  *)
  87
  88 let tkEval args =
  89   if !debug then dump_args args;
  90   let res = tcl_direct_eval args in
  91   if !debug then begin
  92     prerr_string "->>";
  93     prerr_endline res
  94     end;
  95   res
  96
  97 let tkCommand args = ignore (tkEval args)
  98
  99 (*
 100  * Callbacks
 101  *)
 102
 103 (* LablTk only *)
 104 let cCAMLtoTKwidget w =
 105   (* Widget.check_class w table; (* with subtyping, it is redundant *) *)
 106   TkToken (Widget.name w)
 107
 108 let cTKtoCAMLwidget = function
 109    "" -> raise (Invalid_argument "cTKtoCAMLwidget")
 110  | s -> Widget.get_atom s
 111
 112 let callback_naming_table =
 113    (Hashtbl.create 401 : (int, callback_buffer -> unit) Hashtbl.t)
 114
 115 let callback_memo_table =
 116    (Hashtbl.create 401 : (any widget, int) Hashtbl.t)
 117
 118 let new_function_id =
 119   let counter = ref 0 in
 120   function () -> incr counter;  !counter
 121
 122 let string_of_cbid = string_of_int
 123
 124 (* Add a new callback, associated to widget w *)
 125 (* The callback should be cleared when w is destroyed *)
 126 let register_callback w ~callback:f =
 127   let id = new_function_id () in
 128     Hashtbl.add callback_naming_table id f;
 129     if (forget_type w) <> (forget_type Widget.dummy) then
 130       Hashtbl.add callback_memo_table (forget_type w) id;
 131     (string_of_cbid id)
 132
 133 let clear_callback id =
 134   Hashtbl.remove callback_naming_table id
 135
 136 (* Clear callbacks associated to a given widget *)
 137 let remove_callbacks w =
 138   let w = forget_type w in
 139   let cb_ids = Hashtbl.find_all callback_memo_table w in
 140     List.iter clear_callback cb_ids;
 141     for i = 1 to List.length cb_ids do
 142       Hashtbl.remove callback_memo_table w
 143     done
 144
 145 (* Hand-coded callback for destroyed widgets
 146  * This may be extended by the application, or by other layers of Camltk.
 147  * Could use bind + of Tk, but I'd rather give an alternate mechanism so
 148  * that hooks can be set up at load time (i.e. before openTk)
 149  *)
 150 let destroy_hooks = ref []
 151 let add_destroy_hook f =
 152   destroy_hooks := f :: !destroy_hooks
 153
 154 let _ =
 155   add_destroy_hook (fun w -> remove_callbacks w; Widget.remove w)
 156
 157 let install_cleanup () =
 158   let call_destroy_hooks = function
 159       [wname] ->
 160         let w = cTKtoCAMLwidget wname in
 161          List.iter (fun f -> f w) !destroy_hooks
 162     | _ -> raise (TkError "bad cleanup callback") in
 163   let fid = new_function_id () in
 164   Hashtbl.add callback_naming_table fid call_destroy_hooks;
 165   (* setup general destroy callback *)
 166   tcl_command ("bind all <Destroy> {camlcb " ^ (string_of_cbid fid) ^" %W}");
 167   at_exit finalizeTk
 168
 169 let prerr_cbid id =
 170   prerr_string "camlcb "; prerr_int id
 171
 172 (* The callback dispatch function *)
 173 let dispatch_callback id args =
 174   if !debug then begin
 175     prerr_cbid id;
 176     List.iter (fun x -> prerr_string " "; prerr_string x) args;
 177     prerr_newline()
 178     end;
 179   (Hashtbl.find callback_naming_table id) args;
 180   if !debug then prerr_endline "<<-"
 181
 182 let protected_dispatch id args =
 183   try
 184     dispatch_callback id args
 185   with e ->
 186     Printf.eprintf "Uncaught exception: %s\n" (Printexc.to_string e);
 187     flush stderr
 188
 189 let _ = Callback.register "camlcb" protected_dispatch
 190
 191 (* Make sure the C variables are initialised *)
 192 let _ = callback_init ()
 193
 194 (* Different version of initialisation functions *)
 195 let default_display_name = ref ""
 196 let default_display () = !default_display_name
 197
 198 let camltk_argv = ref []
 199
 200 (* options for Arg.parse *)
 201 let keywords = [
 202   "-display", Arg.String (fun s ->
 203     camltk_argv := "-display" :: s :: !camltk_argv),
 204     "<disp> : X server to contact (CamlTk)";
 205   "-colormap", Arg.String (fun s ->
 206     camltk_argv := "-colormap" :: s :: !camltk_argv),
 207     "<colormap> : colormap to use (CamlTk)";
 208   "-geometry", Arg.String (fun s ->
 209     camltk_argv := "-geometry" :: s :: !camltk_argv),
 210     "<geom> : size and position (CamlTk)";
 211   "-name", Arg.String (fun s ->
 212     camltk_argv := "-name" :: s :: !camltk_argv),
 213     "<name> : application class (CamlTk)";
 214   "-sync", Arg.Unit (fun () ->
 215     camltk_argv := "-sync" :: !camltk_argv),
 216     ": sync mode (CamlTk)";
 217   "-use", Arg.String (fun s ->
 218     camltk_argv := "-use" :: s :: !camltk_argv),
 219     "<id> : parent window id (CamlTk)";
 220   "-window", Arg.String (fun s ->
 221     camltk_argv := "-use" :: s :: !camltk_argv),
 222     "<id> : parent window id (CamlTk)";
 223   "-visual", Arg.String (fun s ->
 224     camltk_argv := "-visual" :: s :: !camltk_argv),
 225     "<visual> : visual to use (CamlTk)" ]
 226
 227 let opentk_with_args argv (* = [argv1;..;argvn] *) =
 228   (* argv must be command line for wish *)
 229   let argv0 = Sys.argv.(0) in
 230   let rec find_display = function
 231     | "-display" :: s :: xs -> s
 232     | "-colormap" :: s :: xs -> find_display xs
 233     | "-geometry" :: s :: xs -> find_display xs
 234     | "-name" :: s :: xs -> find_display xs
 235     | "-sync" :: xs -> find_display xs
 236     | "-use" :: s :: xs -> find_display xs
 237     | "-window" :: s :: xs -> find_display xs
 238     | "-visual" :: s :: xs -> find_display xs
 239     | "--" :: _ -> ""
 240     | _ :: xs -> find_display xs
 241     | [] -> ""
 242   in
 243   default_display_name := find_display argv;
 244   opentk_low (argv0 :: argv);
 245   install_cleanup();
 246   Widget.default_toplevel
 247
 248 let opentk () = opentk_with_args !camltk_argv;;
 249
 250 let openTkClass s = opentk_with_args ["-name"; s]
 251 let openTkDisplayClass disp cl = opentk_with_args ["-display"; disp; "-name"; cl]
 252
 253 (*JPF CAMLTK/LABLTK? *)
 254 let openTk ?(display = "") ?(clas = "LablTk") () =
 255   let dispopt =
 256     match display with
 257     | "" -> []
 258     | _ -> ["-display"; display]
 259   in
 260   opentk_with_args (dispopt @ ["-name"; clas])
 261
 262 (* Destroy all widgets, thus cleaning up table and exiting the loop *)
 263 let closeTk () =
 264   tcl_command "destroy ."
 265
 266 let mainLoop =
 267   tk_mainloop
 268
 269
 270 (* [register tclname f] makes [f] available from Tcl with
 271    name [tclname] *)
 272 let register tclname ~callback =
 273   let s = register_callback Widget.default_toplevel ~callback in
 274     tcl_command (Printf.sprintf "proc %s {args} {eval {camlcb %s} $args}"
 275                              tclname s)
 276