1 files changed, 88 insertions, 0 deletions
diff --git a/otherlibs/labltk/frx/frx_synth.ml b/otherlibs/labltk/frx/frx_synth.ml
new file mode 100644
index 000000000..5ce23b1d4
--- /dev/null
+++ b/otherlibs/labltk/frx/frx_synth.ml
@@ -0,0 +1,88 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                 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. *)
+(*                                                                     *)
+(***********************************************************************)
+(* Some notion of synthetic events *)
+open Camltk
+open Widget
+open Protocol
+
+(* To each event is associated a table of (widget, callback) *)
+let events = Hashtbl.create 37
+
+(* Notes:
+ *   "cascading" events (on the same event) are not supported 
+ *   Only one binding active at a time for each event on each widget.
+ *)
+
+(* Get the callback table associated with <name>. Initializes if required *)
+let get_event name =
+  try Hashtbl.find events name 
+  with
+    Not_found ->
+      let h = Hashtbl.create 37 in
+       Hashtbl.add events name h;
+       (* Initialize the callback invocation mechanism, based on 
+          variable trace
+        *)
+       let var = "camltk_events(" ^ name ^")" in
+       let tkvar = Textvariable.coerce var in
+       let rec set () =
+	 Textvariable.handle tkvar
+	 (fun () ->
+	    begin match Textvariable.get tkvar with
+	      "all" -> (* Invoke all callbacks *)
+		Hashtbl.iter
+      	       	  (fun p f -> 
+      	       	     try 
+      	       	      f (cTKtoCAMLwidget p) 
+      	       	     with _ -> ())
+                  h
+	    | p -> (* Invoke callback for p *)
+		try
+		  let w = cTKtoCAMLwidget p
+      	       	  and f = Hashtbl.find h p in
+		    f w
+      	        with
+      	       	  _ -> ()
+            end; 
+      	    set ()(* reactivate the callback *)
+            ) in
+       set();
+       h 
+
+(* Remove binding for event <name> on widget <w> *)
+let remove w name =   
+  Hashtbl.remove (get_event name) (Widget.name w)
+
+(* Adds <f> as callback for widget <w> on event <name> *)
+let bind w name f =
+  remove w name;
+  Hashtbl.add (get_event name) (Widget.name w) f
+
+(* Sends event <name> to all widgets *)
+let broadcast name =
+  Textvariable.set (Textvariable.coerce ("camltk_events(" ^ name ^")")) "all"
+
+(* Sends event <name> to widget <w> *)
+let send name w =
+  Textvariable.set (Textvariable.coerce ("camltk_events(" ^ name ^")")) 
+                   (Widget.name w)
+
+(* Remove all callbacks associated to widget <w> *)
+let remove_callbacks w =
+  Hashtbl.iter (fun _ h -> Hashtbl.remove h (Widget.name w)) events
+
+let _ =
+  add_destroy_hook remove_callbacks