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