fix setting Lwt_process env on Windows

.github/workflows/workflow.yml

@@ -14,25 +14,25 @@ jobs:
     strategy:
       fail-fast: false
       matrix:
-        os:
-          - ubuntu-latest
-        ocaml-compiler:
-          - "4.14"
-          - "5.0"
-          - "5.1"
-          - "5.2"
-          - "5.3"
-          - "5.4"
-        libev:
-          - true
-          - false
+        # os:
+        #   - ubuntu-latest
+        # ocaml-compiler:
+        #   - "4.14"
+        #   - "5.0"
+        #   - "5.1"
+        #   - "5.2"
+        #   - "5.3"
+        #   - "5.4"
+        # libev:
+        #   - true
+        #   - false
         include:
-          - os: ubuntu-24.04-arm
-            ocaml-compiler: "5.4"
-            libev: false
-          - os: macos-latest
-            ocaml-compiler: "5.4"
-            libev: false
+          # - os: ubuntu-24.04-arm
+          #   ocaml-compiler: "5.4"
+          #   libev: false
+          # - os: macos-latest
+          #   ocaml-compiler: "5.4"
+          #   libev: false
           - os: windows-latest
             ocaml-compiler: "5.4"
             libev: false
@@ -42,10 +42,10 @@ jobs:
           - os: windows-latest
             ocaml-compiler: "ocaml-variants.4.14.2+options,host-system-mingw"
             libev: false
-          - os: ubuntu-latest
-            ocaml-name: "5.4.0+32bit"
-            ocaml-compiler: "ocaml-variants.5.4.0+options,ocaml-option-32bit"
-            libev: false
+          # - os: ubuntu-latest
+          #   ocaml-name: "5.4.0+32bit"
+          #   ocaml-compiler: "ocaml-variants.5.4.0+options,ocaml-option-32bit"
+          #   libev: false
 
 
     runs-on: ${{ matrix.os }}

src/unix/lwt_process_stubs.c

@@ -9,12 +9,25 @@
 
 #include "lwt_unix.h"
 
-#if OCAML_VERSION < 41300
+/* needed for caml_stat_strdup_to_os before ocaml 4.13, and for
+   caml_win32_multi_byte_to_wide_char, at least as of ocaml 5.0 */
 #define CAML_INTERNALS
+#if OCAML_VERSION < 50000
+#define caml_win32_multi_byte_to_wide_char win_multi_byte_to_wide_char
+#endif
+#if OCAML_VERSION == 52000
+/* see https://github.com/ocsigen/lwt/pull/967#issuecomment-2273495094
+ * TL;DR: some OCaml upstream issue means this extern is not included on the
+ * windows, it's added explicitly here instead. */
+CAMLextern int caml_win32_multi_byte_to_wide_char(const char* s,
+                                                  int slen,
+                                                  wchar_t *out,
+                                                  int outlen);
 #endif
 
 #include <caml/alloc.h>
 #include <caml/fail.h>
+#include <caml/misc.h>
 #include <caml/memory.h>
 #include <caml/osdeps.h>
 
@@ -68,6 +81,7 @@ CAMLprim value lwt_process_create_process(value prog, value cmdline, value env,
   HANDLE hp, fd0, fd1, fd2;
   HANDLE to_close0 = INVALID_HANDLE_VALUE, to_close1 = INVALID_HANDLE_VALUE,
     to_close2 = INVALID_HANDLE_VALUE;
+  int size;
 
   fd0 = get_handle(Field(fds, 0));
   fd1 = get_handle(Field(fds, 1));
@@ -94,11 +108,24 @@ CAMLprim value lwt_process_create_process(value prog, value cmdline, value env,
   char_os
     *progs = string_option(prog),
     *cmdlines = caml_stat_strdup_to_os(String_val(cmdline)),
-    *envs = string_option(env),
     *cwds = string_option(cwd);
 
 #undef string_option
 
+  char_os *envs;
+  if (Is_some(env)) {
+    env = Some_val(env);
+    size =
+      caml_win32_multi_byte_to_wide_char(String_val(env),
+                                         caml_string_length(env), NULL, 0);
+    envs = caml_stat_alloc((size + 1)*sizeof(char_os));
+    caml_win32_multi_byte_to_wide_char(String_val(env),
+                                       caml_string_length(env), envs, size);
+    envs[size] = 0;
+  } else {
+    envs = NULL;
+  }
+
   flags |= CREATE_UNICODE_ENVIRONMENT;
   if (! CreateProcess(progs, cmdlines, NULL, NULL, TRUE, flags,
                       envs, cwds, &si, &pi)) {

src/unix/windows_c/windows_bytes_read.c

@@ -8,6 +8,7 @@
 #if defined(LWT_ON_WINDOWS)
 
 #include <caml/bigarray.h>
+#include <caml/misc.h>
 #include <caml/memory.h>
 #include <caml/mlvalues.h>
 #include <caml/unixsupport.h>

src/unix/windows_c/windows_bytes_read_job.c

@@ -8,6 +8,7 @@
 #if defined(LWT_ON_WINDOWS)
 
 #include <caml/bigarray.h>
+#include <caml/misc.h>
 #include <caml/memory.h>
 #include <caml/mlvalues.h>
 #include <caml/unixsupport.h>

src/unix/windows_c/windows_bytes_write.c

@@ -8,6 +8,7 @@
 #if defined(LWT_ON_WINDOWS)
 
 #include <caml/bigarray.h>
+#include <caml/misc.h>
 #include <caml/memory.h>
 #include <caml/mlvalues.h>
 #include <caml/unixsupport.h>

src/unix/windows_c/windows_bytes_write_job.c

@@ -8,6 +8,7 @@
 #if defined(LWT_ON_WINDOWS)
 
 #include <caml/bigarray.h>
+#include <caml/misc.h>
 #include <caml/memory.h>
 #include <caml/mlvalues.h>
 #include <caml/unixsupport.h>

src/unix/windows_c/windows_is_socket.c

@@ -7,6 +7,7 @@
 
 #if defined(LWT_ON_WINDOWS)
 
+#include <caml/misc.h>
 #include <caml/memory.h>
 #include <caml/mlvalues.h>
 #include <caml/unixsupport.h>

src/unix/windows_c/windows_pread.c

@@ -8,6 +8,7 @@
 #if defined(LWT_ON_WINDOWS)
 
 #include <caml/fail.h>
+#include <caml/misc.h>
 #include <caml/memory.h>
 #include <caml/mlvalues.h>
 #include <caml/unixsupport.h>

src/unix/windows_c/windows_pread_job.c

@@ -8,6 +8,7 @@
 #if defined(LWT_ON_WINDOWS)
 
 #include <caml/fail.h>
+#include <caml/misc.h>
 #include <caml/memory.h>
 #include <caml/mlvalues.h>
 #include <caml/unixsupport.h>

src/unix/windows_c/windows_pwrite.c

@@ -8,6 +8,7 @@
 #if defined(LWT_ON_WINDOWS)
 
 #include <caml/fail.h>
+#include <caml/misc.h>
 #include <caml/memory.h>
 #include <caml/mlvalues.h>
 #include <caml/unixsupport.h>

src/unix/windows_c/windows_pwrite_job.c

@@ -8,6 +8,7 @@
 #if defined(LWT_ON_WINDOWS)
 
 #include <caml/fail.h>
+#include <caml/misc.h>
 #include <caml/memory.h>
 #include <caml/mlvalues.h>
 #include <caml/unixsupport.h>

src/unix/windows_c/windows_read.c

@@ -7,6 +7,7 @@
 
 #if defined(LWT_ON_WINDOWS)
 
+#include <caml/misc.h>
 #include <caml/memory.h>
 #include <caml/mlvalues.h>
 #include <caml/unixsupport.h>

src/unix/windows_c/windows_read_job.c

@@ -7,6 +7,7 @@
 
 #if defined(LWT_ON_WINDOWS)
 
+#include <caml/misc.h>
 #include <caml/memory.h>
 #include <caml/mlvalues.h>
 #include <caml/unixsupport.h>

src/unix/windows_c/windows_system_job.c

@@ -10,9 +10,9 @@
 #if OCAML_VERSION < 41300
 #define CAML_INTERNALS
 #endif
+#include <caml/misc.h>
 #include <caml/memory.h>
 #include <caml/mlvalues.h>
-#include <caml/misc.h>
 #include <caml/unixsupport.h>
 #include <caml/osdeps.h>
 

src/unix/windows_c/windows_write.c

@@ -7,6 +7,7 @@
 
 #if defined(LWT_ON_WINDOWS)
 
+#include <caml/misc.h>
 #include <caml/memory.h>
 #include <caml/mlvalues.h>
 #include <caml/unixsupport.h>

src/unix/windows_c/windows_write_job.c

@@ -7,6 +7,7 @@
 
 #if defined(LWT_ON_WINDOWS)
 
+#include <caml/misc.h>
 #include <caml/memory.h>
 #include <caml/mlvalues.h>
 #include <caml/unixsupport.h>

test/test.ml

@@ -1,6 +1,7 @@
 (* This file is part of Lwt, released under the MIT license. See LICENSE.md for
    details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *)
 
+let () = Printexc.record_backtrace true
 
 type test = {
   test_name : string;
@@ -9,6 +10,12 @@ type test = {
   run : unit -> bool Lwt.t;
 }
 
+type suite = {
+  suite_name : string;
+  suite_tests : test list;
+  skip_suite_if_this_is_false : unit -> bool;
+}
+
 type outcome =
   | Passed
   | Failed
@@ -28,15 +35,28 @@ let test_direct test_name ?(only_if = fun () -> true) run =
 let test test_name ?(only_if = fun () -> true) ?(sequential = false) run =
   {test_name; skip_if_this_is_false = only_if; sequential; run}
 
+let running_in_ci = Option.is_some (Sys.getenv_opt "CI")
+
 module Log =
 struct
-  let log_file =
+  let filename =
     let pid = Unix.getpid () in
     let ms = Unix.gettimeofday () |> modf |> fst in
-    let filename = Printf.sprintf "test.%i.%03.0f.log" pid (ms *. 1e3) in
-    open_out filename
+    Printf.sprintf "test.%i.%03.0f.log" pid (ms *. 1e3)
+  let log_file = open_out filename
   let () =
-    at_exit (fun () -> close_out_noerr log_file)
+    at_exit (fun () ->
+      if running_in_ci then
+        let ic = open_in filename in
+        try
+          while true do
+            let line = input_line ic in
+            print_endline line
+          done
+        with End_of_file ->
+          close_in ic ;
+      flush_all ();
+      close_out_noerr log_file)
 
   let start_time = ref None
   let elapsed () =
@@ -59,15 +79,15 @@ end
 
 let log = Log.log
 
-let run_test : test -> outcome Lwt.t = fun test ->
+let run_test : suite -> test -> outcome Lwt.t = fun suite test ->
   if test.skip_if_this_is_false () = false then begin
-    log @@ (fun k -> k test.test_name "skipping");
+    log @@ (fun k -> k (Printf.sprintf "[%s] %s" suite.suite_name test.test_name) "skipping");
     Lwt.return Skipped
   end
 
   else begin
     let start_time = Unix.gettimeofday () in
-    log @@ (fun k -> k test.test_name "starting");
+    log @@ (fun k -> k (Printf.sprintf "[%s] %s" suite.suite_name test.test_name) "starting");
 
     (* Lwt.async_exception_hook handling inspired by
          https://github.com/mirage/alcotest/issues/45 *)
@@ -102,7 +122,7 @@ let run_test : test -> outcome Lwt.t = fun test ->
       (fun () ->
         Lwt.async_exception_hook := old_async_exception_hook;
         let elapsed = Unix.gettimeofday () -. start_time in
-        log @@ (fun k -> k test.test_name "finished in %.3f s" elapsed);
+        log @@ (fun k -> k (Printf.sprintf "[%s] %s" suite.suite_name test.test_name) "finished in %.3f s" elapsed);
         Lwt.return_unit)
   end
 
@@ -114,12 +134,6 @@ let outcome_to_character : outcome -> string = function
 
 
 
-type suite = {
-  suite_name : string;
-  suite_tests : test list;
-  skip_suite_if_this_is_false : unit -> bool;
-}
-
 let contains_dup_tests suite tests =
   let names =
     List.map (fun t -> "suite:" ^ suite ^ " test:" ^ t.test_name) tests in
@@ -145,6 +159,7 @@ let suite name ?(only_if = fun () -> true) tests =
 
 let run_test_suite : suite -> ((string * outcome) list) Lwt.t = fun suite ->
   if suite.skip_suite_if_this_is_false () = false then
+    let () = log @@ (fun k -> k suite.suite_name "skipping") in
     let outcomes =
       suite.suite_tests
       |> List.map (fun {test_name; _} -> (test_name, Skipped))
@@ -158,7 +173,7 @@ let run_test_suite : suite -> ((string * outcome) list) Lwt.t = fun suite ->
 
   else
     suite.suite_tests |> Lwt_list.map_s begin fun test ->
-      Lwt.bind (run_test test) (fun outcome ->
+      Lwt.bind (run_test suite test) (fun outcome ->
       outcome |> outcome_to_character |> print_string;
       flush stdout;
       Lwt.return (test.test_name, outcome))
@@ -281,7 +296,7 @@ let concurrent library_name suites =
       if suite.skip_suite_if_this_is_false () = false then
         Lwt.return Skipped
       else
-        run_test test
+        run_test suite test
     end
     >|= fun outcome ->
     print_string (outcome_to_character outcome);
@@ -331,8 +346,14 @@ let concurrent library_name suites =
       | (suite, test), Exception exn ->
         Printf.eprintf "Test '%s' in suite '%s' raised '%s'\n"
           test.test_name suite.suite_name (Printexc.to_string exn)
-      | _ ->
-        ());
+      | (suite, test), Skipped ->
+        if running_in_ci then
+          Printf.eprintf "Test '%s' in suite '%s' skipped\n"
+            test.test_name suite.suite_name
+      | (suite, test), Passed ->
+        if running_in_ci then
+          Printf.eprintf "Test '%s' in suite '%s' passed\n"
+            test.test_name suite.suite_name);
     exit 1
   end