spawn_glib_23.0.0_440f8b8a/source/spawn/spawn-processes-windows.adb

--
--  Copyright (C) 2018-2021, AdaCore
--
--  SPDX-License-Identifier: Apache-2.0
--

with Ada.Characters.Wide_Latin_1;
with Ada.Strings.UTF_Encoding.Wide_Strings;
with Ada.Strings.Wide_Fixed;
with Ada.Strings.Wide_Unbounded;
with Interfaces.C.Strings;

pragma Warnings (Off);
with System.OS_Interface;
with System.Win32;
pragma Warnings (On);

with Spawn.Environments.Internal;

package body Spawn.Processes.Windows is

   Terminate_Code : constant Windows_API.UINT := 16#F291#;
   --  Arbitrary code to use as exit code for TerminateProcess call.

   package Read_Write_Ex is
     new Windows_API.Generic_Read_Write_Ex (Internal.Context);

   procedure Standard_Output_Callback
     (dwErrorCode               : Windows_API.DWORD;
      dwNumberOfBytesTransfered : Windows_API.DWORD;
      lpOverlapped              : access Internal.Context)
        with Convention => Stdcall;

   procedure Standard_Error_Callback
     (dwErrorCode               : Windows_API.DWORD;
      dwNumberOfBytesTransfered : Windows_API.DWORD;
      lpOverlapped              : access Internal.Context)
        with Convention => Stdcall;

   procedure Append_Escaped_String
     (Command_Line : in out Ada.Strings.Wide_Unbounded.Unbounded_Wide_String;
      Argument     : Ada.Strings.Unbounded.Unbounded_String);
   --  Append the given argument to a command line such that CommandLineToArgvW
   --  return the argument string unchanged. Arguments in a command line should
   --  be separated by spaces; this subprogram doesn't add these spaces.

   function Internal_Terminate_Process
     (hWnd   : Windows_API.HWND;
      lParam : Windows_API.LPARAM) return Windows_API.BOOL;
   --  Post WM_CLOSE message to the window when given window belongs to given
   --  process. lParam is process identifier in DWORD format.

   Callback : constant array (Stdout .. Stderr) of Read_Write_Ex.Callback :=
     (Standard_Output_Callback'Access,
      Standard_Error_Callback'Access);

   Pipe_Count : Interfaces.Unsigned_32 := 0;
   --  Counter of pipes created by current process. It is used to construct
   --  unique name of the named pipe.

   ---------------------------
   -- Append_Escaped_String --
   ---------------------------

   procedure Append_Escaped_String
     (Command_Line : in out Ada.Strings.Wide_Unbounded.Unbounded_Wide_String;
      Argument     : Ada.Strings.Unbounded.Unbounded_String)
   is
      --  Implementation of the subprogram based on Microsoft's blog post
      --  "Everyone quotes command line arguments the wrong way".

      use Ada.Strings.Wide_Unbounded;

      Quotation_Check_Pattern : constant Wide_String :=
        Ada.Characters.Wide_Latin_1.Space
        & Ada.Characters.Wide_Latin_1.Quotation
        & Ada.Characters.Wide_Latin_1.LF
        & Ada.Characters.Wide_Latin_1.HT
        & Ada.Characters.Wide_Latin_1.VT;

      S : constant Wide_String :=
        Ada.Strings.UTF_Encoding.Wide_Strings.Decode
          (Ada.Strings.Unbounded.To_String (Argument));

      J : Natural;  --  Iterator
      N : Natural;  --  Number of sequential backslashes.

   begin
      if S'Length /= 0
        and then Ada.Strings.Wide_Fixed.Index (S, Quotation_Check_Pattern) /= 0
      then
         --  Don't quote unless we actually need to do so - hopefully avoid
         --  problems if programs won't parse quotes properly.

         Append (Command_Line, S);

      else
         Append (Command_Line, '"');
         --  Opening double quotation mark

         J := S'First;

         while J <= S'Last loop
            N := 0;

            while J <= S'Last and then S (J) = '\' loop
               J := J + 1;
               N := N + 1;
            end loop;

            if J > S'Last then
               --  Escape all backslashed, but let the terminating double
               --  quotation mark we add below be interpreted as a
               --  metacharacter.

               Append (Command_Line, (N * 2) * '\');

            elsif S (J) = '"' then
               --  Escape all backslashes and the following double
               --  quotation mark.

               Append (Command_Line, (N * 2 + 1) * '\');
               Append (Command_Line, '"');

            else
               --  Backslashes aren't special here.

               Append (Command_Line, N * '\');
               Append (Command_Line, S (J));
            end if;

            J := J + 1;
         end loop;

         Append (Command_Line, '"');
         --  Closing double quotation mark
      end if;
   end Append_Escaped_String;

   --------------------------------
   -- Internal_Terminate_Process --
   --------------------------------

   function Internal_Terminate_Process
     (hWnd   : Windows_API.HWND;
      lParam : Windows_API.LPARAM) return Windows_API.BOOL
   is
      use type Windows_API.DWORD;

      Process_ID         : constant Windows_API.DWORD :=
        Windows_API.DWORD (lParam);
      Current_Thread_ID  : Windows_API.DWORD with Unreferenced;
      Current_Process_ID : aliased Windows_API.DWORD  := 0;
      Dummy              : Windows_API.BOOL;

   begin
      Current_Thread_ID :=
        Windows_API.GetWindowThreadProcessId (hWnd, Current_Process_ID'Access);

      if Current_Process_ID = Process_ID then
         Dummy := Windows_API.PostMessageW (hWnd, Windows_API.WM_CLOSE, 0, 0);
      end if;

      return System.Win32.TRUE;
   end Internal_Terminate_Process;

   -------------------
   -- Do_Close_Pipe --
   -------------------

   procedure Do_Close_Pipe
     (Self : in out Process'Class;
      Kind : Pipe_Kinds)
   is
      use type Windows_API.HANDLE;

      procedure Check_Error (Value : Windows_API.BOOL);

      -----------------
      -- Check_Error --
      -----------------

      procedure Check_Error (Value : Windows_API.BOOL) is
         use type Windows_API.BOOL;
      begin
         if Value = System.Win32.FALSE then
            Self.Listener.Error_Occurred
              (Integer (System.Win32.GetLastError));
         end if;
      end Check_Error;

      Handle : Windows_API.HANDLE renames Self.pipe (Kind).Handle;
   begin
      if Handle /= System.Win32.INVALID_HANDLE_VALUE then
         Check_Error (Windows_API.CancelIo (Self.pipe (Kind).Handle));
         Check_Error (System.Win32.CloseHandle (Self.pipe (Kind).Handle));
         Self.pipe (Kind).Handle := System.Win32.INVALID_HANDLE_VALUE;
      end if;
   end Do_Close_Pipe;

   ---------------------
   -- Do_Kill_Process --
   ---------------------

   procedure Do_Kill_Process (Self : in out Process'Class) is
      Success : Windows_API.BOOL with Unreferenced;

   begin
      Success :=
        Windows_API.TerminateProcess (Self.pid.hProcess, Terminate_Code);
   end Do_Kill_Process;

   -------------
   -- Do_Read --
   -------------

   procedure Do_Read
     (Self       : in out Process'Class;
      Data       : out Ada.Streams.Stream_Element_Array;
      Last       : out Ada.Streams.Stream_Element_Offset;
      Kind       : Pipe_Kinds;
      On_No_Data : access procedure)
   is
      use type Ada.Streams.Stream_Element_Offset;

      Count : constant Ada.Streams.Stream_Element_Offset :=
        Self.pipe (Kind).Last;

   begin
      if Count = 0 then
         Last := Data'First - 1;
         On_No_Data.all;
      elsif Count > Data'Length then
         Self.pipe (Kind).Last := Count - Data'Length;
         Last := Data'Last;
         Data := Self.pipe (Kind).Buffer (1 .. Data'Length);

         Self.pipe (Kind).Buffer (1 .. Count - Data'Length) :=
           Self.pipe (Kind).Buffer (Data'Length + 1 .. Count);
      else
         Self.pipe (Kind).Last := 0;
         Last := Data'First + Count - 1;
         Data (Data'First .. Last) := Self.pipe (Kind).Buffer (1 .. Count);
      end if;
   end Do_Read;

   ----------------------
   -- Do_Start_Process --
   ----------------------

   procedure Do_Start_Process
     (Self     : aliased in out Process'Class;
      On_Start : access procedure)
   is
      function Make_Command_Line return Interfaces.C.wchar_array;
      function Work_Directory return String;
      function Is_Error (Value : Windows_API.BOOL) return Boolean;
      procedure Request_Read (Kind : Standard_Pipe);

      procedure Create_Pipe
        (Parent_Handle : out Windows_API.HANDLE;
         Child_Handle  : out Windows_API.HANDLE;
         Inbound       : Boolean;
         Success       : in out Boolean);

      function Create_Pipes
        (Start : access Windows_API.STARTUPINFOW) return Boolean;

      use type Windows_API.BOOL;
      use type Windows_API.DWORD;
      use type Windows_API.HANDLE;

      -----------------
      -- Create_Pipe --
      -----------------

      procedure Create_Pipe
        (Parent_Handle : out Windows_API.HANDLE;
         Child_Handle  : out Windows_API.HANDLE;
         Inbound       : Boolean;
         Success       : in out Boolean)
      is
         use type Interfaces.Unsigned_32;

         procedure Ignore (Value : System.Win32.BOOL) is null;
         procedure Ignore (Value : System.Win32.DWORD) is null;
         --  Used to ignore returned value of the Windows API functions

         Process_Id_Image : constant String :=
           Spawn.Windows_API.DWORD'Image
             (Spawn.Windows_API.GetCurrentProcessId);

         Mode : constant array (Boolean) of Windows_API.DWORD :=
           (True  => Windows_API.PIPE_ACCESS_INBOUND,
            False => Windows_API.PIPE_ACCESS_OUTBOUND);

         Client_Access : constant array (Boolean) of Windows_API.DWORD :=
           (True  => System.Win32.GENERIC_WRITE,
            False =>
              System.Win32.GENERIC_READ + System.Win32.FILE_WRITE_ATTRIBUTES);

         Inherit_Handle      : aliased System.Win32.SECURITY_ATTRIBUTES :=
           (nLength             => System.Win32.SECURITY_ATTRIBUTES'Size / 8,
            pSecurityDescriptor => System.Null_Address,
            bInheritHandle      => System.Win32.TRUE);
         Dont_Inherit_Handle : aliased System.Win32.SECURITY_ATTRIBUTES :=
           (nLength             => System.Win32.SECURITY_ATTRIBUTES'Size / 8,
            pSecurityDescriptor => System.Null_Address,
            bInheritHandle      => System.Win32.FALSE);

         Pipe_Name : Interfaces.C.Strings.chars_ptr;
         Attempts  : Natural := 1_000;

      begin
         --  Create named pipe and server handle

         loop
            declare
               Pipe_Count_Image : constant String :=
                 Interfaces.Unsigned_32'Image (Pipe_Count);

            begin
               Interfaces.C.Strings.Free (Pipe_Name);
               Pipe_Name :=
                 Interfaces.C.Strings.New_String
                   (Spawn.Windows_API.Pipe_Name_Prefix
                    & "ada-"
                    & Process_Id_Image
                      (Process_Id_Image'First + 1 .. Process_Id_Image'Last)
                    & '-'
                    & Pipe_Count_Image
                      (Pipe_Count_Image'First + 1 .. Pipe_Count_Image'Last));
               --  Each named pipe is created with unique name.

               Pipe_Count := Pipe_Count + 1;

               Parent_Handle := Windows_API.CreateNamedPipeA
                 (lpName               => Pipe_Name,
                  dwOpenMode           =>
                    Mode (Inbound) + Windows_API.FILE_FLAG_OVERLAPPED,
                  dwPipeMode           =>
                    Windows_API.PIPE_TYPE_BYTE
                      + Windows_API.PIPE_WAIT
                      + Windows_API.PIPE_REJECT_REMOTE_CLINETS,
                  nMaxInstances        => 1,
                  nOutBufferSize       => 0,
                  nInBufferSize        => 0,
                  nDefaultTimeOut      => 0,
                  lpSecurityAttributes => Dont_Inherit_Handle'Access);

               exit when Parent_Handle /= System.Win32.INVALID_HANDLE_VALUE;

               declare
                  Error : constant Windows_API.DWORD :=
                    System.Win32.GetLastError;

               begin
                  Attempts := Attempts - 1;

                  if Error /= Windows_API.ERROR_PIPE_BUSY or Attempts = 0 then
                     Self.Listener.Error_Occurred (Integer (Error));

                     Interfaces.C.Strings.Free (Pipe_Name);

                     Child_Handle  := System.Win32.INVALID_HANDLE_VALUE;
                     Parent_Handle := System.Win32.INVALID_HANDLE_VALUE;
                     Success       := False;

                     return;
                  end if;
               end;
            end;
         end loop;

         --  Open named pipe to create client handle

         Child_Handle := Windows_API.CreateFileA
           (lpFileName            => Pipe_Name,
            dwDesiredAccess       => Client_Access (Inbound),
            dwShareMode           => 0,
            lpSecurityAttributes  => Inherit_Handle'Access,
            dwCreationDisposition => System.Win32.OPEN_EXISTING,
            dwFlagsAndAttributes  => Windows_API.FILE_FLAG_OVERLAPPED,
            hTemplateFile         => 0);

         if Child_Handle = System.Win32.INVALID_HANDLE_VALUE then
            Self.Listener.Error_Occurred (Integer (System.Win32.GetLastError));

            Interfaces.C.Strings.Free (Pipe_Name);
            Ignore (System.Win32.CloseHandle (Parent_Handle));

            Child_Handle  := System.Win32.INVALID_HANDLE_VALUE;
            Parent_Handle := System.Win32.INVALID_HANDLE_VALUE;
            Success       := False;

            return;
         end if;

         Interfaces.C.Strings.Free (Pipe_Name);

         --  Wait till connection is in place

         declare
            Overlapped : aliased Windows_API.OVERLAPPED;

         begin
            Overlapped.hEvent :=
              System.OS_Interface.CreateEvent
                (pEventAttributes => null,
                 bManualReset     => System.Win32.TRUE,
                 bInitialState    => System.Win32.FALSE,
                 pName            => Interfaces.C.Strings.Null_Ptr);

            if Windows_API.ConnectNamedPipe (Parent_Handle, Overlapped'Access)
              = System.Win32.FALSE
            then
               declare
                  Error : constant Windows_API.DWORD :=
                    System.Win32.GetLastError;

               begin
                  case Error is
                     when Windows_API.ERROR_PIPE_CONNECTED =>
                        null;

                     when Windows_API.ERROR_IO_PENDING =>
                        Ignore
                          (System.OS_Interface.WaitForSingleObject
                             (Overlapped.hEvent,
                              System.OS_Interface.Wait_Infinite));

                     when others =>
                        Self.Listener.Error_Occurred
                          (Integer (System.Win32.GetLastError));

                        Ignore (System.Win32.CloseHandle (Overlapped.hEvent));
                        Ignore (System.Win32.CloseHandle (Parent_Handle));
                        Ignore (System.Win32.CloseHandle (Child_Handle));

                        Child_Handle  := System.Win32.INVALID_HANDLE_VALUE;
                        Parent_Handle := System.Win32.INVALID_HANDLE_VALUE;
                        Success       := False;

                        return;
                  end case;
               end;
            end if;

            Ignore (System.Win32.CloseHandle (Overlapped.hEvent));
         end;

         Success := True;
      end Create_Pipe;

      ------------------
      -- Create_Pipes --
      ------------------

      function Create_Pipes
        (Start : access Windows_API.STARTUPINFOW) return Boolean
      is
         Child : constant array (Standard_Pipe) of
           not null access Windows_API.HANDLE :=
             (Stdin  => Start.hStdInput'Access,
              Stdout => Start.hStdOutput'Access,
              Stderr => Start.hStdError'Access);

         Ok : Boolean := True;
      begin
         for J in Standard_Pipe loop
            Self.pipe (J).Process := Self'Unchecked_Access;
            Self.pipe (J).Kind := J;
            Create_Pipe
              (Parent_Handle => Self.pipe (J).Handle,
               Child_Handle  => Child (J).all,
               Inbound       => J /= Stdin,
               Success       => Ok);

            exit when not Ok;
         end loop;

         return Ok;
      end Create_Pipes;

      --------------
      -- If_Error --
      --------------

      function Is_Error (Value : Windows_API.BOOL) return Boolean is
      begin
         if Value = System.Win32.FALSE then
            Self.Listener.Error_Occurred (Integer (System.Win32.GetLastError));
            return True;
         else
            return False;
         end if;
      end Is_Error;

      -----------------------
      -- Make_Command_Line --
      -----------------------

      function Make_Command_Line return Interfaces.C.wchar_array is
         Result : Ada.Strings.Wide_Unbounded.Unbounded_Wide_String;

      begin
         Append_Escaped_String (Result, Self.Program);

         for Arg of Self.Arguments loop
            Ada.Strings.Wide_Unbounded.Append (Result, ' ');
            Append_Escaped_String
              (Result, Ada.Strings.Unbounded.To_Unbounded_String (Arg));
         end loop;

         return Interfaces.C.To_C
           (Ada.Strings.Wide_Unbounded.To_Wide_String (Result));
      end Make_Command_Line;

      ------------------
      -- Request_Read --
      ------------------

      procedure Request_Read (Kind : Standard_Pipe) is
      begin
         if Is_Error
           (Read_Write_Ex.ReadFileEx
              (hFile                => Self.pipe (Kind).Handle,
               lpBuffer             => Self.pipe (Kind).Buffer,
               nNumberOfBytesToRead => Self.pipe (Kind).Buffer'Length,
               lpOverlapped         => Self.pipe (Kind)'Access,
               lpCompletionRoutine  => Callback (Kind)))
         then
            null;  --  then what?
         end if;
      end Request_Read;

      --------------------
      -- Work_Directory --
      --------------------

      function Work_Directory return String is
         Directory : constant String :=
           Ada.Strings.Unbounded.To_String (Self.Directory);
      begin
         if Directory = "" then
            return ".";
         else
            return Directory;
         end if;
      end Work_Directory;

      Start : aliased Windows_API.STARTUPINFOW :=
        (cb      => Windows_API.STARTUPINFOW'Size / 8,
         dwFlags => Windows_API.STARTF_USESTDHANDLES,
         others  => <>);

      Exe : constant Interfaces.C.wchar_array :=
        Interfaces.C.To_C
          (Ada.Strings.UTF_Encoding.Wide_Strings.Decode
             (Ada.Strings.Unbounded.To_String (Self.Program)));

      Args : Interfaces.C.wchar_array := Make_Command_Line;

      Env  : constant Interfaces.C.wchar_array :=
        Spawn.Environments.Internal.Raw (Self.Environment);

      Dir  : constant Interfaces.C.wchar_array :=
        Interfaces.C.To_C
          (Ada.Strings.UTF_Encoding.Wide_Strings.Decode
             (Work_Directory));
   begin
      if not Create_Pipes (Start'Access) then
         return;
      end if;

      if Is_Error
        (Windows_API.CreateProcessW
           (lpApplicationName    => Exe,
            lpCommandLine        => Args,
            lpProcessAttributes  => null,
            lpThreadAttributes   => null,
            bInheritHandles      => System.Win32.TRUE,
            dwCreationFlags      => Windows_API.CREATE_NO_WINDOW +
              Windows_API.CREATE_UNICODE_ENVIRONMENT,
            lpEnvironment        => Env,
            lpCurrentDirectory   => Dir,
            lpStartupInfo        => Start'Access,
            lpProcessInformation => Self.pid'Access))
      then
         return;
      end if;

      On_Start.all;

      Self.Status := Running;
      Self.Listener.Started;
      Self.Listener.Standard_Input_Available;
      Request_Read (Stdout);
      Request_Read (Stderr);
   end Do_Start_Process;

   --------------------------
   -- Do_Terminate_Process --
   --------------------------

   procedure Do_Terminate_Process (Self : in out Process'Class) is
      Success : Windows_API.BOOL with Unreferenced;

   begin
      Success :=
        Windows_API.EnumWindows
          (Internal_Terminate_Process'Access,
           Windows_API.LPARAM (Self.pid.dwProcessId));
      Success :=
         Windows_API.PostThreadMessageW
          (Self.pid.dwThreadId, Windows_API.WM_CLOSE, 0, 0);
   end Do_Terminate_Process;

   --------------
   -- Do_Write --
   --------------

   procedure Do_Write
     (Self       : in out Process'Class;
      Data       : Ada.Streams.Stream_Element_Array;
      Last       : out Ada.Streams.Stream_Element_Offset;
      On_No_Data : access procedure)
   is
      use type Ada.Streams.Stream_Element_Count;

      Pipe  : Internal.Context renames Self.pipe (Stdin);
      Count : constant Ada.Streams.Stream_Element_Offset := Pipe.Last;
      Min   : constant Ada.Streams.Stream_Element_Offset :=
        Ada.Streams.Stream_Element_Offset'Min
          (Pipe.Buffer'Length, Data'Length);

   begin
      if Count = 0 then
         --  Buffer isn't busy, we can write
         Last := Data'First + Min - 1;
         Pipe.Buffer (1 .. Min) := Data (Data'First .. Last);
         Pipe.Last := Min;

         if Last < Data'Last then
            --  Only part of the data has been buffered, request notification
            --  after completion of the IO operation.

            Pipe.Last := Pipe.Last + Spawn.Internal.Buffer_Size;
         end if;

         On_No_Data.all;

      elsif Count in Internal.Stream_Element_Buffer'Range then
         --  Buffer is busy, mark stdin as 'send notification'
         Pipe.Last := Pipe.Last + Spawn.Internal.Buffer_Size;
         Last := Data'First - 1;
      else
         --  Buffer is busy and the 'send notification' mark has been set
         Last := Data'First - 1;
      end if;
   end Do_Write;

   -----------------
   -- IO_Callback --
   -----------------

   procedure IO_Callback
     (dwErrorCode               : Windows_API.DWORD;
      dwNumberOfBytesTransfered : Windows_API.DWORD;
      lpOverlapped              : access Internal.Context;
      Kind                      : Standard_Pipe)
   is
      use type Windows_API.DWORD;
      use type Windows_API.HANDLE;
      use type Ada.Streams.Stream_Element_Count;

      Self : Process'Class renames
        Process'Class (lpOverlapped.Process.all);

      Last : Ada.Streams.Stream_Element_Count := lpOverlapped.Last;

      Transfered : constant Ada.Streams.Stream_Element_Count :=
        Ada.Streams.Stream_Element_Count (dwNumberOfBytesTransfered);
   begin
      if Self.pipe (Kind).Handle = System.Win32.INVALID_HANDLE_VALUE then
         --  A user closed the pipe, but OS reports some IO on it
         return;
      end if;

      if dwErrorCode /= 0 then
         if not (Self.Status = Not_Running
                 and then dwErrorCode = Windows_API.ERROR_OPERATION_ABORTED)
         then
            Self.Listener.Error_Occurred (Integer (dwErrorCode));
         end if;

         return;
      end if;

      case Kind is
         when Stdin =>
            lpOverlapped.Last := 0;

            if Last in lpOverlapped.Buffer'Range then
               pragma Assert (Last = Transfered);

            else
               Last := Last - Spawn.Internal.Buffer_Size;
               pragma Assert (Last = Transfered);

               Self.Listener.Standard_Input_Available;
            end if;
            --  FIXME: what shall we do if Last /= Transfered?

         when Stderr =>
            lpOverlapped.Last := Transfered;
            Self.Listener.Standard_Error_Available;

         when Stdout =>
            lpOverlapped.Last := Transfered;
            Self.Listener.Standard_Output_Available;
      end case;
   end IO_Callback;

   ---------------------
   -- On_Process_Died --
   ---------------------

   procedure On_Process_Died (Self : in out Process'Class) is

      use type Windows_API.DWORD;

      function Is_Error (Value : Windows_API.BOOL) return Boolean;

      --------------
      -- If_Error --
      --------------

      function Is_Error (Value : Windows_API.BOOL) return Boolean is
         use type Windows_API.BOOL;
      begin
         if Value = System.Win32.FALSE then
            Self.Listener.Error_Occurred
              (Integer (System.Win32.GetLastError));
            return True;
         else
            return False;
         end if;
      end Is_Error;

      Exit_Code : aliased Windows_API.DWORD := 0;

   begin
      --  Close stdio pipes
      for J in Self.pipe'Range loop
         Windows.Do_Close_Pipe (Self, J);
      end loop;

      if not Is_Error
        (Windows_API.GetExitCodeProcess
           (Self.pid.hProcess, Exit_Code'Access))
        and then not Is_Error
          (System.Win32.CloseHandle (Self.pid.hProcess))
          and then not Is_Error
            (System.Win32.CloseHandle (Self.pid.hThread))
      then
         --  Process exit code can be application defined code, Win32 error
         --  code, HRESULT code (including Win32 code or NTSTATUS code
         --  converted into HRESULT), or NTSTATUS code. It is impossible to
         --  recognize used format exactly, thus some heuristic is used to
         --  detect "crash" cases, primary cases when system's HRESULT and
         --  NTSTATUS code reports failure. All custom error codes are
         --  interpreted as normal exit.
         --
         --  Win32 error code occupy two lower bytes and all higher bits are
         --  set to 0.
         --
         --  NTSTATUS upper bits are:
         --   | 31 | 30 | 29 | 28 |
         --   |   Sev   |  C |  N |
         --
         --  HRESULT upper bits are:
         --   | 31 | 30 | 29 | 28 |
         --   |  S |  R |  C |  N |
         --
         --  For both NTSTATUS and HRESULT 'C' is reserved for custom codes.
         --  All these codes interpreted as normal termination.
         --
         --  'N' is '0' for native NTSTATUS, but '1' when NTSTATUS is converted
         --  into HRESULT.
         --
         --  'Sev" is severity of the NTSTATUS. Only 2#11# is interpreted as
         --  crash.
         --
         --  'S" is severity of HRESULT, 2#1# means failure.

         if Exit_Code = Windows_API.DWORD (Terminate_Code)
           --  Process terminated by call to TerminateProcess
           or else (Exit_Code and 16#F000_0000#) = 16#D000_0000#
           --  NTSTATUS converted into HRESULT with STATUS_SERVERITY_ERROR
           --  (bits 28, 30 and 31 are set to '1', and bit 29 are set to '0')
           or else (Exit_Code and 16#B000_0000#) = 16#8000_0000#
           --  HRESULT with failure severity
         then
            Self.Exit_Status := Crash;

         else
            Self.Exit_Status := Normal;
         end if;

         Self.Exit_Code := Process_Exit_Code (Exit_Code);
         Self.Status := Not_Running;
         Self.Listener.Finished
           (Self.Exit_Status, Self.Exit_Code);
      end if;
   end On_Process_Died;

   -----------------------------
   -- Standard_Error_Callback --
   -----------------------------

   procedure Standard_Error_Callback
     (dwErrorCode               : Windows_API.DWORD;
      dwNumberOfBytesTransfered : Windows_API.DWORD;
      lpOverlapped              : access Internal.Context) is
   begin
      Windows.IO_Callback
        (dwErrorCode, dwNumberOfBytesTransfered, lpOverlapped, Stderr);
   end Standard_Error_Callback;

   ------------------------------
   -- Standard_Output_Callback --
   ------------------------------

   procedure Standard_Output_Callback
     (dwErrorCode               : Windows_API.DWORD;
      dwNumberOfBytesTransfered : Windows_API.DWORD;
      lpOverlapped              : access Internal.Context) is
   begin
      Windows.IO_Callback
        (dwErrorCode, dwNumberOfBytesTransfered, lpOverlapped, Stdout);
   end Standard_Output_Callback;

end Spawn.Processes.Windows;