event_stubs.c

   1 /************************************************************************/
   2 /* The OcamlEvent library                                               */
   3 /*                                                                      */
   4 /* Copyright 2002, 2003, 2004 Maas-Maarten Zeeman. All rights reserved. */
   5 /* See LICENCE for details.                                             */
   6 /************************************************************************/
   7
   8 /* $Id: event_stubs.c,v 1.2 2009-11-26 08:41:10 maas Exp $ */
   9
  10 /* Stub code to interface Ocaml with libevent */
  11
  12 #include <sys/time.h>
  13 #include <stdlib.h>
  14 #include <event.h>
  15 #include <string.h>
  16
  17 #include <caml/mlvalues.h>
  18 #include <caml/custom.h>
  19 #include <caml/alloc.h>
  20 #include <caml/memory.h>
  21 #include <caml/callback.h>
  22 #include <caml/fail.h>
  23 #include <caml/unixsupport.h>
  24 #include <caml/signals.h>
  25
  26 #define struct_event_val(v) (*(struct event**) Data_custom_val(v))
  27 #define Is_some(v) (Is_block(v))
  28
  29 /* FIXME use custom block */
  30 #define struct_event_base_val(v) (struct event_base*)(v)
  31 #define Val_struct_event_base(base) ((value)(base))
  32
  33 static value * event_cb_closure = NULL;
  34
  35 /* FIXME use dedicated exception */
  36 static void raise_error(char const* str, char const* arg)
  37 {
  38   uerror((char*)str, NULL == arg ? Nothing : caml_copy_string(arg));
  39 }
  40
  41 static void
  42 struct_event_finalize(value ve)
  43 {
  44   struct event *ev = struct_event_val(ve);
  45
  46   if (event_initialized(ev)) {
  47     event_del(ev);
  48   }
  49
  50   caml_stat_free(struct_event_val(ve));
  51 }
  52
  53 static int
  54 struct_event_compare(value v1, value v2)
  55 {
  56   struct event *p1 = struct_event_val(v1);
  57   struct event *p2 = struct_event_val(v2);
  58   if(p1 == p2) return 0;
  59   if(p1 < p2) return -1;
  60   return 1;
  61 }
  62
  63 static long
  64 struct_event_hash(value v)
  65 {
  66   return (long) struct_event_val(v);
  67 }
  68
  69 static struct custom_operations struct_event_ops = {
  70   "struct event",
  71   struct_event_finalize,
  72   struct_event_compare,
  73   struct_event_hash,
  74   custom_serialize_default,
  75   custom_deserialize_default
  76 };
  77
  78 /*
  79  * This callback calls the ocaml event callback, which will in turn
  80  * call the real ocaml callback.
  81  */
  82 static void
  83 event_cb(int fd, short type, void *arg)
  84 {
  85   caml_leave_blocking_section();
  86   callback3(*event_cb_closure,
  87             Val_long((long) arg), Val_int(fd), Val_int(type));
  88   caml_enter_blocking_section();
  89 }
  90
  91 static void
  92 set_struct_timeval(struct timeval *tv, value vfloat)
  93 {
  94   double timeout = Double_val(vfloat);
  95   tv->tv_sec = (int) timeout;
  96   tv->tv_usec = (int) (1e6 * (timeout - tv->tv_sec));
  97 }
  98
  99 CAMLprim value
 100 oc_create_event(value u)
 101 {
 102   CAMLparam1(u);
 103   CAMLlocal1(ve);
 104   struct event* ev = caml_stat_alloc(sizeof(struct event));
 105   memset(ev, 0, sizeof(*ev));
 106
 107   ve = caml_alloc_custom(&struct_event_ops, sizeof(struct event*), 0, 1);
 108   struct_event_val(ve) = ev;
 109
 110   CAMLreturn(ve);
 111 }
 112
 113 CAMLprim value
 114 oc_event_id(value vevent)
 115 {
 116   CAMLparam0();
 117   CAMLreturn(Val_long((long) struct_event_val(vevent)));
 118 }
 119
 120 CAMLprim value
 121 oc_event_fd(value vevent)
 122 {
 123   CAMLparam1(vevent);
 124   CAMLreturn(Val_long(EVENT_FD(struct_event_val(vevent))));
 125 }
 126
 127 CAMLprim value
 128 oc_event_set(value vbase, value vevent, value fd, value vevent_flag)
 129 {
 130   CAMLparam4(vbase, vevent, fd, vevent_flag);
 131
 132   struct event *event = struct_event_val(vevent);
 133
 134   event_set(event, Int_val(fd), Int_val(vevent_flag),
 135             &event_cb, event);
 136
 137   if (0 != event_base_set(struct_event_base_val(vbase), event))
 138   {
 139     raise_error("event_set", "event_base_set");
 140   }
 141
 142   CAMLreturn(Val_unit);
 143 }
 144
 145 CAMLprim value
 146 oc_event_add(value vevent, value vfloat_option)
 147 {
 148   CAMLparam2(vevent, vfloat_option);
 149   struct event *event = struct_event_val(vevent);
 150   struct timeval timeval;
 151   struct timeval *tv = NULL;
 152
 153   if (Is_some(vfloat_option)) {
 154     set_struct_timeval(&timeval, Field(vfloat_option, 0));
 155     tv = &timeval;
 156   }
 157
 158   if (0 != event_add(event, tv)) {
 159     raise_error("event_add", "event_add");
 160   }
 161
 162   CAMLreturn(Val_unit);
 163 }
 164
 165 CAMLprim value
 166 oc_event_del(value vevent)
 167 {
 168   CAMLparam0();
 169   struct event *event = struct_event_val(vevent);
 170
 171   event_del(event);
 172
 173   CAMLreturn(Val_unit);
 174 }
 175
 176 CAMLprim value
 177 oc_event_pending(value vevent, value vtype, value vfloat_option)
 178 {
 179   CAMLparam3(vevent, vtype, vfloat_option);
 180   struct event *event = struct_event_val(vevent);
 181   struct timeval timeval;
 182   struct timeval *tv = NULL;
 183
 184   if Is_some(vfloat_option) {
 185     set_struct_timeval(&timeval, Field(vfloat_option, 0));
 186     tv = &timeval;
 187   }
 188
 189   event_pending(event, Int_val(vtype), tv);
 190
 191   CAMLreturn(Val_unit);
 192 }
 193
 194 CAMLprim value
 195 oc_event_base_loop(value vbase, value vloop_flag)
 196 {
 197   CAMLparam2(vbase,vloop_flag);
 198   struct event_base* base = struct_event_base_val(vbase);
 199   int flag = 0;
 200   if (0 == Int_val(vloop_flag)) flag = EVLOOP_ONCE;
 201   else if (1 == Int_val(vloop_flag)) flag = EVLOOP_NONBLOCK;
 202   else caml_invalid_argument("loop");
 203
 204   caml_enter_blocking_section();
 205   if((-1 == event_base_loop(base,flag))) {
 206     caml_leave_blocking_section();
 207     raise_error("event_loop", NULL);
 208   }
 209   caml_leave_blocking_section();
 210
 211   CAMLreturn(Val_unit);
 212 }
 213
 214
 215 CAMLprim value
 216 oc_event_base_dispatch(value vbase)
 217 {
 218   CAMLparam1(vbase);
 219   struct event_base* base = struct_event_base_val(vbase);
 220
 221   caml_enter_blocking_section();
 222   if((-1 == event_base_dispatch(base))) {
 223     caml_leave_blocking_section();
 224     raise_error("event_dispatch", NULL);
 225   }
 226   caml_leave_blocking_section();
 227
 228   CAMLreturn(Val_unit);
 229 }
 230
 231 /*
 232  * Initialize event base
 233  */
 234 CAMLprim value
 235 oc_event_base_init(value unit)
 236 {
 237   CAMLparam1(unit);
 238   struct event_base* base = NULL;
 239
 240   /* setup the event callback closure if needed */
 241   if(event_cb_closure == NULL) {
 242     event_cb_closure = caml_named_value("event_cb");
 243     if(event_cb_closure == NULL) {
 244       invalid_argument("Callback event_cb not initialized.");
 245     }
 246   }
 247
 248   base = event_base_new();
 249   if (!base) {
 250     raise_error("event_base_init", NULL);
 251   }
 252
 253   CAMLreturn(Val_struct_event_base(base));
 254 }
 255
 256 CAMLprim value
 257 oc_event_base_reinit(value vbase)
 258 {
 259   CAMLparam1(vbase);
 260   struct event_base* base = struct_event_base_val(vbase);
 261
 262   if (0 != event_reinit(base)) {
 263     raise_error("event_base_reinit", NULL);
 264   }
 265
 266   CAMLreturn(Val_unit);
 267 }
 268
 269 CAMLprim value
 270 oc_event_base_free(value vbase)
 271 {
 272   CAMLparam1(vbase);
 273   struct event_base* base = struct_event_base_val(vbase);
 274
 275   event_base_free(base);
 276
 277   CAMLreturn(Val_unit);
 278 }
 279