Initial revision

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

diff --git a/helm/DEVEL/lablgtk/lablgtk_20000829-0.1.0/gtkMain.ml b/helm/DEVEL/lablgtk/lablgtk_20000829-0.1.0/gtkMain.ml
new file mode 100644 (file)
index 0000000..7ef3443
--- /dev/null
+++ b/helm/DEVEL/lablgtk/lablgtk_20000829-0.1.0/gtkMain.ml
@@ -0,0 +1,50 @@
+(* $Id$ *)
+
+open Gtk
+
+let _ = Callback.register_exception "gtkerror" (Error"")
+
+module Timeout = struct
+  type id
+  external add : ms:int -> callback:(GtkArgv.t -> unit) -> id
+      = "ml_gtk_timeout_add"
+  let add ~ms ~callback =
+    add ~ms ~callback:(fun arg -> GtkArgv.set_result arg (`BOOL(callback ())))
+  external remove : id -> unit = "ml_gtk_timeout_remove"
+end
+
+module Main = struct
+  external init : string array -> string array = "ml_gtk_init"
+  (* external exit : int -> unit = "ml_gtk_exit" *)
+  external set_locale : unit -> string = "ml_gtk_set_locale"
+  (* external main : unit -> unit = "ml_gtk_main" *)
+  let locale = set_locale ()
+  let init () =
+    (* let locale = set_locale () in *)
+    let argv = init Sys.argv in
+    Array.blit ~src:argv ~dst:Sys.argv ~len:(Array.length argv)
+      ~src_pos:0 ~dst_pos:0;
+    Obj.truncate (Obj.repr Sys.argv) ~len:(Array.length argv);
+    locale
+  open Glib
+  let loops = ref [] 
+  let main () =
+    let loop = (Main.create true) in
+    loops := loop :: !loops;
+    while Main.is_running loop do Main.iteration true done;
+    loops := List.tl !loops
+  and quit () = Main.quit (List.hd !loops)
+  external get_version : unit -> int * int * int = "ml_gtk_get_version"
+  let version = get_version ()
+
+  let flush = Gdk.X.flush
+end
+
+module Grab = struct
+  external add : [>`widget] obj -> unit = "ml_gtk_grab_add"
+  external remove : [>`widget] obj -> unit = "ml_gtk_grab_remove"
+  external get_current : unit -> widget obj= "ml_gtk_grab_get_current"
+end
+
+let _ = Glib.set_warning_handler (fun msg -> raise (Warning msg))
+let _ = Glib.set_print_handler (fun msg -> print_string msg)