diff --git a/CHANGES b/CHANGES index 4e40df2..435af42 100644 --- a/CHANGES +++ b/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) ====== diff --git a/cry.opam b/cry.opam index 46964c4..6577ad0 100644 --- a/cry.opam +++ b/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} ] diff --git a/dune-project b/dune-project index 427551b..a762060 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 poll base-bytes) + (depends (ocaml (>= 4.12.0)) dune base-bytes) ) diff --git a/src/cry.ml b/src/cry.ml index 3eb81f5..e68200f 100644 --- a/src/cry.ml +++ b/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", "")) diff --git a/src/cry_stubs.c b/src/cry_stubs.c new file mode 100644 index 0000000..5246fa1 --- /dev/null +++ b/src/cry_stubs.c @@ -0,0 +1,131 @@ +#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 e20fabf..07f8143 100644 --- a/src/dune +++ b/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"))