Revert "Switch to poll."

This reverts commit a4e8307.

CHANGES

@@ -2,7 +2,6 @@
 =====
 * Raise a proper error when non-blocking connection
   fails.
-* Switch to `poll` for polling implementation.
 
 1.0.2 (2024-01-08)
 ======

cry.opam

@@ -12,7 +12,6 @@ bug-reports: "https://github.com/savonet/ocaml-cry/issues"
 depends: [
   "ocaml" {>= "4.12.0"}
   "dune" {>= "2.8"}
-  "poll"
   "base-bytes"
   "odoc" {with-doc}
 ]

dune-project

@@ -13,5 +13,5 @@
  (name cry)
  (synopsis "OCaml client for the various icecast & shoutcast source protocols")
  (description "The cry library is an implementation of the various icecast & shoutcast protocols to connect to streaming servers such as icecast")
- (depends (ocaml (>= 4.12.0)) dune poll base-bytes)
+ (depends (ocaml (>= 4.12.0)) dune base-bytes)
 )

src/cry.ml

@@ -20,27 +20,22 @@
 
 (** OCaml low level implementation of the shout source protocol. *)
 
-let poll r w timeout =
-  let timeout =
-    match timeout with
-      | x when x < 0. -> Poll.Timeout.never
-      | 0. -> Poll.Timeout.immediate
-      | x -> Poll.Timeout.after (Int64.of_float (x *. 1_000_000_000.))
-  in
-  let poll = Poll.create () in
-  List.iter (fun fd -> Poll.set poll fd Poll.Event.read) r;
-  List.iter (fun fd -> Poll.set poll fd Poll.Event.write) w;
-  match Poll.wait poll timeout with
-    | `Ok ->
-        let r = ref [] in
-        let w = ref [] in
-        Poll.iter_ready poll ~f:(fun fd -> function
-          | { Poll.Event.readable = true; _ } -> r := fd :: !r
-          | _ -> w := fd :: !w);
-        let r = !r in
-        let w = !w in
-        (r, w)
-    | `Timeout -> ([], [])
+external poll :
+  Unix.file_descr array ->
+  Unix.file_descr array ->
+  Unix.file_descr array ->
+  float ->
+  Unix.file_descr array * Unix.file_descr array * Unix.file_descr array
+  = "caml_cry_poll"
+
+let poll r w e timeout =
+  let r = Array.of_list r in
+  let w = Array.of_list w in
+  let e = Array.of_list e in
+  let r, w, e = poll r w e timeout in
+  (Array.to_list r, Array.to_list w, Array.to_list e)
+
+let select = match Sys.os_type with "Unix" -> poll | _ -> Unix.select
 
 type error =
   | Create of exn
@@ -95,8 +90,9 @@ let wait_for ?(log = fun _ -> ()) event timeout =
       | `Both socket -> ([socket], [socket])
   in
   let rec wait t =
-    let r, w =
-      try poll r w t with Unix.Unix_error (Unix.EINTR, _, _) -> ([], [])
+    let r, w, _ =
+      try select r w [] t
+      with Unix.Unix_error (Unix.EINTR, _, _) -> ([], [], [])
     in
     if r = [] && w = [] then (
       let current_time = Unix.gettimeofday () in
@@ -168,8 +164,8 @@ let connect_sockaddr ?bind_address ?timeout sockaddr =
   let do_timeout = timeout <> None in
   let check_timeout () =
     let timeout = Option.get timeout in
-    (* Block in a poll call for [timeout] seconds. *)
-    let _, w = poll [] [socket] timeout in
+    (* Block in a select call for [timeout] seconds. *)
+    let _, w, _ = select [] [socket] [] timeout in
     if w = [] then raise Timeout;
     match Unix.getsockopt_error socket with
       | Some err -> raise (Unix.Unix_error (err, "connect", ""))

src/cry_stubs.c

@@ -0,0 +1,131 @@
+#include <caml/alloc.h>
+#include <caml/bigarray.h>
+#include <caml/fail.h>
+#include <caml/memory.h>
+#include <caml/signals.h>
+#include <caml/threads.h>
+#include <caml/unixsupport.h>
+
+#include <errno.h>
+
+/* On native Windows platforms, many macros are not defined.  */
+#if (defined _WIN32 || defined __WIN32__) && !defined __CYGWIN__
+
+#ifndef EWOULDBLOCK
+#define EWOULDBLOCK EAGAIN
+#endif
+
+#endif
+
+#ifdef WIN32
+#define Fd_val(fd) win_CRT_fd_of_filedescr(fd)
+#define Val_fd(fd) caml_failwith("Val_fd")
+#else
+#define Fd_val(fd) Int_val(fd)
+#define Val_fd(fd) Val_int(fd)
+#endif
+
+#ifndef WIN32
+#include <poll.h>
+
+CAMLprim value caml_cry_poll(value _read, value _write, value _err,
+                             value _timeout) {
+  CAMLparam3(_read, _write, _err);
+  CAMLlocal4(_pread, _pwrite, _perr, _ret);
+
+  struct pollfd *fds;
+  nfds_t nfds = 0;
+  nfds_t nread = 0;
+  nfds_t nwrite = 0;
+  nfds_t nerr = 0;
+  int timeout;
+  size_t last = 0;
+  int n, ret;
+
+  if (Double_val(_timeout) == -1)
+    timeout = -1;
+  else
+    timeout = Double_val(_timeout) * 1000;
+
+  nfds += Wosize_val(_read);
+  nfds += Wosize_val(_write);
+  nfds += Wosize_val(_err);
+
+  fds = calloc(nfds, sizeof(struct pollfd));
+  if (fds == NULL)
+    caml_raise_out_of_memory();
+
+  for (n = 0; n < Wosize_val(_read); n++) {
+    fds[last + n].fd = Fd_val(Field(_read, n));
+    fds[last + n].events = POLLIN;
+  }
+  last += Wosize_val(_read);
+
+  for (n = 0; n < Wosize_val(_write); n++) {
+    fds[last + n].fd = Fd_val(Field(_write, n));
+    fds[last + n].events = POLLOUT;
+  }
+  last += Wosize_val(_write);
+
+  for (n = 0; n < Wosize_val(_err); n++) {
+    fds[last + n].fd = Fd_val(Field(_err, n));
+    fds[last + n].events = POLLERR;
+  }
+
+  caml_release_runtime_system();
+  ret = poll(fds, nfds, timeout);
+  caml_acquire_runtime_system();
+
+  if (ret == -1) {
+    free(fds);
+    uerror("poll", Nothing);
+  }
+
+  for (n = 0; n < nfds; n++) {
+    if (fds[n].revents & POLLIN)
+      nread++;
+    if (fds[n].revents & POLLOUT)
+      nwrite++;
+    if (fds[n].revents & POLLERR)
+      nerr++;
+  }
+
+  _pread = caml_alloc_tuple(nread);
+  nread = 0;
+
+  _pwrite = caml_alloc_tuple(nwrite);
+  nwrite = 0;
+
+  _perr = caml_alloc_tuple(nerr);
+  nerr = 0;
+
+  for (n = 0; n < nfds; n++) {
+    if (fds[n].revents & POLLIN) {
+      Store_field(_pread, nread, Val_fd(fds[n].fd));
+      nread++;
+    }
+    if (fds[n].revents & POLLOUT) {
+      Store_field(_pwrite, nwrite, Val_fd(fds[n].fd));
+      nwrite++;
+    }
+    if (fds[n].revents & POLLERR) {
+      Store_field(_pread, nerr, Val_fd(fds[n].fd));
+      nerr++;
+    }
+  }
+
+  free(fds);
+
+  _ret = caml_alloc_tuple(3);
+  Store_field(_ret, 0, _pread);
+  Store_field(_ret, 1, _pwrite);
+  Store_field(_ret, 2, _perr);
+
+  CAMLreturn(_ret);
+}
+#else
+CAMLprim value caml_cry_poll(value _read, value _write, value _err,
+                             value _timeout) {
+  caml_failwith("caml_poll");
+}
+#endif

src/dune

@@ -1,6 +1,9 @@
 (library
  (name cry)
  (public_name cry)
- (libraries poll bytes unix)
+ (libraries bytes unix)
+ (foreign_stubs
+  (language c)
+  (names cry_stubs))
  (synopsis
   "OCaml client for the various icecast & shoutcast source protocols"))