diff --git a/boot/duneboot.ml b/boot/duneboot.ml index 7f41ce23645..703e86b6d56 100644 --- a/boot/duneboot.ml +++ b/boot/duneboot.ml @@ -1067,6 +1067,7 @@ let build ~ocaml_config ~dependencies ~c_files + ~build_flags ~link_flags { target = name, main; external_libraries; _ } = @@ -1114,7 +1115,7 @@ let build Process.run ~cwd:build_dir Config.compiler - (List.concat [ [ "-c"; "-g" ]; external_includes; [ file ] ]) + (List.concat [ [ "-c"; "-g" ]; external_includes; build_flags; [ file ] ]) >>| fun () -> Filename.chop_extension file ^ ext_obj)) >>= fun obj_files -> let compiled_ml_ext = @@ -1151,6 +1152,12 @@ let rec rm_rf fn = and clear dir = List.iter (readdir dir) ~f:rm_rf +let get_flags ocaml_system flags = + match List.assoc_opt ocaml_system flags with + | None -> [] + | Some flags -> flags +;; + (** {2 Bootstrap process} *) let main () = (try clear build_dir with @@ -1164,15 +1171,14 @@ let main () = let c_files = List.map ~f:(fun (_, _, c_files) -> c_files) libraries |> List.concat in get_dependencies libraries >>= fun dependencies -> - let link_flags = + let ocaml_system = match StringMap.find_opt "system" ocaml_config with | None -> assert false - | Some platform -> - (match List.assoc_opt platform Libs.link_flags with - | None -> [] - | Some flags -> flags) + | Some s -> s in - build ~ocaml_config ~dependencies ~c_files ~link_flags task + let build_flags = get_flags ocaml_system Libs.build_flags in + let link_flags = get_flags ocaml_system Libs.link_flags in + build ~ocaml_config ~dependencies ~c_files ~build_flags ~link_flags task ;; let () = Fiber.run (main ()) diff --git a/boot/libs.ml b/boot/libs.ml index 55eb8facc0b..d4fcfe4686f 100644 --- a/boot/libs.ml +++ b/boot/libs.ml @@ -97,6 +97,13 @@ let local_libraries = ; ("src/dune_rules_rpc", Some "Dune_rules_rpc", false, None) ] +let build_flags = + [ ("win32", [ "-ccopt"; "-D_UNICODE"; "-ccopt"; "-DUNICODE" ]) + ; ("win64", [ "-ccopt"; "-D_UNICODE"; "-ccopt"; "-DUNICODE" ]) + ; ("mingw", [ "-ccopt"; "-D_UNICODE"; "-ccopt"; "-DUNICODE" ]) + ; ("mingw64", [ "-ccopt"; "-D_UNICODE"; "-ccopt"; "-DUNICODE" ]) + ] + let link_flags = [ ("macosx", [ "-cclib" diff --git a/doc/changes/10212.md b/doc/changes/10212.md new file mode 100644 index 00000000000..fd5528aaa3a --- /dev/null +++ b/doc/changes/10212.md @@ -0,0 +1,2 @@ +- on Windows, use an unicode-aware version of `CreateProcess` to avoid crashes + when paths contains non-ascii characters. (#10212, fixes #10180, @emillon) diff --git a/src/dune_rules/bootstrap_info.ml b/src/dune_rules/bootstrap_info.ml index 5f9c2f0badf..1031e6b49af 100644 --- a/src/dune_rules/bootstrap_info.ml +++ b/src/dune_rules/bootstrap_info.ml @@ -15,6 +15,9 @@ let rule sctx ~requires_link (exes : Executables.t) = | Some x -> Left x | None -> Right lib) in + let windows_system_values = [ "win32"; "win64"; "mingw"; "mingw64" ] in + let win_build_flags = [ "-ccopt"; "-D_UNICODE"; "-ccopt"; "-DUNICODE" ] in + let build_flags = List.map windows_system_values ~f:(fun f -> f, win_build_flags) in let link_flags = let win_link_flags = [ "-cclib"; "-lshell32"; "-cclib"; "-lole32"; "-cclib"; "-luuid" ] @@ -22,12 +25,9 @@ let rule sctx ~requires_link (exes : Executables.t) = (* additional link flags keyed by the platform *) [ ( "macosx" , [ "-cclib"; "-framework CoreFoundation"; "-cclib"; "-framework CoreServices" ] ) - ; "win32", win_link_flags - ; "win64", win_link_flags - ; "mingw", win_link_flags - ; "mingw64", win_link_flags - ; "beos", [ "-cclib"; "-lbsd" ] (* flags for Haiku *) ] + @ List.map windows_system_values ~f:(fun w -> w, win_link_flags) + @ [ "beos", [ "-cclib"; "-lbsd" ] (* flags for Haiku *) ] in let+ locals = Memo.parallel_map locals ~f:(fun x -> @@ -83,6 +83,11 @@ let rule sctx ~requires_link (exes : Executables.t) = ; Pp.nop ; def "local_libraries" (List locals) ; Pp.nop + ; def + "build_flags" + (let open Dyn in + list (pair string (list string)) build_flags) + ; Pp.nop ; def "link_flags" (let open Dyn in diff --git a/vendor/spawn/src/dune b/vendor/spawn/src/dune index 3a23c0859ad..9b2c4559de3 100644 --- a/vendor/spawn/src/dune +++ b/vendor/spawn/src/dune @@ -2,5 +2,24 @@ (name spawn) (foreign_stubs (language c) + (flags (:standard (:include flags.sexp))) (names spawn_stubs)) (libraries unix threads.posix)) + +(rule + (target flags.sexp) + (enabled_if + (= %{os_type} "Win32")) + (action + (with-stdout-to + %{target} + (echo "(-DUNICODE -D_UNICODE)")))) + +(rule + (target flags.sexp) + (enabled_if + (<> %{os_type} "Win32")) + (action + (with-stdout-to + %{target} + (echo "()")))) diff --git a/vendor/spawn/src/spawn.ml b/vendor/spawn/src/spawn.ml index c7dcee07d0a..c2911e6358d 100644 --- a/vendor/spawn/src/spawn.ml +++ b/vendor/spawn/src/spawn.ml @@ -28,12 +28,20 @@ module Unix_backend = struct unsuccessful. In the end we decided not to default to [vfork] on OSX. *) - if is_osx then - Fork - else - Vfork + if is_osx then Fork else Vfork + ;; end +let no_null s = + if String.contains s '\000' + then + Printf.ksprintf + invalid_arg + "Spawn.Env.of_list: NUL bytes are not allowed in the environment but found one in \ + %S" + s +;; + module type Env = sig type t @@ -44,36 +52,30 @@ module Env_win32 : Env = struct type t = string let of_list env = - let len = - List.fold_left env ~init:1 ~f:(fun acc s -> acc + String.length s + 1) - in - let buf = Buffer.create len in - List.iter env ~f:(fun s -> + if env = [] + then "\000\000" + else ( + let len = List.fold_left env ~init:1 ~f:(fun acc s -> acc + String.length s + 1) in + let buf = Buffer.create len in + List.iter env ~f:(fun s -> + no_null s; Buffer.add_string buf s; Buffer.add_char buf '\000'); - Buffer.add_char buf '\000'; - Buffer.contents buf + Buffer.add_char buf '\000'; + Buffer.contents buf) + ;; end module Env_unix : Env = struct type t = string list - let no_null s = - if String.contains s '\000' then - Printf.ksprintf invalid_arg - "Spawn.Env.of_list: NUL bytes are not allowed in the environment but \ - found one in %S" - s - let of_list l = List.iter l ~f:no_null; l + ;; end -module Env : Env = (val if Sys.win32 then - (module Env_win32) - else - (module Env_unix) : Env) +module Env : Env = (val if Sys.win32 then (module Env_win32) else (module Env_unix) : Env) module Pgid = struct type t = int @@ -81,17 +83,13 @@ module Pgid = struct let new_process_group = 0 let of_pid = function - | 0 -> - raise (Invalid_argument "bad pid: 0 (hint: use [Pgid.new_process_group])") - | t -> - if t < 0 then - raise (Invalid_argument ("bad pid: " ^ string_of_int t)) - else - t + | 0 -> raise (Invalid_argument "bad pid: 0 (hint: use [Pgid.new_process_group])") + | t -> if t < 0 then raise (Invalid_argument ("bad pid: " ^ string_of_int t)) else t + ;; end -external spawn_unix : - env:Env.t option +external spawn_unix + : env:Env.t option -> cwd:Working_dir.t -> prog:string -> argv:string list @@ -101,29 +99,38 @@ external spawn_unix : -> use_vfork:bool -> setpgid:int option -> sigprocmask:(Unix.sigprocmask_command * int list) option - -> int = "spawn_unix_byte" "spawn_unix" + -> int + = "spawn_unix_byte" "spawn_unix" -external spawn_windows : - env:Env.t option +external spawn_windows + : env:Env.t option -> cwd:string option -> prog:string -> cmdline:string -> stdin:Unix.file_descr -> stdout:Unix.file_descr -> stderr:Unix.file_descr - -> int = "spawn_windows_byte" "spawn_windows" + -> int + = "spawn_windows_byte" "spawn_windows" let maybe_quote f = - if - String.contains f ' ' || String.contains f '\"' || String.contains f '\t' - || f = "" - then - Filename.quote f - else - f - -let spawn_windows ~env ~cwd ~prog ~argv ~stdin ~stdout ~stderr ~use_vfork:_ - ~setpgid:_ ~sigprocmask:_ = + if String.contains f ' ' || String.contains f '\"' || String.contains f '\t' || f = "" + then Filename.quote f + else f +;; + +let spawn_windows + ~env + ~cwd + ~prog + ~argv + ~stdin + ~stdout + ~stderr + ~use_vfork:_ + ~setpgid:_ + ~sigprocmask:_ + = let cwd = match (cwd : Working_dir.t) with | Path p -> Some p @@ -132,48 +139,49 @@ let spawn_windows ~env ~cwd ~prog ~argv ~stdin ~stdout ~stderr ~use_vfork:_ in let cmdline = String.concat (List.map argv ~f:maybe_quote) ~sep:" " in let prog = - match (Filename.is_relative prog, cwd) with + match Filename.is_relative prog, cwd with | true, Some p -> Filename.concat p prog | _ -> prog in spawn_windows ~env ~cwd ~prog ~cmdline ~stdin ~stdout ~stderr +;; let no_null s = - if String.contains s '\000' then - Printf.ksprintf invalid_arg - "Spawn.spawn: NUL bytes are not allowed in any of the arguments but \ - found one in %S" + if String.contains s '\000' + then + Printf.ksprintf + invalid_arg + "Spawn.spawn: NUL bytes are not allowed in any of the arguments but found one in %S" s - -let spawn ?env ?(cwd = Working_dir.Inherit) ~prog ~argv ?(stdin = Unix.stdin) - ?(stdout = Unix.stdout) ?(stderr = Unix.stderr) - ?(unix_backend = Unix_backend.default) ?setpgid ?sigprocmask () = +;; + +let spawn + ?env + ?(cwd = Working_dir.Inherit) + ~prog + ~argv + ?(stdin = Unix.stdin) + ?(stdout = Unix.stdout) + ?(stderr = Unix.stderr) + ?(unix_backend = Unix_backend.default) + ?setpgid + ?sigprocmask + () + = (match cwd with - | Path s -> no_null s - | Fd _ - | Inherit -> - ()); + | Path s -> no_null s + | Fd _ | Inherit -> ()); no_null prog; List.iter argv ~f:no_null; - let backend = - if Sys.win32 then - spawn_windows - else - spawn_unix - in + let backend = if Sys.win32 then spawn_windows else spawn_unix in let use_vfork = match unix_backend with | Vfork -> true | Fork -> false in - backend ~env ~cwd ~prog ~argv ~stdin ~stdout ~stderr ~use_vfork ~setpgid - ~sigprocmask + backend ~env ~cwd ~prog ~argv ~stdin ~stdout ~stderr ~use_vfork ~setpgid ~sigprocmask +;; external safe_pipe : unit -> Unix.file_descr * Unix.file_descr = "spawn_pipe" -let safe_pipe = - if Sys.win32 then - fun () -> - Unix.pipe ~cloexec:true () - else - safe_pipe +let safe_pipe = if Sys.win32 then fun () -> Unix.pipe ~cloexec:true () else safe_pipe diff --git a/vendor/spawn/src/spawn.mli b/vendor/spawn/src/spawn.mli index e4d2454b395..3cbab8ac210 100644 --- a/vendor/spawn/src/spawn.mli +++ b/vendor/spawn/src/spawn.mli @@ -6,10 +6,10 @@ module Working_dir : sig type t = - | Path of string (** Path in the filesystem *) + | Path of string (** Path in the filesystem *) | Fd of Unix.file_descr (** File descriptor pointing to a directory. Not supported on Windows. *) - | Inherit (** Inherit the working directory of the current process *) + | Inherit (** Inherit the working directory of the current process *) end module Unix_backend : sig @@ -110,8 +110,8 @@ end [unix_backend] describes what backend to use on Unix. If set to [Default], [vfork] is used unless the environment variable [SPAWN_USE_FORK] is set. On Windows, [CreateProcess] is used. *) -val spawn : - ?env:Env.t +val spawn + : ?env:Env.t -> ?cwd:Working_dir.t (* default: [Inherit] *) -> prog:string -> argv:string list diff --git a/vendor/spawn/src/spawn_stubs.c b/vendor/spawn/src/spawn_stubs.c index 2b025075879..4ff78fa4cf8 100644 --- a/vendor/spawn/src/spawn_stubs.c +++ b/vendor/spawn/src/spawn_stubs.c @@ -1,5 +1,25 @@ #define _GNU_SOURCE +/* Must come before any other caml/ headers are included */ +#define CAML_INTERNALS + +#ifdef _WIN32 +/* for [caml_win32_multi_byte_to_wide_char] */ +#include + +/* Prior to OCaml 5.0, the function was called win_multi_byte_to_wide_char */ +#include +#if OCAML_VERSION_MAJOR < 5 +#define caml_win32_multi_byte_to_wide_char win_multi_byte_to_wide_char +#define caml_win32_maperr win32_maperr +#endif +#endif + +/* for [caml_convert_signal_number] */ +#include + +#undef CAML_INTERNALS + #include #include #include @@ -8,9 +28,6 @@ #include -#include -CAMLextern int caml_convert_signal_number(int); - #if defined(__APPLE__) # if defined(__MAC_OS_X_VERSION_MAX_ALLOWED) @@ -846,31 +863,51 @@ CAMLprim value spawn_windows(value v_env, { STARTUPINFO si; PROCESS_INFORMATION pi; + WCHAR *prog; + WCHAR *cmdline; + WCHAR *env = NULL; + WCHAR *cwd = NULL; + BOOL result; ZeroMemory(&si, sizeof(si)); ZeroMemory(&pi, sizeof(pi)); - si.cb = sizeof(si); - si.dwFlags = STARTF_USESTDHANDLES; if (!dup2_and_clear_close_on_exec(v_stdin , &si.hStdInput ) || !dup2_and_clear_close_on_exec(v_stdout, &si.hStdOutput) || !dup2_and_clear_close_on_exec(v_stderr, &si.hStdError )) { - win32_maperr(GetLastError()); + caml_win32_maperr(GetLastError()); close_std_handles(&si); uerror("DuplicateHandle", Nothing); } - if (!CreateProcess(String_val(v_prog), - Bytes_val(v_cmdline), - NULL, - NULL, - TRUE, - 0, - Is_block(v_env) ? Bytes_val(Field(v_env, 0)) : NULL, - Is_block(v_cwd) ? String_val(Field(v_cwd, 0)) : NULL, - &si, - &pi)) { - win32_maperr(GetLastError()); + prog = caml_stat_strdup_to_utf16(String_val(v_prog)); + cmdline = caml_stat_strdup_to_utf16(String_val(v_cmdline)); + + if (Is_block(v_env)) { + v_env = Field(v_env, 0); + mlsize_t len = caml_string_length(v_env); + int size = caml_win32_multi_byte_to_wide_char(String_val(v_env), len, NULL, 0); + env = caml_stat_alloc(size * sizeof(WCHAR)); + caml_win32_multi_byte_to_wide_char(String_val(v_env), len, env, size); + } + + if (Is_block(v_cwd)) + cwd = caml_stat_strdup_to_utf16(String_val(Field(v_cwd, 0))); + + si.cb = sizeof(si); + si.dwFlags = STARTF_USESTDHANDLES; + + result = + CreateProcess(prog, cmdline, NULL, NULL, TRUE, CREATE_UNICODE_ENVIRONMENT, + env, cwd, &si, &pi); + + caml_stat_free(prog); + caml_stat_free(cmdline); + caml_stat_free(env); + caml_stat_free(cwd); + + if (!result) { + caml_win32_maperr(GetLastError()); close_std_handles(&si); uerror("CreateProcess", Nothing); } diff --git a/vendor/update-spawn.sh b/vendor/update-spawn.sh index faec2e53643..4954b043c40 100755 --- a/vendor/update-spawn.sh +++ b/vendor/update-spawn.sh @@ -1,6 +1,6 @@ #!/bin/bash -version=e184beb298d9abe0c524a4839bb0bec3d2571282 +version=d5991f7eb4073c85b440789587936d14b4e0417f set -e -o pipefail