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 : event_base -> 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_int : event -> int -> int -> unit = "oc_event_set"
  57
  58 let persist_flag = function true -> 0x10 | false -> 0
  59
  60 (* Event set *)
  61 let set event fd etype persist (cb : event_callback) =
  62   let rec int_of_event_type_list flag = function
  63       h::t -> int_of_event_type_list (flag lor (int_of_event_type h)) t
  64     | [] -> flag
  65   in
  66   let flag = int_of_event_type_list (persist_flag persist) etype in
  67   Hashtbl.replace table (event_id event) cb;
  68   cset_fd event fd flag
  69
  70 let set_timer event persist (cb : unit -> unit) =
  71   let flag = persist_flag persist in
  72   Hashtbl.replace table (event_id event) (fun _ _ -> cb ());
  73   cset_int event (-1) flag
  74
  75 let set_signal event signal persist (cb : event_callback) =
  76   let flag = (int_of_event_type SIGNAL) lor (persist_flag persist) in
  77   Hashtbl.replace table (event_id event) cb;
  78   cset_int event signal flag
  79
  80 (* Add an event *)
  81 external add : event -> float option -> unit = "oc_event_add"
  82
  83 (* Del an event  *)
  84 external cdel : event -> unit = "oc_event_del"
  85 let del event =
  86   Hashtbl.remove table (event_id event);
  87   cdel event
  88
  89 (* *)
  90 (* Not fully implemented yet *)
  91 external pending : event -> event_flags list -> bool = "oc_event_pending"
  92
  93 (* Process events *)
  94 external dispatch : event_base -> unit = "oc_event_base_dispatch"
  95
  96 type loop_flags = ONCE | NONBLOCK
  97 external loop : event_base -> loop_flags -> unit = "oc_event_base_loop"
  98
  99 external init : unit -> event_base = "oc_event_base_init"
 100 external reinit : event_base -> unit = "oc_event_base_reinit"
 101 external free : event_base -> unit = "oc_event_base_free"
 102
 103 let () =
 104   Callback.register "event_cb" event_cb
 105
 106 (** Compatibility *)
 107 module Global = struct
 108
 109 let base = init ()
 110 let init () = reinit base
 111
 112 let create () = create base
 113 let dispatch () = dispatch base
 114 let loop = loop base
 115
 116 end
 117