event_stubs.c

   1 /************************************************************************/
   2 /* The ocaml-libevent library                                           */
   3 /*                                                                      */
   4 /* Copyright 2002, 2003, 2004 Maas-Maarten Zeeman. All rights reserved. */
   5 /* Copyright 2010 ygrek                                                 */
   6 /* See LICENCE for details.                                             */
   7 /************************************************************************/
   8
   9 /* Stub code to interface Ocaml with libevent */
  10
  11 #include <sys/time.h>
  12 #include <stdlib.h>
  13 #include <event.h>
  14 #include <string.h>
  15
  16 #include <caml/mlvalues.h>
  17 #include <caml/custom.h>
  18 #include <caml/alloc.h>
  19 #include <caml/memory.h>
  20 #include <caml/callback.h>
  21 #include <caml/fail.h>
  22 #include <caml/unixsupport.h>
  23 #include <caml/signals.h>
  24
  25 #define struct_event_val(v) (*(struct event**) Data_custom_val(v))
  26 #ifndef Is_some
  27 #define Is_some(v) (Is_block(v))
  28 #endif
  29
  30 #define struct_event_base_val(v) (*(struct event_base**) Data_custom_val(v))
  31
  32 static value const * event_cb_closure = NULL;
  33
  34 /* FIXME use dedicated exception */
  35 static void raise_error(char const* str, char const* arg)
  36 {
  37   uerror((char*)str, NULL == arg ? Nothing : caml_copy_string(arg));
  38 }
  39
  40 static void
  41 struct_event_finalize(value ve)
  42 {
  43   struct event *ev = struct_event_val(ve);
  44
  45   if (NULL != ev)
  46   {
  47     event_del(ev);
  48     caml_stat_free(ev);
  49     struct_event_val(ve) = NULL;
  50   }
  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 #if defined(custom_compare_ext_default)
  77   custom_compare_ext_default,
  78 #endif
  79 };
  80
  81 static void
  82 struct_event_base_finalize(value vbase)
  83 {
  84   struct event_base* base = struct_event_base_val(vbase);
  85   if (NULL != base)
  86   {
  87     event_base_free(base);
  88     struct_event_base_val(vbase) = NULL;
  89   }
  90 }
  91
  92 static int
  93 struct_event_base_compare(value v1, value v2)
  94 {
  95   struct event_base *p1 = struct_event_base_val(v1);
  96   struct event_base *p2 = struct_event_base_val(v2);
  97   if(p1 == p2) return 0;
  98   if(p1 < p2) return -1;
  99   return 1;
 100 }
 101
 102 static long
 103 struct_event_base_hash(value v)
 104 {
 105   return (long) struct_event_base_val(v);
 106 }
 107
 108 static struct custom_operations struct_event_base_ops = {
 109   "struct event_base",
 110   struct_event_base_finalize,
 111   struct_event_base_compare,
 112   struct_event_base_hash,
 113   custom_serialize_default,
 114   custom_deserialize_default,
 115 #if defined(custom_compare_ext_default)
 116   custom_compare_ext_default,
 117 #endif
 118 };
 119
 120 static struct event_base*
 121 get_struct_event_base_val(value v)
 122 {
 123   struct event_base* base = struct_event_base_val(v);
 124   if (NULL == base)
 125   {
 126     raise_error("event_base","NULL");
 127   }
 128   return base;
 129 }
 130
 131 /*
 132  * This callback calls the ocaml event callback, which will in turn
 133  * call the real ocaml callback.
 134  */
 135 static void
 136 event_cb(int fd, short type, void *arg)
 137 {
 138   caml_leave_blocking_section();
 139   caml_callback3(*event_cb_closure,
 140             Val_long((long) arg), Val_int(fd), Val_int(type));
 141   caml_enter_blocking_section();
 142 }
 143
 144 static void
 145 set_struct_timeval(struct timeval *tv, value vfloat)
 146 {
 147   double timeout = Double_val(vfloat);
 148   tv->tv_sec = (int) timeout;
 149   tv->tv_usec = (int) (1e6 * (timeout - tv->tv_sec));
 150 }
 151
 152 CAMLprim value
 153 oc_create_event(value u)
 154 {
 155   CAMLparam1(u);
 156   CAMLlocal1(ve);
 157   struct event* ev = caml_stat_alloc(sizeof(struct event));
 158   memset(ev, 0, sizeof(*ev));
 159
 160   ve = caml_alloc_custom(&struct_event_ops, sizeof(struct event*), 0, 1);
 161   struct_event_val(ve) = ev;
 162
 163   CAMLreturn(ve);
 164 }
 165
 166 CAMLprim value
 167 oc_event_id(value vevent)
 168 {
 169   CAMLparam0();
 170   CAMLreturn(Val_long((long) struct_event_val(vevent)));
 171 }
 172
 173 CAMLprim value
 174 oc_event_fd(value vevent)
 175 {
 176   CAMLparam1(vevent);
 177   CAMLreturn(Val_long(EVENT_FD(struct_event_val(vevent))));
 178 }
 179
 180 CAMLprim value
 181 oc_event_set(value vbase, value vevent, value fd, value vevent_flag)
 182 {
 183   CAMLparam4(vbase, vevent, fd, vevent_flag);
 184
 185   struct event *event = struct_event_val(vevent);
 186   struct event_base* base = get_struct_event_base_val(vbase);
 187
 188   event_set(event, Int_val(fd), Int_val(vevent_flag),
 189             &event_cb, event);
 190
 191   if (0 != event_base_set(base, event))
 192   {
 193     raise_error("event_base_set", NULL);
 194   }
 195
 196   CAMLreturn(Val_unit);
 197 }
 198
 199 CAMLprim value
 200 oc_event_add(value vevent, value vfloat_option)
 201 {
 202   CAMLparam2(vevent, vfloat_option);
 203   struct event *event = struct_event_val(vevent);
 204   struct timeval timeval;
 205   struct timeval *tv = NULL;
 206
 207   if (Is_some(vfloat_option)) {
 208     set_struct_timeval(&timeval, Field(vfloat_option, 0));
 209     tv = &timeval;
 210   }
 211
 212   if (0 != event_add(event, tv)) {
 213     raise_error("event_add", NULL);
 214   }
 215
 216   CAMLreturn(Val_unit);
 217 }
 218
 219 CAMLprim value
 220 oc_event_del(value vevent)
 221 {
 222   CAMLparam0();
 223   struct event *event = struct_event_val(vevent);
 224
 225   event_del(event);
 226
 227   CAMLreturn(Val_unit);
 228 }
 229
 230 CAMLprim value
 231 oc_event_pending(value vevent, value vtype)
 232 {
 233   CAMLparam2(vevent, vtype);
 234   struct event *event = struct_event_val(vevent);
 235   int r = 0;
 236
 237   r = event_pending(event, Int_val(vtype), NULL);
 238
 239   CAMLreturn(Val_bool(r));
 240 }
 241
 242 CAMLprim value
 243 oc_event_active(value vevent, value vtype)
 244 {
 245   CAMLparam2(vevent, vtype);
 246   struct event *event = struct_event_val(vevent);
 247
 248   event_active(event, Int_val(vtype), 0);
 249
 250   CAMLreturn(Val_unit);
 251 }
 252
 253 CAMLprim value
 254 oc_event_base_loop(value vbase, value vflags)
 255 {
 256   CAMLparam2(vbase,vflags);
 257   struct event_base* base = get_struct_event_base_val(vbase);
 258   int flags = 0;
 259   while (vflags != Val_emptylist)
 260   {
 261     if (0 == Int_val(Field(vflags,0))) flags |= EVLOOP_ONCE;
 262     else if (1 == Int_val(Field(vflags,0))) flags |= EVLOOP_NONBLOCK;
 263     else caml_invalid_argument("Libevent.loops");
 264
 265     vflags = Field(vflags,1);
 266   }
 267
 268   caml_enter_blocking_section();
 269   if((-1 == event_base_loop(base,flags))) {
 270     caml_leave_blocking_section();
 271     raise_error("event_base_loop", NULL);
 272   }
 273   caml_leave_blocking_section();
 274
 275   CAMLreturn(Val_unit);
 276 }
 277
 278
 279 CAMLprim value
 280 oc_event_base_dispatch(value vbase)
 281 {
 282   CAMLparam1(vbase);
 283   struct event_base* base = get_struct_event_base_val(vbase);
 284
 285   caml_enter_blocking_section();
 286   if((-1 == event_base_dispatch(base))) {
 287     caml_leave_blocking_section();
 288     raise_error("event_base_dispatch", NULL);
 289   }
 290   caml_leave_blocking_section();
 291
 292   CAMLreturn(Val_unit);
 293 }
 294
 295 /*
 296  * Initialize event base
 297  */
 298 CAMLprim value
 299 oc_event_base_init(value unit)
 300 {
 301   CAMLparam1(unit);
 302   CAMLlocal1(v);
 303   struct event_base* base = NULL;
 304
 305   /* setup the event callback closure if needed */
 306   if(event_cb_closure == NULL) {
 307     event_cb_closure = caml_named_value("event_cb");
 308     if(event_cb_closure == NULL) {
 309       caml_invalid_argument("Callback event_cb not initialized.");
 310     }
 311   }
 312
 313   base = event_base_new();
 314   if (!base) {
 315     raise_error("event_base_init", NULL);
 316   }
 317
 318   v = caml_alloc_custom(&struct_event_base_ops, sizeof(struct event_base*), 0, 1);
 319   struct_event_base_val(v) = base;
 320
 321   CAMLreturn(v);
 322 }
 323
 324 CAMLprim value
 325 oc_event_base_reinit(value vbase)
 326 {
 327   CAMLparam1(vbase);
 328   struct event_base* base = get_struct_event_base_val(vbase);
 329
 330   if (0 != event_reinit(base)) {
 331     raise_error("event_base_reinit", NULL);
 332   }
 333
 334   CAMLreturn(Val_unit);
 335 }
 336
 337 CAMLprim value
 338 oc_event_base_free(value vbase)
 339 {
 340   CAMLparam1(vbase);
 341
 342   struct event_base* base = get_struct_event_base_val(vbase);
 343   event_base_free(base);
 344   struct_event_base_val(vbase) = NULL;
 345
 346   CAMLreturn(Val_unit);
 347 }