Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

fix setting Lwt_process env on Windows #967

Open
wants to merge 3 commits into
base: master
Choose a base branch
from
Open
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
30 changes: 28 additions & 2 deletions src/unix/lwt_process_stubs.c
Original file line number Diff line number Diff line change
Expand Up @@ -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 <caml/alloc.h>
Expand Down Expand Up @@ -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));
Expand All @@ -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)) {
Expand Down
9 changes: 9 additions & 0 deletions test/unix/dummy.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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"
78 changes: 60 additions & 18 deletions test/unix/test_lwt_process.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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
Expand All @@ -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
raphael-proust marked this conversation as resolved.
Show resolved Hide resolved
| 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)
Expand Down Expand Up @@ -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);
]
Loading