diff --git a/OMakefile b/OMakefile index ea86327..b9ee5dc 100644 --- a/OMakefile +++ b/OMakefile @@ -21,6 +21,11 @@ section tests.cmo: tests$(EXT_OBJ): + dispatch_tests.cmx: + dispatch_tests.cmi: + dispatch_tests.cmo: + dispatch_tests$(EXT_OBJ): + OCamlProgram(tests, tests dispatch_tests dispatch chat irc command iobuf client channel) .PHONY: test diff --git a/dispatch.ml b/dispatch.ml index bcafc69..8f51a13 100644 --- a/dispatch.ml +++ b/dispatch.ml @@ -1,125 +1,128 @@ -type fd_handler = t -> event -> Unix.file_descr -> unit -type timeout_handler = t -> float -> unit -type timeout = (float * timeout_handler) - -module Fd_map = - Map.Make (struct - type t = Unix.file_descr - let compare = compare - ) - -module Timeout_set = - Set.Make (struct - type t = timeout - let compare = compare - ) - type event = Input | Priority | Output | Error | Hangup +type timer_handler = float -> unit +type fd_handler = Unix.file_descr -> event list -> unit + +module Timer = + Set.Make (struct + type t = (float * timer_handler) + let compare = compare + end) + +module Fd_map = + Map.Make (struct + type t = Unix.file_descr + let compare = compare + end) type t = { e : Epoll.t; fds : (fd_handler * event list) Fd_map.t ref; numfds : int ref; - timeouts : timeout_handler Timeout_set.t ref; + timers : Timer.t ref; } -let rec epoll_events_of_events - | [] -> [] - | Input :: tl -> Epoll.In @ (epoll_events_of_events tl) - | Priority :: tl -> Epoll.Priority @ (epoll_events_of_events tl) - | Output :: tl -> Epoll.Output @ (epoll_events_of_events tl) - | Error :: tl -> Epoll.Error @ (epoll_events_of_events tl) - | Hangup :: tl -> Epoll.Hangup @ (epoll_events_of_events tl) + +let to_epoll = function + | Input -> Epoll.In + | Priority -> Epoll.Priority + | Output -> Epoll.Out + | Error -> Epoll.Error + | Hangup -> Epoll.Hangup + +let from_epoll = function + | Epoll.In -> Input + | Epoll.Priority -> Priority + | Epoll.Out -> Output + | Epoll.Error -> Error + | Epoll.Hangup -> Hangup + +let rec epoll_events_of_events = List.map to_epoll -let rec events_of_epoll_events - | [] -> [] - | Epoll.In :: tl -> Input @ (events_of_epoll_events) - | Epoll.Priority :: tl -> Priority @ (events_of_epoll_events) - | Epoll.Out :: tl -> Out @ (events_of_epoll_events) - | Epoll.Error :: tl -> Error @ (events_of_epoll_events) - | Epoll.Hangup :: tl -> Hangup @ (events_of_epoll_events) +let rec events_of_epoll_events = List.map from_epoll let create size = {e = Epoll.create size; fds = ref Fd_map.empty; numfds = ref 0; - timeouts = ref Timeout_set.empty} + timers = ref Timer.empty} let destroy d = Epoll.destroy d.e; - (* Explicitly unreference fds and timeouts, in case d sticks around *) + (* Explicitly unreference fds and timers, in case d sticks around *) d.fds := Fd_map.empty; d.numfds := 0; - d.timeouts := Timeout_set.empty + d.timers := Timer.empty let add d fd handler events = Epoll.ctl d.e Epoll.Add (fd, (epoll_events_of_events events)); - d.fds := Fd_map.add fd (handler, events) !d.fds; - d.numfds := !d.numfds + 1 + d.fds := Fd_map.add fd (handler, events) !(d.fds); + d.numfds := !(d.numfds) + 1 let modify d fd events = Epoll.ctl d.e Epoll.Modify (fd, (epoll_events_of_events events)) let set_handler d fd handler = - let (_, events) = Fd_map.find fd in - d.fds := Fd_map.add fd (handler, events) !d.fds + let (_, events) = Fd_map.find fd !(d.fds) in + d.fds := Fd_map.add fd (handler, events) !(d.fds) let delete d fd = Epoll.ctl d.e Epoll.Delete (fd, []); - d.fds := Fd_map.remove fd !d.fds; - d.numfds := !d.numfds - 1 + d.fds := Fd_map.remove fd !(d.fds); + d.numfds := !(d.numfds) - 1 -let add_timeout d time handler = - d.timeouts := Timeout_set.add (time, handler) !d.timeouts +let add_timer d time handler = + d.timers := Timer.add (time, handler) !(d.timers) -let delete d time = +let delete_timer d time = let may_remain (time', _) = time' <> time in - d.timeouts := Timeout_set.filter may_remain !d.timeouts + d.timers := Timer.filter may_remain !(d.timers) -let rec dispatch_timeouts d now = - let (time, handler) = Timeout_set.min_elt !d.timeouts in - if now > time then - () - else begin - handler d time; - d.timeouts := Timeout_set.remove time !d.timeouts; - dispatch_timeouts d now - end +let rec dispatch_timers d now = + if (!(d.timers) != Timer.empty) then + let (time, handler) = Timer.min_elt !(d.timers) in + if now > time then + () + else begin + handler time; + d.timers := Timer.remove (time, handler) !(d.timers); + dispatch_timers d now + end let rec dispatch_results d events_list = match events_list with | [] -> - () + () | (fd, epoll_events) :: tl -> - let handler = Fd_map.find fd !d.fds in - let events = events_of_epoll_events in - handler d fd events; - dispatch_results d tl + let handler, _ = Fd_map.find fd !(d.fds) in + let events = events_of_epoll_events epoll_events in + handler fd events; + dispatch_results d tl let once d = let now = Unix.time () in let timeout = try - let (time, _) = Timeout_set.min_elt !d.timeouts in - let timeout_s = max (time - now) 0.0 in - int_of_float (timeout_s *. 1000.0) + let (time, _) = Timer.min_elt !(d.timers) in + let timeout_s = max (time -. now) 0.0 in + int_of_float (timeout_s *. 1000.0) with Not_found -> -1 in - let result = Epoll.wait d.e !d.nfds timeout in - dispatch_timeouts d (Unix.time ()); + let result = Epoll.wait d.e !(d.numfds) timeout in + dispatch_timers d (Unix.time ()); dispatch_results d result + let rec run d = - if ((!d.fds == Fd_map.empty) && - (!d.timeouts == Timeout_set.empty)) then + if ((!(d.fds) == Fd_map.empty) && + (!(d.timers) == Timer.empty)) then () else begin once d; run d end - + diff --git a/dispatch.mli b/dispatch.mli index 218cb3c..566cbbb 100644 --- a/dispatch.mli +++ b/dispatch.mli @@ -4,13 +4,13 @@ type t type event = Input | Priority | Output | Error | Hangup (** An event associated with a file descriptor *) -type fd_handler = t -> Unix.file_descr -> event list -> unit +type fd_handler = Unix.file_descr -> event list -> unit (** [fd_handler d fd evt] handles an [event] generated by dispatcher [d] *) -type timeout_handler = t -> float -> unit -(** [timeout_handler d when] is called at or after [when] by dispatcher [d] *) +type timer_handler = float -> unit +(** [timer_handler d when] is called at or after [when] by dispatcher [d] *) -val create : [size] -> t +val create : int -> t (** Create a new event dispatcher, preallocating [size] fd events. [size] is just a hint, the fd list will grow on demand. *) @@ -21,7 +21,7 @@ val add : t -> Unix.file_descr -> fd_handler -> event list -> unit (** [add d fd handler events] begins listening for [events] on file descriptor [fd], calling [handler] when an event occurs. *) -val modify : t -> Unix.file_descr -> event_list -> unit +val modify : t -> Unix.file_descr -> event list -> unit (** [modify d fd events] changes the events to listen for on fd *) val set_handler : t -> Unix.file_descr -> fd_handler -> unit @@ -32,12 +32,12 @@ val delete : t -> Unix.file_descr -> unit (** [delete d fd] stops [d] paying attention to events on file descriptor [fd] *) -val add_timeout : t -> float -> timeout_handler -> unit -(** [add_timeout d time handler] will cause dispatcher [d] to invoke +val add_timer : t -> float -> timer_handler -> unit +(** [add_timer d time handler] will cause dispatcher [d] to invoke [handler d time] at or after [time] *) -val delete_timeout : t -> float -> unit -(** [delete_timeout d time] prevents dispatcher from invoking any +val delete_timer : t -> float -> unit +(** [delete_timer d time] prevents dispatcher from invoking any handlers added for [time] *) val once : t -> unit @@ -46,4 +46,4 @@ val once : t -> unit val run : t -> unit (** [run d] will dispatch events from [d] until all file descriptors - have been removed and all timeouts have run or been removed *) + have been removed and all timers have run or been removed *) diff --git a/dispatch_tests.ml b/dispatch_tests.ml index fe518ac..d353aa7 100644 --- a/dispatch_tests.ml +++ b/dispatch_tests.ml @@ -6,7 +6,7 @@ let unit = (fun () -> let d = Dispatch.create 3 in let a,b = Unix.socketpair Unix.PF_UNIX Unix.SOCK_STREAM 0 in - let rec handle d fd events = + let rec handle fd events = match events with | [Dispatch.Input; Dispatch.Output] -> let s = String.create 4096 in @@ -23,5 +23,9 @@ let unit = let s = String.create 4096 in assert_equal 2 (Unix.read a s 0 4096); assert_equal "hi" (Str.string_before s 2); + + Dispatch.destroy d; + Unix.close a; + Unix.close b ); ]