diff --git a/src/unix/lwt_process_stubs.c b/src/unix/lwt_process_stubs.c index 629682bac..fea5e032b 100644 --- a/src/unix/lwt_process_stubs.c +++ b/src/unix/lwt_process_stubs.c @@ -9,8 +9,20 @@ #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 @@ -68,6 +80,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 +107,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)) { diff --git a/test/unix/dummy.ml b/test/unix/dummy.ml index 2ec9f2577..f650450ac 100644 --- a/test/unix/dummy.ml +++ b/test/unix/dummy.ml @@ -23,9 +23,18 @@ let read () = let write fd = assert (test_input_len = Unix.write fd test_input 0 test_input_len) +let printenv () = + (* stdout is in text mode by default, which converts \n to \r\n on Windows. + switch to binary mode to prevent this, so the output is the same across + platforms. *) + set_binary_mode_out stdout true; + Array.iter (Printf.printf "%s\n") (Unix.unsafe_environment ()); + flush stdout + let () = match Sys.argv.(1) with | "read" -> exit @@ if read () then 0 else 1 | "write" -> write Unix.stdout | "errwrite" -> write Unix.stderr + | "printenv" -> printenv () | _ -> invalid_arg "Sys.argv" diff --git a/test/unix/test_lwt_process.ml b/test/unix/test_lwt_process.ml index cad23768b..7404f336d 100644 --- a/test/unix/test_lwt_process.ml +++ b/test/unix/test_lwt_process.ml @@ -8,7 +8,6 @@ open Lwt.Infix let expected_str = "the quick brown fox jumps over the lazy dog" let expected = Bytes.of_string expected_str -let expected_len = Bytes.length expected let check_status ?(status=(=) 0) = function | Unix.WEXITED n when status n -> Lwt.return_true @@ -22,7 +21,8 @@ let check_status ?(status=(=) 0) = function Printf.eprintf "stopped with signal %d" x; Lwt.return_false -let pwrite ~stdin pout = +let pwrite ~stdin pout expected = + let expected_len = Bytes.length expected in let args = [|"dummy.exe"; "read"|] in let proc = Lwt_process.exec ~stdin ("./dummy.exe", args) in let write = Lwt.finalize @@ -33,26 +33,47 @@ let pwrite ~stdin pout = assert (n = expected_len); check_status r -let pread ?stdout ?stderr pin = - let buf = Bytes.create expected_len in - let proc = match stdout, stderr with - | Some stdout, None -> - let args = [|"dummy.exe"; "write"|] in - Lwt_process.exec ~stdout ("./dummy.exe", args) - | None, Some stderr -> - let args = [|"dummy.exe"; "errwrite"|] in - Lwt_process.exec ~stderr ("./dummy.exe", args) - | _ -> assert false +let read_all ic buf ofs len = + let rec loop ic buf ofs len = + Lwt_unix.read ic buf ofs len >>= function + | 0 -> + Lwt.return ofs + | n -> + let ofs = ofs + n in + let len = len - n in + if len = 0 then + Lwt.return ofs + else + loop ic buf ofs len in - let read = Lwt_unix.read pin buf 0 expected_len in + loop ic buf ofs len + +let pread ?env ?stdout ?stderr pin cmd expected = + (match stdout, stderr with + | Some _, None + | None, Some _ -> + () + | _ -> assert false); + let expected_len = Bytes.length expected in + let buf = Bytes.create expected_len in + let args = [|"dummy.exe"; cmd|] in + let proc = Lwt_process.exec ?env ?stdout ?stderr ("./dummy.exe", args) in + let read = read_all pin buf 0 expected_len in proc >>= fun r -> read >>= fun n -> - assert (n = expected_len); + (if n <> expected_len then Printf.ksprintf failwith "expected %d bytes, got %d" expected_len n); assert (Bytes.equal buf expected); Lwt_unix.read pin buf 0 1 >>= fun n -> - assert (n = 0); + if n <> 0 then Printf.ksprintf failwith "expected 0 bytes remaining, got %d" n; check_status r +let bytes_of_env env = + env + |> Array.map (Printf.sprintf "%s\n") + |> Array.to_list + |> String.concat "" + |> Bytes.of_string + let suite = suite "lwt_process" [ (* The sleep command is not available on Win32. *) test "lazy_undefined" ~only_if:(fun () -> not Sys.win32) @@ -93,15 +114,36 @@ let suite = suite "lwt_process" [ test "can write to subproc stdin" (fun () -> let pin, pout = Lwt_unix.pipe_out ~cloexec:true () in - pwrite ~stdin:(`FD_move pin) pout); + pwrite ~stdin:(`FD_move pin) pout expected); test "can read from subproc stdout" (fun () -> let pin, pout = Lwt_unix.pipe_in ~cloexec:true () in - pread ~stdout:(`FD_move pout) pin); + pread ~stdout:(`FD_move pout) pin "write" expected); test "can read from subproc stderr" (fun () -> let pin, perr = Lwt_unix.pipe_in ~cloexec:true () in - pread ~stderr:(`FD_move perr) pin); + pread ~stderr:(`FD_move perr) pin "errwrite" expected); + + test "overrides env" + (fun () -> + let env = [| "FOO=1" |] in + let expected = Bytes.of_string "FOO=1\n" in + let pin, pout = Lwt_unix.pipe_in ~cloexec:true () in + pread ~env ~stdout:(`FD_move pout) pin "printenv" expected); + + test "passes env" + (fun () -> + let env = Unix.unsafe_environment () in + let expected = bytes_of_env env in + let pin, pout = Lwt_unix.pipe_in ~cloexec:true () in + pread ~env ~stdout:(`FD_move pout) pin "printenv" expected); + + test "inherits env" + (fun () -> + let env = Unix.unsafe_environment () in + let expected = bytes_of_env env in + let pin, pout = Lwt_unix.pipe_in ~cloexec:true () in + pread ?env:None ~stdout:(`FD_move pout) pin "printenv" expected); ]