From a4e8307b209938fb96be25fb4cad59f8750858e2 Mon Sep 17 00:00:00 2001 From: Romain Beauxis Date: Sun, 4 Feb 2024 11:30:28 -0600 Subject: [PATCH] Switch to poll. --- CHANGES | 1 + cry.opam | 1 + dune-project | 2 +- src/cry.ml | 46 +++++++++-------- src/cry_stubs.c | 131 ------------------------------------------------ src/dune | 5 +- 6 files changed, 29 insertions(+), 157 deletions(-) delete mode 100644 src/cry_stubs.c diff --git a/CHANGES b/CHANGES index 435af42..4e40df2 100644 --- a/CHANGES +++ b/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) ====== diff --git a/cry.opam b/cry.opam index 6577ad0..46964c4 100644 --- a/cry.opam +++ b/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} ] diff --git a/dune-project b/dune-project index a762060..427551b 100644 --- a/dune-project +++ b/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) ) diff --git a/src/cry.ml b/src/cry.ml index e68200f..3eb81f5 100644 --- a/src/cry.ml +++ b/src/cry.ml @@ -20,22 +20,27 @@ (** 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 -> 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 -> ([], []) type error = | Create of exn @@ -90,9 +95,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 +168,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", "")) diff --git a/src/cry_stubs.c b/src/cry_stubs.c deleted file mode 100644 index 5246fa1..0000000 --- a/src/cry_stubs.c +++ /dev/null @@ -1,131 +0,0 @@ -#include -#include -#include -#include -#include -#include -#include - -#include - -/* 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 - -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 diff --git a/src/dune b/src/dune index 07f8143..e20fabf 100644 --- a/src/dune +++ b/src/dune @@ -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"))