release 0.9.0
[ocaml-event.git] / libevent.ml
blobc9855d8f47e6d69300213d0ebdf19d2d86c21746
1 (***********************************************************************)
2 (* The ocaml-libevent library *)
3 (* *)
4 (* Copyright 2002, 2003 Maas-Maarten Zeeman. All rights reserved. *)
5 (* Copyright 2010 ygrek *)
6 (* See LICENCE for details. *)
7 (***********************************************************************)
9 type event
10 type event_base
12 type event_flags =
13 TIMEOUT
14 | READ
15 | WRITE
16 | SIGNAL
18 let int_of_event_type = function
19 TIMEOUT -> 0x01
20 | READ -> 0x02
21 | WRITE -> 0x04
22 | SIGNAL -> 0x08
24 let event_type_of_int = function
25 | 1 -> TIMEOUT
26 | 2 -> READ
27 | 4 -> WRITE
28 | 6 -> READ (* READ|WRITE *)
29 | 8 -> SIGNAL
30 | n -> raise (Invalid_argument (Printf.sprintf "event_type %d" n))
32 type event_callback = Unix.file_descr -> event_flags -> unit
34 (* Use an internal hashtable to store the ocaml callbacks with the
35 event *)
36 let table = Hashtbl.create 0
38 (* Called by the c-stub, locate, and call the ocaml callback *)
39 let event_cb event_id fd etype =
40 let k =
41 try Hashtbl.find table event_id
42 with Not_found -> (fun _ _ -> ()) (* it may happen, cf. activate *)
44 k fd (event_type_of_int etype)
46 (* Create an event *)
47 external create : unit -> event = "oc_create_event"
49 (* Return the id of an event *)
50 external event_id : event -> int = "oc_event_id"
52 (* Return the signal associated with the event *)
53 external signal : event -> int = "oc_event_fd"
55 (* Return the fd associated with the event *)
56 external fd : event -> Unix.file_descr = "oc_event_fd"
58 (* Set an event (not exported) *)
59 external cset_fd : event_base -> event -> Unix.file_descr -> int -> unit = "oc_event_set"
60 external cset_int : event_base -> event -> int -> int -> unit = "oc_event_set"
62 let persist_flag = function true -> 0x10 | false -> 0
64 let rec int_of_event_type_list flag = function
65 | h::t -> int_of_event_type_list (flag lor (int_of_event_type h)) t
66 | [] -> flag
68 (* Event set *)
69 let set base event fd etype persist (cb : event_callback) =
70 let flag = int_of_event_type_list (persist_flag persist) etype in
71 Hashtbl.replace table (event_id event) cb;
72 cset_fd base event fd flag
74 let set_timer base event persist (cb : unit -> unit) =
75 let flag = persist_flag persist in
76 Hashtbl.replace table (event_id event) (fun _ _ -> cb ());
77 cset_int base event (-1) flag
79 let set_signal base event signal persist (cb : event_callback) =
80 let flag = (int_of_event_type SIGNAL) lor (persist_flag persist) in
81 Hashtbl.replace table (event_id event) cb;
82 cset_int base event signal flag
84 (* Add an event *)
85 external add : event -> float option -> unit = "oc_event_add"
87 (* Del an event *)
88 external cdel : event -> unit = "oc_event_del"
89 let del event =
90 Hashtbl.remove table (event_id event);
91 cdel event
93 (* Check whether event is pending *)
94 external cpending : event -> int -> bool = "oc_event_pending"
95 let pending event flags = cpending event (int_of_event_type_list 0 flags)
97 external cactive : event -> int -> unit = "oc_event_active"
98 let activate event flags = cactive event (int_of_event_type_list 0 flags)
100 (* Process events *)
101 external dispatch : event_base -> unit = "oc_event_base_dispatch"
103 type loop_flag = ONCE | NONBLOCK
104 external loops : event_base -> loop_flag list -> unit = "oc_event_base_loop"
105 let loop events flag = loops events [flag]
107 external init : unit -> event_base = "oc_event_base_init"
108 external reinit : event_base -> unit = "oc_event_base_reinit"
109 external free : event_base -> unit = "oc_event_base_free"
111 let () =
112 Callback.register "event_cb" event_cb
114 (** Compatibility *)
115 module Global = struct
117 let base = init ()
118 let init () = reinit base
120 let set = set base
121 let dispatch () = dispatch base
122 let loop = loop base
123 let loops = loops base