Initial revision

[helm.git] / helm / DEVEL / lablgtk / lablgtk_20000829-0.1.0 / gtkSignal.ml

diff --git a/helm/DEVEL/lablgtk/lablgtk_20000829-0.1.0/gtkSignal.ml b/helm/DEVEL/lablgtk/lablgtk_20000829-0.1.0/gtkSignal.ml
new file mode 100644 (file)
index 0000000..8fa4602
--- /dev/null
+++ b/helm/DEVEL/lablgtk/lablgtk_20000829-0.1.0/gtkSignal.ml
@@ -0,0 +1,65 @@
+(* $Id$ *)
+
+open Gtk
+
+type id
+type ('a,'b) t =
+ { name: string;
+   marshaller: ('b -> GtkArgv.t -> GtkArgv.data list -> unit) }
+
+let enter_callback = ref (fun () -> ())
+and exit_callback = ref (fun () -> ())
+
+let stop_emit_ref = ref false
+let stop_emit () = stop_emit_ref := true
+
+type saved_state = State of bool
+let push_callback () =
+  !enter_callback ();
+  let old = !stop_emit_ref in
+  stop_emit_ref := false;
+  State old
+
+let pop_callback (State old) =
+  let res = !stop_emit_ref in
+  stop_emit_ref := old;
+  !exit_callback ();
+  res
+
+external connect :
+  'a obj -> name:string -> callback:(GtkArgv.t -> unit) -> after:bool -> id
+  = "ml_gtk_signal_connect"
+external emit_stop_by_name : 'a obj -> name:string -> unit
+  = "ml_gtk_signal_emit_stop_by_name"
+let connect  ~(sgn : ('a, _) t) ~callback ?(after=false) (obj : 'a obj) =
+  let callback argv =
+    let old = push_callback () in
+    let exn =
+      try sgn.marshaller callback argv (GtkArgv.get_args argv); None
+      with exn -> Some exn
+    in
+    if pop_callback old then emit_stop_by_name obj ~name:sgn.name;
+    Gaux.may ~f:raise exn
+  in
+  connect obj ~name:sgn.name ~callback ~after
+external disconnect : 'a obj -> id -> unit
+  = "ml_gtk_signal_disconnect"
+external handler_block : 'a obj -> id -> unit
+  = "ml_gtk_signal_handler_block"
+external handler_unblock : 'a obj -> id -> unit
+  = "ml_gtk_signal_handler_unblock"
+
+let marshal_unit f _ _ = f ()
+let marshal_int f _ = function
+  | GtkArgv.INT n :: _ -> f n
+  | _ -> invalid_arg "GtkSignal.marshal_int"
+
+let emit (obj : 'a obj) ~(sgn : ('a, 'b) t)
+    ~(emitter : 'a obj -> name:string -> 'b) =
+  emitter obj ~name:sgn.name
+external emit_none : 'a obj -> name:string -> unit -> unit
+    = "ml_gtk_signal_emit_none"
+let emit_unit obj ~sgn = emit obj ~emitter:emit_none ~sgn ()
+external emit_int : 'a obj -> name:string -> int -> unit
+    = "ml_gtk_signal_emit_int"
+let emit_int = emit ~emitter:emit_int