Switch to poll.

Author: toots

CHANGES

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

cry.opam

@@ -12,6 +12,7 @@ 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 base-bytes)
+ (depends (ocaml (>= 4.12.0)) dune poll base-bytes)
 )

src/cry.ml

@@ -20,22 +20,28 @@
 
 (** OCaml low level implementation of the shout source protocol. *)
 
-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
+let poll r w timeout =
+  let timeout =
+    match timeout with
+      | x when x < 0. -> Poll.Timeout.never
+      | 0. -> Poll.Timeout.immediate
+      | x ->
+          let frac, int = modf x in
+          let int = Int64.mul (Int64.of_float int) 1_000_000_000L in
+          let frac = Int64.of_float (frac *. 1_000_000_000.) in
+          let timeout = Int64.add int frac in
+          Poll.Timeout.after timeout
+  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;
+  ignore (Poll.wait poll timeout);
+  let r = ref [] in
+  let w = ref [] in
+  Poll.iter_ready poll ~f:(fun fd event ->
+      if event.Poll.Event.readable then r := fd :: !r;
+      if event.Poll.Event.writable then w := fd :: !w);
+  (!r, !w)
 
 type error =
   | Create of exn
@@ -90,9 +96,8 @@ let wait_for ?(log = fun _ -> ()) event timeout =
       | `Both socket -> ([socket], [socket])
   in
   let rec wait t =
-    let r, w, _ =
-      try select r w [] t
-      with Unix.Unix_error (Unix.EINTR, _, _) -> ([], [], [])
+    let r, w =
+      try poll r w t with Unix.Unix_error (Unix.EINTR, _, _) -> ([], [])
     in
     if r = [] && w = [] then (
       let current_time = Unix.gettimeofday () in
@@ -164,8 +169,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 select call for [timeout] seconds. *)
-    let _, w, _ = select [] [socket] [] timeout in
+    (* Block in a poll call for [timeout] seconds. *)
+    let _, w = poll [] [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

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