1 (***********************************************************************)
2 (* The OcamlEvent library *)
4 (* Copyright 2002, 2003 Maas-Maarten Zeeman. All rights reserved. See *)
5 (* LICENCE for details. *)
6 (***********************************************************************)
8 (* $Id: liboevent.ml,v 1.1 2009-11-26 08:49:02 maas Exp $ *)
18 let int_of_event_type = function
24 let event_type_of_int = function
28 | 6 -> READ
(* READ|WRITE *)
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
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
=
41 try Hashtbl.find
table event_id
42 with Not_found
-> assert false
44 k fd
(event_type_of_int etype
)
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
65 let set base event fd etype persist
(cb
: event_callback
) =
66 let rec int_of_event_type_list flag
= function
67 h
::t
-> int_of_event_type_list (flag
lor (int_of_event_type h
)) t
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
85 external add
: event
-> float option -> unit = "oc_event_add"
88 external cdel
: event
-> unit = "oc_event_del"
90 Hashtbl.remove
table (event_id event
);
94 (* Not fully implemented yet *)
95 external pending
: event
-> event_flags list
-> bool = "oc_event_pending"
98 external dispatch
: event_base
-> unit = "oc_event_base_dispatch"
100 type loop_flags
= ONCE
| NONBLOCK
101 external loop
: event_base
-> loop_flags
-> unit = "oc_event_base_loop"
103 external init
: unit -> event_base
= "oc_event_base_init"
104 external reinit
: event_base
-> unit = "oc_event_base_reinit"
105 external free
: event_base
-> unit = "oc_event_base_free"
108 Callback.register
"event_cb" event_cb
111 module Global
= struct
114 let init () = reinit
base
117 let dispatch () = dispatch base