(* $Id: uq_tcl.ml 45 2004-10-07 15:45:09Z gerd $ *)

open Equeue
open Unixqueue

type tcl_timer_handler
type tcl_file_handler

type tcl_file_handler_rec =
    { mutable tcl_fh : tcl_file_handler;
      mutable tcl_fd : Unix.file_descr;
      mutable tcl_mask : int;
    }


external tcl_CreateFileHandler 
         : (unit -> unit) -> Unix.file_descr -> int -> tcl_file_handler
	 = "caml_Tcl_CreateFileHandler";;

external tcl_DeleteFileHandler
         : tcl_file_handler -> unit
	 = "caml_Tcl_DeleteFileHandler";;

external tcl_CreateTimerHandler 
         : (unit -> unit) -> int -> tcl_timer_handler
	 = "caml_Tcl_CreateTimerHandler";;

external tcl_DeleteTimerHandler
         : tcl_timer_handler -> unit
	 = "caml_Tcl_DeleteTimerHandler";;

external tcl_null_file_handler : unit -> tcl_file_handler = "caml_return_null";;

external tcl_null_timer_handler : unit -> tcl_timer_handler = "caml_return_null";;


let null_fh = tcl_null_file_handler();;
let null_th = tcl_null_timer_handler();;
let dummy_fh =
  { tcl_fh = tcl_null_file_handler();
    tcl_fd = Unix.stdin;
    tcl_mask = -1;
  }
;;


let create_timer callback ms =
  (* prerr_endline ("create_timer ms=" ^ string_of_int ms); *)
  ref (tcl_CreateTimerHandler callback ms)
;;


let delete_timer t = 
  (* prerr_endline ("delete_timer"); *)
  let old = !t in
  t := null_th;
  tcl_DeleteTimerHandler old
;;



type runner =
    event_system -> (unit -> unit) -> unit


class tcl_event_system ?(run : runner option) () =
object (self)
  inherit unix_event_system() as super

  val mutable tcl_attaching = false
  val mutable tcl_run_soon = false
  val mutable tcl_is_running = false

  val mutable tcl_last_timer = (None : tcl_timer_handler ref option)

  val mutable tcl_last_file_handlers =
                (Hashtbl.create 1 :
		   (Unix.file_descr, tcl_file_handler_rec) Hashtbl.t)

  method private tcl_attach ?(run_soon=false) () =
    (* Creates an idle callback to reschedule events the next time the
     * event loop is entered. This step can be omitted when this method
     * is called from a Unixqueue callback (it is ensured tcl_setup
     * will be invoked soon).
     *
     * run_soon: if true, the Unixqueue is run once from the idle
     * callback. This can be used to process additional, non-file events.
     *)
    if not tcl_is_running then (
      (* prerr_endline "ATTACH!"; *)
      if not tcl_attaching then (
	tcl_attaching <- true;
	( match tcl_last_timer with
	      Some th -> delete_timer th; tcl_last_timer <- None
	    | None    -> ()
	);
	tcl_last_timer <- Some (create_timer 
				  (fun () ->
				     self#tcl_setup();
				     if tcl_run_soon then (
				       tcl_run_soon <- false;
				       self#tcl_safe_handler ([],[],[],0.0) ()
				     )
				  )
				  0);
      );
      tcl_run_soon <- tcl_run_soon || run_soon;
    )
    (* else prerr_endline "(no attach)"; *)


  method private tcl_setup() =
    let (infiles, outfiles, oobfiles, time) as watch_tuple = super#setup() in

    let ht = Hashtbl.create 50 (* n *) in   (* 50 should be enough *)

    (* Fill ht, the new hash table of file handlers: *)
    List.iter
      (fun fd ->
	 let r =
	   try Hashtbl.find ht fd
	   with Not_found ->
	     let r' =
	       { tcl_fh = null_fh; tcl_fd = fd; tcl_mask = 0 } in
	     Hashtbl.add ht fd r';
	     r'
	 in
	 r.tcl_mask <- r.tcl_mask lor 1)
      infiles;
    
    List.iter
      (fun fd ->
	 let r =
	   try Hashtbl.find ht fd
	   with Not_found ->
	     let r' =
	       { tcl_fh = null_fh; tcl_fd = fd; tcl_mask = 0 } in
	     Hashtbl.add ht fd r';
	     r'
	 in
	 r.tcl_mask <- r.tcl_mask lor 2)
      outfiles;
    
    List.iter
      (fun fd ->
	 let r =
	   try Hashtbl.find ht fd
	   with Not_found ->
	     let r' =
	       { tcl_fh = null_fh; tcl_fd = fd; tcl_mask = 0 } in
	     Hashtbl.add ht fd r';
	     r'
       in
	 r.tcl_mask <- r.tcl_mask lor 4)
      oobfiles;

    (* Remove all TCL file handlers *)
    Hashtbl.iter
      (fun fd r ->
	 (* Only delete if the new condition is different: *)
	 if
	   try
	     let r' = Hashtbl.find ht fd in
	     r'.tcl_mask <> r.tcl_mask
	   with
	       Not_found -> true
	 then begin
	   let fh = r.tcl_fh in
	   r.tcl_fh <- null_fh;        (* to avoid race condition with GC *)
	   (* prerr_endline "DeleteFileHandler"; *)
	   tcl_DeleteFileHandler fh
	 end
      )
      tcl_last_file_handlers;

    (* Create the new file handlers *)
    Hashtbl.iter
      (fun fd r ->
	 (* Only create if the new condition is different: *)
	 let r' = 
	   try
	     Hashtbl.find tcl_last_file_handlers fd 
	   with
	       Not_found -> dummy_fh   (* dummy_fh.tcl_mask <> r.tcl_mask *)
	 in
	 if r'.tcl_mask <> r.tcl_mask then (
	   (* prerr_endline ("CreateFileHandler mask=" ^ string_of_int r.tcl_mask); *)
	   r.tcl_fh <- tcl_CreateFileHandler 
			 (self#tcl_safe_handler watch_tuple)
			 fd
	                 r.tcl_mask )
	 else
	   r.tcl_fh <- r'.tcl_fh;
      )
      ht;
    
    (* Remember [ht] for next round: *)

    tcl_last_file_handlers <- ht;

    let watching_files = infiles <> [] || 
			 outfiles <> [] || 
			 oobfiles <> [] in
    

    (* Remove the old timer, if any. *)
    begin match tcl_last_timer with
	None -> ()
      | Some th -> 
	  delete_timer th;
	  tcl_last_timer <- None;
    end;
    tcl_attaching <- false;

    (* Set the new timer, if necessary *)
    if time >= 0.0 then begin
      (* prerr_endline ("Timeout: " ^ string_of_float time); *)
      tcl_last_timer <- Some (create_timer
				(self#tcl_safe_handler watch_tuple)
				(int_of_float
				   (((*min*) time (*1.0*)) *. 1E3 +. 0.5)));
    end;

    (* If no handler is active, detach. *)
    (*
    if tcl_last_timer = None && not watching_files then begin
      tcl_attached <- false;
      (* prerr_endline "Detached!"; *)
    end;
    *)

  method private tcl_safe_handler watch_tuple () =
    try
      self#tcl_handler watch_tuple ()
    with
	any ->
	  prerr_endline("Uq_tcl: Internal uncaught exception: " ^
			Printexc.to_string any);

  method private tcl_handler 
                   ((infiles, outfiles, oobfiles, time) as watch_tuple) () =

    (* IMPORTANT:
     * It is possible that this is a "ghost event". We need to test whether
     * there is a resource for the event or not.
     *)

    (* Do now a 'select' with zero timeout to test the file descriptors. *)

    let (infiles', outfiles', oobfiles') as actual_tuple =
      (* (infiles', outfiles', oobfiles'): Lists of file descriptors that
       * can be handled
       *)
      Unix.select infiles outfiles oobfiles 0.0
	(* Because of the timeout value 0.0, this "select" call cannot block,
	 * and it cannot raise EINTR.
	 *)
    in

    (* Now we have in infiles', outfiles', oobfiles' the actually happened
     * file descriptor events.
     * Furthermore, pure timeout events may have happened, but this is not
     * indicated specially.
     *)
    ignore(self#queue_events actual_tuple);

    (* Now run the queue (without source). *)
    begin try
      tcl_is_running <- true;
      match run with
	  None   -> super#run()
	| Some r -> r (self : #event_system :> event_system) super#run;
    with
	any ->
	  prerr_endline ("Uq_tcl: Uncaught exception: " ^
			 Printexc.to_string any
			);
    end;
    tcl_is_running <- false;
    
    (* Set up for the next round. *)
    self#tcl_setup ();

  (**********************************************************************)
  (* Overriden methods                                                  *)
  (**********************************************************************)
 
  method private source _ =
    (* Override this method: All events are coming from the tcl loop,
     * so disable this source of events
     *)
    ()

  (* After certain method invocations, we must ensure we are attached: *)

  method add_resource g (op,t) =
    super # add_resource g (op,t);
    self # tcl_attach()

  method remove_resource g op =
    super # remove_resource g op;
    self # tcl_attach()

  method add_event e =
    super # add_event e;
    self # tcl_attach ~run_soon:true ()


  method run() =
    (* Calling this method is an error! *)
    failwith "tcl_event_system#run: This method is disabled. Run the TCL event loop instead!"

end
;;