Use Windows Unicode API in C stubs, require OCaml >= 4.06

ocsigen · Oct 6, 2021 · 9fced69 · 9fced69
1 parent e12504e
commit 9fced69
Show file tree

Hide file tree

Showing 4 changed files with 47 additions and 13 deletions.
diff --git a/lwt.opam b/lwt.opam
@@ -23,7 +23,7 @@ depends: [
   "dune" {>= "1.8.0"}
   "dune-configurator"
   "mmap" {>= "1.1.0"} # mmap is needed as long as Lwt supports OCaml < 4.06.0.
-  "ocaml" {>= "4.02.0"}
+  "ocaml" {>= "4.02.0" & "os" != "win32 " | >= "4.06.0"}
   ("ocaml" {>= "4.08.0"} | "ocaml-syntax-shims")
   "ocplib-endian"
   "result" # result is needed as long as Lwt supports OCaml 4.02.

diff --git a/src/unix/config/discover.ml b/src/unix/config/discover.ml
@@ -262,10 +262,11 @@ struct
 
   let ws2_32_lib context =
     if Configurator.ocaml_config_var_exn context "os_type" = "Win32" then
+      let unicode = ["-DUNICODE"; "-D_UNICODE"] in
       if Configurator.ocaml_config_var_exn context "ccomp_type" = "msvc" then
-        extend [] ["ws2_32.lib"]
+        extend unicode ["ws2_32.lib"]
       else
-        extend [] ["-lws2_32"]
+        extend unicode ["-lws2_32"]
 
   let c_flags () =
     !c_flags

diff --git a/src/unix/lwt_process_stubs.c b/src/unix/lwt_process_stubs.c
@@ -10,10 +10,15 @@
 #include <lwt_unix.h>
 
 #define CAML_NAME_SPACE
+#include <caml/version.h>
+#if OCAML_VERSION < 41300
+#define CAML_INTERNALS
+#endif
 
 #include <caml/alloc.h>
 #include <caml/fail.h>
 #include <caml/memory.h>
+#include <caml/osdeps.h>
 
 static HANDLE get_handle(value opt) {
   value fd;
@@ -29,15 +34,25 @@ static HANDLE get_handle(value opt) {
     return INVALID_HANDLE_VALUE;
 }
 
-#define string_option(opt) (Is_block(opt) ? String_val(Field(opt, 0)) : NULL)
-
 CAMLprim value lwt_process_create_process(value prog, value cmdline, value env,
                                           value cwd, value fds) {
   CAMLparam5(prog, cmdline, env, cwd, fds);
   CAMLlocal1(result);
 
   STARTUPINFO si;
   PROCESS_INFORMATION pi;
+  BOOL ret;
+
+#define string_option(opt) \
+  (Is_block(opt) ? caml_stat_strdup_to_os(String_val(Field(opt, 0))) : NULL)
+
+  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
 
   ZeroMemory(&si, sizeof(si));
   ZeroMemory(&pi, sizeof(pi));
@@ -47,9 +62,14 @@ CAMLprim value lwt_process_create_process(value prog, value cmdline, value env,
   si.hStdOutput = get_handle(Field(fds, 1));
   si.hStdError = get_handle(Field(fds, 2));
 
-  if (!CreateProcess(string_option(prog), (LPSTR)String_val(cmdline), NULL,
-                     NULL, TRUE, 0, (LPVOID)string_option(env),
-                     string_option(cwd), &si, &pi)) {
+  ret = CreateProcess(progs, cmdlines, NULL, NULL, TRUE, 0,
+                      envs, cwds, &si, &pi);
+  caml_stat_free(progs);
+  caml_stat_free(cmdlines);
+  caml_stat_free(envs);
+  caml_stat_free(cwds);
+
+  if (!ret) {
     win32_maperr(GetLastError());
     uerror("CreateProcess", Nothing);
   }

diff --git a/src/unix/windows_c/windows_system_job.c b/src/unix/windows_c/windows_system_job.c
@@ -7,8 +7,16 @@
 
 #if defined(LWT_ON_WINDOWS)
 
+#define CAML_NAME_SPACE
+#include <caml/version.h>
+#if OCAML_VERSION < 41300
+#define CAML_INTERNALS
+#endif
+#include <caml/memory.h>
 #include <caml/mlvalues.h>
+#include <caml/misc.h>
 #include <caml/unixsupport.h>
+#include <caml/osdeps.h>
 
 #include "lwt_unix.h"
 
@@ -40,23 +48,28 @@ static value result_system(struct job_system *job)
 
 CAMLprim value lwt_unix_system_job(value cmdline)
 {
+    CAMLparam1(cmdline);
     STARTUPINFO si;
     PROCESS_INFORMATION pi;
+    BOOL ret;
+
+    char_os *cmdlines = caml_stat_strdup_to_os(String_val(cmdline));
 
     ZeroMemory(&si, sizeof(si));
     ZeroMemory(&pi, sizeof(pi));
     si.cb = sizeof(si);
-    /* The cast to LPSTR below is only legitimate because we are calling
-       CreateProcessA. See https://github.com/ocsigen/lwt/pull/790. */
-    if (!CreateProcess(NULL, (LPSTR)String_val(cmdline), NULL, NULL, TRUE, 0,
-                       NULL, NULL, &si, &pi)) {
+
+    ret = CreateProcess(NULL, cmdlines, NULL, NULL, TRUE, 0,
+                        NULL, NULL, &si, &pi);
+    caml_stat_free(cmdlines);
+    if (!ret) {
         win32_maperr(GetLastError());
         uerror("CreateProcess", Nothing);
     } else {
         LWT_UNIX_INIT_JOB(job, system, 0);
         CloseHandle(pi.hThread);
         job->handle = pi.hProcess;
-        return lwt_unix_alloc_job(&(job->job));
+        CAMLreturn(lwt_unix_alloc_job(&(job->job)));
     }
 }
 #endif