irc-bot/dispatch.ml

134 lines
3.5 KiB
OCaml
Raw Normal View History

2009-02-08 22:26:27 -07:00
type event = Input | Output | Exception
2008-03-15 19:46:06 -06:00
type timer_handler = float -> unit
2009-02-08 22:26:27 -07:00
type fd_handler = Unix.file_descr -> event -> unit
2008-03-14 12:16:04 -06:00
2008-03-15 19:46:06 -06:00
module Timer =
2008-03-14 12:16:04 -06:00
Set.Make (struct
2008-03-15 19:46:06 -06:00
type t = (float * timer_handler)
let compare (time, handler) (time', handler') = compare time time'
2008-03-15 19:46:06 -06:00
end)
2008-03-14 12:16:04 -06:00
2008-03-15 19:46:06 -06:00
module Fd_map =
Map.Make (struct
type t = Unix.file_descr
let compare = compare
end)
2008-03-14 12:16:04 -06:00
type t = {
2009-02-08 22:26:27 -07:00
read_fds : Unix.file_descr list ref;
write_fds : Unix.file_descr list ref;
except_fds : Unix.file_descr list ref;
handlers : fd_handler Fd_map.t ref;
2008-03-15 19:46:06 -06:00
timers : Timer.t ref;
2008-03-14 12:16:04 -06:00
}
2010-12-09 08:22:44 -07:00
let create ?(size=5) () =
2009-02-08 22:26:27 -07:00
{read_fds = ref [];
write_fds = ref [];
except_fds = ref [];
handlers = ref Fd_map.empty;
2008-03-15 19:46:06 -06:00
timers = ref Timer.empty}
2008-03-14 12:16:04 -06:00
let destroy d =
2008-03-15 19:46:06 -06:00
(* Explicitly unreference fds and timers, in case d sticks around *)
2009-02-08 22:26:27 -07:00
d.handlers := Fd_map.empty;
2008-03-15 19:46:06 -06:00
d.timers := Timer.empty
2008-03-14 12:16:04 -06:00
2009-02-08 22:26:27 -07:00
let get_fds d event =
match event with
| Input -> d.read_fds
| Output -> d.write_fds
| Exception -> d.except_fds
2008-03-14 12:16:04 -06:00
let modify d fd events =
2009-02-08 22:26:27 -07:00
let add_event event =
let l = get_fds d event in
let nl = (List.filter ((<>) fd) !l) in
if List.mem event events then
l := fd :: nl
else
l := nl
in
if Fd_map.mem fd !(d.handlers) then
List.iter add_event [Input; Output; Exception]
else
raise Not_found
2008-03-14 12:16:04 -06:00
let set_handler d fd handler =
2009-02-08 22:26:27 -07:00
d.handlers := Fd_map.add fd handler !(d.handlers)
let add d fd handler events =
set_handler d fd handler;
modify d fd events
2008-03-14 12:16:04 -06:00
let delete d fd =
2009-02-08 22:26:27 -07:00
let del_event event =
let l = get_fds d event in
l := (List.filter ((<>) fd) !l)
in
d.handlers := Fd_map.remove fd !(d.handlers);
List.iter del_event [Input; Output; Exception]
2008-03-14 12:16:04 -06:00
let add_timer d handler time =
2008-03-15 19:46:06 -06:00
d.timers := Timer.add (time, handler) !(d.timers)
2008-03-14 12:16:04 -06:00
2008-03-15 19:46:06 -06:00
let delete_timer d time =
2008-03-14 12:16:04 -06:00
let may_remain (time', _) =
time' <> time
in
2008-03-15 19:46:06 -06:00
d.timers := Timer.filter may_remain !(d.timers)
2008-03-14 12:16:04 -06:00
2008-03-15 19:46:06 -06:00
let rec dispatch_timers d now =
2010-12-08 17:18:07 -07:00
if not (Timer.is_empty !(d.timers)) then
2008-03-15 19:46:06 -06:00
let (time, handler) = Timer.min_elt !(d.timers) in
if now < time then
2008-03-15 19:46:06 -06:00
()
else begin
handler time;
d.timers := Timer.remove (time, handler) !(d.timers);
dispatch_timers d now
end
2008-03-14 12:16:04 -06:00
2009-02-08 22:26:27 -07:00
let rec dispatch_results d (read_ready, write_ready, except_ready) =
let rec dispatch event fd_list =
match fd_list with
| [] ->
()
| fd :: tl ->
let handler = Fd_map.find fd !(d.handlers) in
handler fd event;
dispatch event tl
in
dispatch Input read_ready;
dispatch Output write_ready;
dispatch Exception except_ready
2008-03-14 12:16:04 -06:00
let once d =
2010-12-08 17:18:07 -07:00
(* You might think it'd work better to use the timeout of select().
Not so! select() waits *at most* timeout ms. Doing things
this way results in a tight loop as the timer approaches. *)
let interval =
2008-03-14 12:16:04 -06:00
try
2010-12-08 17:18:07 -07:00
let (next, _) = Timer.min_elt !(d.timers) in
let delta = (next -. (Unix.gettimeofday ())) in
max delta 0.0
2008-03-14 12:16:04 -06:00
with Not_found ->
2010-12-08 17:18:07 -07:00
0.0
2008-03-14 12:16:04 -06:00
in
2010-12-08 17:18:07 -07:00
let s = { Unix.it_interval = interval; Unix.it_value = 0.0 } in
let _ = Sys.set_signal Sys.sigalrm Sys.Signal_ignore in
let _ = Unix.setitimer Unix.ITIMER_REAL s in
let result = Unix.select !(d.read_fds) !(d.write_fds) !(d.except_fds) (-1.0) in
2009-02-08 22:26:27 -07:00
dispatch_results d result;
dispatch_timers d (Unix.gettimeofday ())
2008-03-15 19:46:06 -06:00
2010-12-08 17:18:07 -07:00
let rec run d =
if (Fd_map.is_empty !(d.handlers)) && (Timer.is_empty !(d.timers)) then
2008-03-14 12:16:04 -06:00
()
else begin
once d;
run d
end
2010-12-08 17:18:07 -07:00