(***********************************************************************)
(*                                                                     *)
(*                 MLTk, Tcl/Tk interface of OCaml                     *)
(*                                                                     *)
(*    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 OCaml source tree.          *)
(*                                                                     *)
(***********************************************************************)

(* $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 ~callback =
  if !Protocol.debug then begin
    prerr_string "Timer.add "; flush stderr;
  end;
  let id = new_function_id () in
  if !Protocol.debug then begin
    prerr_string "id="; prerr_cbid id; flush stderr;
  end;
  let wrapped _ =
    clear_callback id; (* do it first in case f raises exception *)
    callback() in
  Hashtbl.add callback_naming_table id wrapped;
  let t = internal_add_timer ms id in
  if !Protocol.debug then begin
    prerr_endline " done"
  end;
   t,id

let set ~ms ~callback = ignore (add ~ms ~callback);;

(* 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