liboevent.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 = 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   (Hashtbl.find table event_id) fd (event_type_of_int etype)
  41
  42 (* Create an event *)
  43 external create : unit -> event = "oc_create_event"
  44
  45 (* Return the id of an event *)
  46 external event_id : event -> int = "oc_event_id"
  47
  48 (* Return the signal associated with the event *)
  49 external signal : event -> int = "oc_event_fd"
  50
  51 (* Return the fd associated with the event *)
  52 external fd : event -> Unix.file_descr = "oc_event_fd"
  53
  54 (* Set an event (not exported) *)
  55 external cset_fd : event -> Unix.file_descr -> int -> unit = "oc_event_set"
  56 external cset_timer : event -> unit = "oc_event_set_timer"
  57 external cset_int : event -> int -> int -> unit = "oc_event_set"
  58
  59 (* Event set *)
  60 let set event fd etype persist (cb : event_callback) =
  61   let rec int_of_event_type_list flag = function
  62       h::t -> int_of_event_type_list (flag lor (int_of_event_type h)) t
  63     | [] -> flag
  64   in
  65   let flag =
  66     let f = int_of_event_type_list 0 etype in
  67     if persist then
  68       f lor 0x10
  69     else
  70       f
  71   in
  72   Hashtbl.add table (event_id event) cb;
  73   cset_fd event fd flag
  74
  75 let set_timer event (cb : unit -> unit) =
  76   Hashtbl.add table (event_id event) (fun _ _ -> cb ());
  77   cset_timer event
  78
  79 let set_signal event signal persist (cb : event_callback) =
  80   let signal_flag = (int_of_event_type SIGNAL) in
  81   let flag = if persist then
  82     signal_flag lor 0x10
  83   else
  84     signal_flag
  85   in
  86   Hashtbl.add table (event_id event) cb;
  87   cset_int event signal flag
  88
  89 (* Add an event *)
  90 external add : event_base -> event -> float option -> unit = "oc_event_base_add"
  91
  92 (* Del an event  *)
  93 external cdel : event -> unit = "oc_event_del"
  94 let del event =
  95   Hashtbl.remove table (event_id event);
  96   cdel event
  97
  98 (* *)
  99 (* Not fully implemented yet *)
 100 external pending : event -> event_flags list -> bool = "oc_event_pending"
 101
 102 (* Process events *)
 103 external dispatch : event_base -> unit = "oc_event_base_dispatch"
 104
 105 type loop_flags = ONCE | NONBLOCK
 106 external loop : event_base -> loop_flags -> unit = "oc_event_base_loop"
 107
 108 external init : unit -> event_base = "oc_event_base_init"
 109 external reinit : event_base -> unit = "oc_event_base_reinit"
 110 external free : event_base -> unit = "oc_event_base_free"
 111
 112 let () =
 113   Callback.register "event_cb" event_cb
 114
 115 (** Compatibility *)
 116 module Global = struct
 117
 118 let base = init ()
 119 let init () = reinit base
 120
 121 let add = add base
 122 let dispatch () = dispatch base
 123 let loop = loop base
 124
 125 end
 126