libevent.ml

   1 (***********************************************************************)
   2 (* The OcamlEvent library                                              *)
   3 (*                                                                     *)
   4 (* Copyright 2002, 2003 Maas-Maarten Zeeman. All rights reserved. See  *)
   5 (* LICENCE for details.                                                *)
   6 (***********************************************************************)
   7
   8 (* $Id: liboevent.ml,v 1.1 2009-11-26 08:49:02 maas Exp $ *)
   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 = event -> 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 (event,cb) = Hashtbl.find table event_id in
  41   cb event fd (event_type_of_int etype)
  42
  43 (* Return the id of an event *)
  44 external event_id : event -> int = "oc_event_id"
  45
  46 (* Return the signal associated with the event *)
  47 external signal : event -> int = "oc_event_fd"
  48
  49 (* Return the fd associated with the event *)
  50 external fd : event -> Unix.file_descr = "oc_event_fd"
  51
  52 (* Set an event (not exported) *)
  53 external cset_fd : event_base -> Unix.file_descr -> int -> event = "oc_event_create"
  54 external cset_int : event_base -> int -> int -> event = "oc_event_create"
  55
  56 let persist_flag = function true -> 0x10 | false -> 0
  57
  58 (* Create events *)
  59 let create event_base fd etype persist (cb : event_callback) =
  60   let rec int_of_event_type_list flag = function
  61       h::t -> int_of_event_type_list (flag lor (int_of_event_type h)) t
  62     | [] -> flag
  63   in
  64   let flag = int_of_event_type_list (persist_flag persist) etype in
  65   let event = cset_fd event_base fd flag in
  66   Hashtbl.add table (event_id event) (event,cb);
  67   event
  68
  69 let create_timer event_base persist (cb : event -> unit) =
  70   let flag = persist_flag persist in
  71   let event = cset_int event_base (-1) flag in
  72   Hashtbl.add table (event_id event) (event, (fun e _ _ -> cb e));
  73   event
  74
  75 let create_signal event_base signal persist (cb : event_callback) =
  76   let flag = (int_of_event_type SIGNAL) lor (persist_flag persist) in
  77   let event = cset_int event_base signal flag in
  78   Hashtbl.add table (event_id event) (event,cb);
  79   event
  80
  81 (* Add an event *)
  82 external add : event -> float option -> unit = "oc_event_add"
  83
  84 (* Del an event  *)
  85 external cdel : event -> unit = "oc_event_del"
  86 let del event =
  87   Hashtbl.remove table (event_id event);
  88   cdel event
  89
  90 (* *)
  91 (* Not fully implemented yet *)
  92 external pending : event -> event_flags list -> bool = "oc_event_pending"
  93
  94 (* Process events *)
  95 external dispatch : event_base -> unit = "oc_event_base_dispatch"
  96
  97 type loop_flags = ONCE | NONBLOCK
  98 external loop : event_base -> loop_flags -> unit = "oc_event_base_loop"
  99
 100 external init : unit -> event_base = "oc_event_base_init"
 101 external reinit : event_base -> unit = "oc_event_base_reinit"
 102 external free : event_base -> unit = "oc_event_base_free"
 103
 104 let () =
 105   Callback.register "event_cb" event_cb
 106
 107 (** Compatibility *)
 108 module Global = struct
 109
 110 let base = init ()
 111 let init () = reinit base
 112
 113 let create = create base
 114 let dispatch () = dispatch base
 115 let loop = loop base
 116
 117 end
 118