From 278197992042f1d0f817ead100f11b9510c1b63c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Antonin=20D=C3=A9cimo?= Date: Tue, 25 Feb 2025 17:35:27 +0100 Subject: [PATCH] Display Windows NTSTATUS exit codes in hex MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit On Windows, "negative" exit codes are probably NTSTATUS values. For example, if a program accesses an invalid memory location, Unix sends a SIGSEGV signal which, if unhandled, will terminate the process (setting some kind of non-zero exit code - for example, Linux sets the exit code to 128 + signal number to give a fairly memorable 139). In the equivalent scenario, Windows throws an EXCEPTION_ACCESS_VIOLATION which, if handled by the default exception handler, will terminate the process with exit code STATUS_ACCESS_VIOLATION. These codes are large negative numbers, which are not terribly memorable in decimal, so for negative exit codes we instead display them in hexadecimal as 0xc0000005 is slightly more memorable than -1073741819. Co-authored-by: David Allsopp Signed-off-by: Antonin Décimo --- lib/os.ml | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) diff --git a/lib/os.ml b/lib/os.ml index b366f3bc..3b371b8f 100644 --- a/lib/os.ml +++ b/lib/os.ml @@ -34,6 +34,12 @@ let pp_cmd f (cmd, argv) = let argv = if cmd = "" then argv else cmd :: argv in Fmt.hbox Fmt.(list ~sep:sp (quote string)) f argv +let pp_exit_status f n = + if Sys.win32 && n < 0 then + Fmt.pf f "0x%08lx" (Int32.of_int n) + else + Fmt.int f n + let redirection = function | `FD_move_safely x -> `FD_copy x.raw | `Dev_null -> `Dev_null @@ -87,7 +93,7 @@ let process_result ~pp proc = | Unix.WSTOPPED x -> Fmt.error_msg "%t stopped with signal %a" pp Fmt.Dump.signal x) >>= function | Ok 0 -> Lwt_result.return () - | Ok n -> Lwt.return @@ Fmt.error_msg "%t failed with exit status %d" pp n + | Ok n -> Lwt.return @@ Fmt.error_msg "%t failed with exit status %a" pp pp_exit_status n | Error e -> Lwt_result.fail (e : [`Msg of string] :> [> `Msg of string]) (* Overridden in unit-tests *) @@ -97,7 +103,7 @@ let exec_result ?cwd ?stdin ?stdout ?stderr ~pp ?(is_success=((=) 0)) ?(cmd="") Logs.info (fun f -> f "Exec %a" pp_cmd (cmd, argv)); !lwt_process_exec ?cwd ?stdin ?stdout ?stderr ~pp (cmd, Array.of_list argv) >>= function | Ok n when is_success n -> Lwt_result.ok Lwt.return_unit - | Ok n -> Lwt.return @@ Fmt.error_msg "%t failed with exit status %d" pp n + | Ok n -> Lwt.return @@ Fmt.error_msg "%t failed with exit status %a" pp pp_exit_status n | Error e -> Lwt_result.fail (e : [`Msg of string] :> [> `Msg of string]) let exec ?timeout ?cwd ?stdin ?stdout ?stderr ?(is_success=((=) 0)) ?(cmd="") argv = @@ -105,7 +111,7 @@ let exec ?timeout ?cwd ?stdin ?stdout ?stderr ?(is_success=((=) 0)) ?(cmd="") ar let pp f = pp_cmd f (cmd, argv) in !lwt_process_exec ?timeout ?cwd ?stdin ?stdout ?stderr ~pp (cmd, Array.of_list argv) >>= function | Ok n when is_success n -> Lwt.return_unit - | Ok n -> Fmt.failwith "%t failed with exit status %d" pp n + | Ok n -> Fmt.failwith "%t failed with exit status %a" pp pp_exit_status n | Error (`Msg m) -> failwith m let running_as_root = not (Sys.unix) || Unix.getuid () = 0