libevent.ml

   1 (***********************************************************************)
   2 (* The ocaml-event library                                             *)
   3 (*                                                                     *)
   4 (* Copyright 2002, 2003 Maas-Maarten Zeeman. All rights reserved.      *)
   5 (* Copyright 2010 ygrek                                                *)
   6 (* See LICENCE for details.                                            *)
   7 (***********************************************************************)
   8
   9 type event
  10 type event_base
  11
  12 type event_flags =
  13     TIMEOUT
  14   | READ
  15   | WRITE
  16   | SIGNAL
  17
  18 let int_of_event_type = function
  19     TIMEOUT -> 0x01
  20   | READ -> 0x02
  21   | WRITE -> 0x04
  22   | SIGNAL -> 0x08
  23
  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))
  31
  32 type event_callback = Unix.file_descr -> event_flags -> unit
  33
  34 (* Use an internal hashtable to store the ocaml callbacks with the
  35    event *)
  36 let table = Hashtbl.create 0
  37
  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 *)
  43   in
  44   k fd (event_type_of_int etype)
  45
  46 (* Create an event *)
  47 external create : unit -> event = "oc_create_event"
  48
  49 (* Return the id of an event *)
  50 external event_id : event -> int = "oc_event_id"
  51
  52 (* Return the signal associated with the event *)
  53 external signal : event -> int = "oc_event_fd"
  54
  55 (* Return the fd associated with the event *)
  56 external fd : event -> Unix.file_descr = "oc_event_fd"
  57
  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"
  61
  62 let persist_flag = function true -> 0x10 | false -> 0
  63
  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
  67
  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
  73
  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
  78
  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
  83
  84 (* Add an event *)
  85 external add : event -> float option -> unit = "oc_event_add"
  86
  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
  92
  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)
  96
  97 external cactive : event -> int -> unit = "oc_event_active"
  98 let activate event flags = cactive event (int_of_event_type_list 0 flags)
  99
 100 (* Process events *)
 101 external dispatch : event_base -> unit = "oc_event_base_dispatch"
 102
 103 type loop_flags = ONCE | NONBLOCK
 104 external loop : event_base -> loop_flags -> unit = "oc_event_base_loop"
 105
 106 external init : unit -> event_base = "oc_event_base_init"
 107 external reinit : event_base -> unit = "oc_event_base_reinit"
 108 external free : event_base -> unit = "oc_event_base_free"
 109
 110 let () =
 111   Callback.register "event_cb" event_cb
 112
 113 (** Compatibility *)
 114 module Global = struct
 115
 116 let base = init ()
 117 let init () = reinit base
 118
 119 let set = set base
 120 let dispatch () = dispatch base
 121 let loop = loop base
 122
 123 end