import labltklabltk

git-svn-id: http://caml.inria.fr/svn/ocaml/branches/labltk@2531 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

1 files changed, 33 insertions, 0 deletions

diff --git a/otherlibs/labltk/support/timer.ml b/otherlibs/labltk/support/timer.ml
new file mode 100644
index 0000000000..531695fe0d
--- /dev/null
+++ b/otherlibs/labltk/support/timer.ml
@@ -0,0 +1,33 @@
+(* $Id$ *)
+
+(* Timers *)
+open Protocol
+
+type tkTimer = int
+
+external internal_add_timer : int -> cbid -> tkTimer
+      	=  "camltk_add_timer"
+external internal_rem_timer : tkTimer -> unit
+        =  "camltk_rem_timer"
+
+type t = tkTimer * cbid	(* the token and the cb id *)
+
+(* A timer is used only once, so we must clean the callback table *)
+let add ms:milli callback:f =
+  let id = new_function_id () in
+  let wrapped _ =
+    clear_callback id; (* do it first in case f raises exception *)
+    f() in
+  Hashtbl.add callback_naming_table key:id data:wrapped;
+  if !Protocol.debug then begin
+    prerr_cbid id; prerr_endline " for timer"
+  end;
+  let t = internal_add_timer milli id in
+   t,id
+
+(* If the timer has never been used, there is a small space leak in
+   the C heap, where a copy of id has been stored *)
+let remove (tkTimer, id) =
+  internal_rem_timer tkTimer;
+  clear_callback id
+