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: libevent.ml,v 1.1 2004/12/18 21:58:25 maas Exp $ *)
   9 type event
  10
  11 type event_flags =
  12     TIMEOUT
  13   | READ
  14   | WRITE
  15   | SIGNAL
  16
  17 let int_of_event_type = function
  18     TIMEOUT -> 0x01
  19   | READ -> 0x02
  20   | WRITE -> 0x04
  21   | SIGNAL -> 0x08
  22
  23 type event_callback = Unix.file_descr -> event_flags -> unit
  24
  25 (* Use an internal hashtable to store the ocaml callbacks with the
  26    event *)
  27 let table = Hashtbl.create 0
  28
  29 (* Called by the c-stub, locate, and call the ocaml callback *)
  30 let event_cb event_id fd etype =
  31   (Hashtbl.find table event_id) fd etype
  32
  33 (* Create an event *)
  34 external create : unit -> event = "oc_create_event"
  35
  36 (* Return the id of an event *)
  37 external event_id : event -> int = "oc_event_id"
  38
  39 (* Return the signal associated with the event *)
  40 external signal : event -> int = "oc_event_fd"
  41
  42 (* Return the fd associated with the event *)
  43 external fd : event -> Unix.file_descr = "oc_event_fd"
  44
  45 (* Set an event (not exported) *)
  46 external cset_fd : event -> Unix.file_descr -> int -> unit = "oc_event_set"
  47 external cset_int : event -> int -> int -> unit = "oc_event_set"
  48
  49 (* Event set *)
  50 let set event fd etype persist (cb : event_callback) =
  51   let rec int_of_event_type_list flag = function
  52       h::t -> int_of_event_type_list (flag lor (int_of_event_type h)) t
  53     | [] -> flag
  54   in
  55   let flag =
  56     let f = int_of_event_type_list 0 etype in
  57     if persist then
  58       f lor 0x10
  59     else
  60       f
  61   in
  62   Hashtbl.add table (event_id event) cb;
  63   cset_fd event fd flag
  64
  65 let set_signal event signal persist (cb : event_callback) =
  66   let signal_flag = (int_of_event_type SIGNAL) in
  67   let flag = if persist then
  68     signal_flag lor 0x10
  69   else
  70     signal_flag
  71   in
  72   Hashtbl.add table (event_id event) cb;
  73   cset_int event signal flag
  74
  75 (* Add an event *)
  76 external add : event -> float option -> unit = "oc_event_add"
  77
  78 (* Del an event  *)
  79 external cdel : event -> unit = "oc_event_del"
  80 let del event =
  81   Hashtbl.remove table (event_id event);
  82   cdel event
  83
  84 (* *)
  85 (* Not fully implemented yet *)
  86 external pending : event -> event_flags list -> bool = "oc_event_pending"
  87
  88 (* Process events *)
  89 external dispatch : unit -> unit = "oc_event_dispatch"
  90
  91 type loop_flags = ONCE | NONBLOCK
  92 external loop : loop_flags -> unit = "oc_event_loop"
  93
  94 (* Initialize the event library *)
  95 external init : unit -> unit = "oc_event_init"
  96 let _ =
  97   Callback.register "event_cb" event_cb;
  98   init ()
  99
 100
 101