(* $Id: uq_libevent.ml 1635 2011-06-26 15:20:34Z gerd $ *) module type LIBOEVENT = sig type event type event_flags = TIMEOUT | READ | WRITE | SIGNAL type event_callback = Unix.file_descr -> event_flags -> unit val create : unit -> event val set : event -> Unix.file_descr -> event_flags list -> persist:bool -> event_callback -> unit val add : event -> float option -> unit val del : event -> unit type loop_flags = ONCE | NONBLOCK val loop : loop_flags -> unit end module type POLLSET = sig val create_pollset : unit -> Netsys_pollset.pollset val create_event_system : unit -> Unixqueue.event_system end let fd_equal = match Sys.os_type with | "Win32" -> (fun fd1 fd2 -> fd1=fd2) | _ -> (fun (fd1:Unix.file_descr) fd2 -> (Obj.magic fd1 : int) = (Obj.magic fd2 : int) ) let fd_hash = match Sys.os_type with | "Win32" -> (fun fd -> Hashtbl.hash fd) | _ -> (fun fd -> (Obj.magic fd : int)) module FdTbl = Hashtbl.Make (struct type t = Unix.file_descr let equal = fd_equal let hash = fd_hash end ) module Make(L:LIBOEVENT) = struct let create_pollset() : Netsys_pollset.pollset = let ht_req = FdTbl.create 5 in let ht_act = FdTbl.create 5 in let wait_ev = L.create() in let wait_ev_added = ref false in ( object(self) method find fd = let (req,ev) = FdTbl.find ht_req fd in req method add fd req = let ev = try let (_,old_ev) = FdTbl.find ht_req fd in L.del old_ev; old_ev with Not_found -> L.create() in let (r,w,_) = Netsys_posix.poll_req_triple req in let flags = (if r then [L.READ] else []) @ (if w then [L.WRITE] else []) in L.set ev fd flags ~persist:true self#callback; L.add ev None; FdTbl.replace ht_req fd (req,ev) method remove fd = try let (_,ev) = FdTbl.find ht_req fd in L.del ev; FdTbl.remove ht_req fd; FdTbl.remove ht_act fd with Not_found -> () method wait tmo = FdTbl.clear ht_act; if !wait_ev_added then L.del wait_ev; L.set wait_ev (Obj.magic (-1)) [] ~persist:true (fun _ _ -> ()); L.add wait_ev (Some tmo); wait_ev_added := true; L.loop L.ONCE; FdTbl.fold (fun fd act_n acc -> let (req,ev) = try FdTbl.find ht_req fd with Not_found -> assert false in let act = Netsys_posix.act_events_of_int act_n in (fd, req, act) :: acc ) ht_act [] method private callback fd flag = try let act = ( match flag with | L.READ -> Netsys_posix.const_rd_event | L.WRITE -> Netsys_posix.const_wr_event | _ -> raise Not_found ) lor ( try FdTbl.find ht_act fd with Not_found -> 0 ) in FdTbl.replace ht_act fd act with | Not_found -> () method dispose() = () method cancel_wait _ = failwith "Uq_libevent.cancel_wait: not supported" end ) let create_event_system() = Unixqueue_pollset.pollset_event_system (create_pollset()) end