Add OCaml channel tests

CHANGES.md

@@ -22,6 +22,7 @@
 * Runtime: Fix Marshal.to_buffer (#1798)
 * Runtime: unmarshalling objects should refresh its id
 * Runtime: check size upper bound during array creation
+* Runtime: return sys_error when reading from a closed channels
 
 # 5.9.1 (02-12-2024) - Lille
 

compiler/tests-ocaml/lib-channels/bigarrays.expected

@@ -0,0 +1 @@
+Xhello, worldX

compiler/tests-ocaml/lib-channels/bigarrays.ml

@@ -0,0 +1,21 @@
+(* TEST *)
+
+let filename = "test.out"
+
+let bigarray_of_string s =
+  Bigarray.Array1.init Bigarray.char Bigarray.c_layout (String.length s)
+    (String.get s)
+
+let string_of_bigarray buf =
+  String.init (Bigarray.Array1.dim buf) (Bigarray.Array1.get buf)
+
+let () =
+  let oc = Out_channel.open_bin filename in
+  let str = ">hello, world<" in
+  let buf = bigarray_of_string str in
+  Out_channel.output_bigarray oc buf 1 (String.length str - 2);
+  Out_channel.close oc;
+  let ic = In_channel.open_bin filename in
+  let buf = bigarray_of_string (String.map (fun _ -> 'X') str) in
+  assert (Option.is_some (In_channel.really_input_bigarray ic buf 1 (String.length str - 2)));
+  print_endline (string_of_bigarray buf)

compiler/tests-ocaml/lib-channels/buffered.expected

@@ -0,0 +1,10 @@
+stdout 1
+stderr 1
+stderr 2
+stdout 2
+false
+stderr 3
+stdout 3
+stdout 4
+true
+stderr 4

compiler/tests-ocaml/lib-channels/buffered.ml

@@ -0,0 +1,34 @@
+(* TEST *)
+
+(* baseline *)
+let () =
+  print_string "stdout 1\n";
+  prerr_string "stderr 1\n";
+  flush stdout;
+  flush stderr
+
+(* stderr unbuffered *)
+let () =
+  Out_channel.set_buffered stderr false;
+  print_string "stdout 2\n";
+  prerr_string "stderr 2\n";
+  print_string (Bool.to_string (Out_channel.is_buffered stderr));
+  print_char '\n';
+  flush stdout
+
+(* switching to unbuffered flushes the channel *)
+let () =
+  print_string "stdout 3\n";
+  prerr_string "stderr 3\n";
+  Out_channel.set_buffered stderr false;
+  flush stdout
+
+(* stderr back to buffered *)
+let () =
+  Out_channel.set_buffered stderr true;
+  print_string "stdout 4\n";
+  prerr_string "stderr 4\n";
+  print_string (Bool.to_string (Out_channel.is_buffered stderr));
+  print_char '\n';
+  flush stdout;
+  flush stderr

compiler/tests-ocaml/lib-channels/close_in.ml

@@ -0,0 +1,32 @@
+(* TEST *)
+
+(* Test that inputting bytes from a closed in_channel triggers an exception *)
+
+(* The number of bytes we'll rewind after closing; a value
+   between 1 and IO_BUFFER_SIZE *)
+let nb_bytes = 3
+
+let () =
+  let ic = open_in_bin (Filename.basename Sys.argv.(0)) in
+  seek_in ic nb_bytes;
+  close_in ic;
+  assert (
+    try
+      seek_in ic 0;
+      ignore (input_byte ic);
+      false
+    with
+    | Sys_error _ -> true
+    | _           -> false)
+
+(* A variant of #11878, which #11965 failed to fix. *)
+let () =
+  let ic = open_in_bin (Filename.basename Sys.argv.(0)) in
+  close_in ic;
+  begin try
+    seek_in ic (-1);
+    ignore (input_byte ic);
+    assert false;
+  with
+  | Sys_error _ -> ()
+  end

compiler/tests-ocaml/lib-channels/close_out.ml

@@ -0,0 +1,19 @@
+(* TEST
+
+   arguments = "${test_build_directory}/testfile.tmp";
+*)
+
+(* Test that output to a closed out_channel triggers an exception every
+   time, not just the first time. *)
+
+let () =
+  let oc = open_out_bin "testfile.tmp" in
+  close_out oc;
+  begin match output_byte oc 0 with
+  | exception Sys_error _ -> ()
+  | () -> assert false
+  end;
+  begin match output_byte oc 0 with
+  | exception Sys_error _ -> ()
+  | () -> assert false
+  end

compiler/tests-ocaml/lib-channels/dune

@@ -0,0 +1,37 @@
+(tests
+ (names close_in close_out in_channel_length seek_in)
+ (libraries ocaml_testing)
+ (flags
+  (:standard -no-strict-formats \ -strict-formats))
+ (modes js wasm))
+
+(tests
+ (names buffered)
+ (build_if
+  (>= %{ocaml_version} 4.14))
+ (libraries ocaml_testing)
+ (action
+  (pipe-outputs
+   (run node %{test})
+   (run cat)))
+ (flags
+  (:standard -no-strict-formats \ -strict-formats))
+ (modes js wasm))
+
+(tests
+ (names input_lines)
+ (build_if
+  (>= %{ocaml_version} 5.1))
+ (libraries ocaml_testing)
+ (flags
+  (:standard -no-strict-formats \ -strict-formats))
+ (modes js wasm))
+
+(tests
+ (names bigarrays)
+ (build_if
+  (>= %{ocaml_version} 5.2))
+ (libraries ocaml_testing)
+ (flags
+  (:standard -no-strict-formats \ -strict-formats))
+ (modes js wasm))

compiler/tests-ocaml/lib-channels/in_channel_length.ml

@@ -0,0 +1,20 @@
+(* TEST *)
+
+let len = 15000
+let rounds = 10
+
+let () =
+  let oc = open_out "data2.txt" in
+  for i = 1 to rounds do
+    Printf.fprintf oc "%s\n%!" (String.make len 'x');
+  done;
+  close_out oc;
+  let ic = open_in "data2.txt" in
+  let l1 = in_channel_length ic in
+  for i = 1 to rounds do
+    let s = input_line ic in
+    assert (String.length s = len);
+    let l = in_channel_length ic in
+    assert (l = l1)
+  done;
+  close_in ic

compiler/tests-ocaml/lib-channels/input_lines.ml

@@ -0,0 +1,32 @@
+(* TEST *)
+
+open Printf
+
+let data_file =
+  "data.txt"
+
+let length = 500
+
+let rec check lo hi l =
+  if lo = hi + 1 then begin
+    if l <> [] then failwith "list too long"
+  end else begin
+    match l with
+    | [] -> failwith "list too short"
+    | h :: t ->
+        if int_of_string h <> lo then failwith "wrong value";
+        check (lo + 1) hi t
+  end
+
+let _ =
+  Out_channel.with_open_text data_file
+    (fun oc ->
+      fprintf oc "0";
+      for i = 1 to length do fprintf oc "\n%d" i done);
+  In_channel.with_open_text data_file In_channel.input_lines
+  |> check 0 length;
+  In_channel.with_open_text data_file
+    (In_channel.fold_lines (fun accu line -> line :: accu) [])
+  |> List.rev
+  |> check 0 length;
+  Sys.remove data_file

compiler/tests-ocaml/lib-channels/seek_in.ml

@@ -0,0 +1,19 @@
+(* TEST *)
+
+let () =
+  let oc = open_out_bin "data.txt" in
+  output_string oc "0\r\n1\r\n";
+  close_out oc;
+  (* Open in text mode to trigger EOL conversion under Windows *)
+  let ic = open_in "data.txt" in
+  ignore (input_line ic);
+  seek_in ic 3;
+  (* Normally we should be looking at "1\r\n", which will be read as
+     "1" under Windows because of EOL conversion and "1\r" otherwise.
+     What goes wrong with the old implementation of seek_in is that
+     we have "0\n\1\n" in the channel buffer and have read "0\n" already,
+     so we think we are at position 2, and the seek to position 3
+     just advances by one in the buffer, pointing to "\n" instead of "1\n". *)
+  let l = input_line ic in
+  close_in ic;
+  assert (l = "1" || l = "1\r")

runtime/js/io.js

@@ -107,8 +107,9 @@ function caml_sys_open(name, flags, _perms) {
   return caml_sys_open_internal(file, undefined);
 }
 (function () {
+  var is_node = fs_node_supported();
   function file(fd, flags) {
-    if (fs_node_supported()) {
+    if (is_node) {
       return caml_sys_open_for_node(fd, flags);
     } else return new MlFakeFd_out(fd, flags);
   }
@@ -117,11 +118,11 @@ function caml_sys_open(name, flags, _perms) {
     0,
   );
   caml_sys_open_internal(
-    file(1, { buffered: 2, wronly: 1, isCharacterDevice: true }),
+    file(1, { buffered: is_node ? 1 : 2, wronly: 1, isCharacterDevice: true }),
     1,
   );
   caml_sys_open_internal(
-    file(2, { buffered: 2, wronly: 1, isCharacterDevice: true }),
+    file(2, { buffered: is_node ? 1 : 2, wronly: 1, isCharacterDevice: true }),
     2,
   );
 })();
@@ -338,6 +339,7 @@ function caml_ml_set_channel_refill(chanid, f) {
 
 //Provides: caml_refill
 //Requires: caml_ml_string_length, caml_uint8_array_of_string
+//Requires: caml_raise_sys_error
 function caml_refill(chan) {
   if (chan.refill != null) {
     var str = chan.refill();
@@ -355,6 +357,9 @@ function caml_refill(chan) {
       chan.buffer_max += str_a.length;
     }
   } else {
+    if (chan.fd === -1) {
+      caml_raise_sys_error("Bad file descriptor");
+    }
     var nread = chan.file.read(
       chan.offset,
       chan.buffer,