diff --git a/Makefile b/Makefile index a1c7139..a14af21 100644 --- a/Makefile +++ b/Makefile @@ -19,7 +19,8 @@ endif all: gprbuild $(GPRBUILD_FLAGS) -P gnat/spawn.gpr - gprbuild $(GPRBUILD_FLAGS) -P gnat/spawn_tests.gpr + gprbuild $(GPRBUILD_FLAGS) -P gnat/spawn_tests.gpr -XSPAWN_LIBRARY_TYPE=static + check: export LD_LIBRARY_PATH=.libs/spawn/relocatable; \ for TEST in ${SPAWN_TESTS}; do \ diff --git a/gnat/spawn.gpr b/gnat/spawn.gpr index 3a92f59..2d6f60f 100644 --- a/gnat/spawn.gpr +++ b/gnat/spawn.gpr @@ -1,5 +1,5 @@ -- --- Copyright (C) 2018-2022, AdaCore +-- Copyright (C) 2018-2023, AdaCore -- -- SPDX-License-Identifier: Apache-2.0 -- @@ -10,7 +10,8 @@ library project Spawn is OS_API : OS_API_Kind := external ("OS", "unix"); type Library_Kind is ("static", "static-pic", "relocatable"); - Library_Type : Library_Kind := external ("LIBRARY_TYPE", "static"); + Library_Type : Library_Kind := + external ("SPAWN_LIBRARY_TYPE", external ("LIBRARY_TYPE", "static")); type Spawn_Build_Kind is ("dev", "prod", "coverage", "AddressSanitizer"); Build_Mode : Spawn_Build_Kind := @@ -40,6 +41,7 @@ library project Spawn is for Excluded_Source_Files use Common_Excluded & ("pipe2.c", "spawn-windows_api.ads", + "spawn-windows_api.adb", "spawn-internal-windows.ads", "spawn-internal-windows.adb"); diff --git a/gnat/spawn_glib.gpr b/gnat/spawn_glib.gpr index e0b373b..07df237 100644 --- a/gnat/spawn_glib.gpr +++ b/gnat/spawn_glib.gpr @@ -1,5 +1,5 @@ -- --- Copyright (C) 2018-2022, AdaCore +-- Copyright (C) 2018-2023, AdaCore -- -- SPDX-License-Identifier: Apache-2.0 -- @@ -12,7 +12,8 @@ library project Spawn_Glib is OS_API : OS_API_Kind := external ("OS", "unix"); type Library_Kind is ("static", "static-pic", "relocatable"); - Library_Type : Library_Kind := external ("LIBRARY_TYPE", "static"); + Library_Type : Library_Kind := + external ("SPAWN_GLIB_LIBRARY_TYPE", external ("LIBRARY_TYPE", "static")); type Spawn_Glib_Build_Kind is ("dev", "prod", "coverage"); Build_Mode : Spawn_Glib_Build_Kind := @@ -48,6 +49,7 @@ library project Spawn_Glib is when "unix" | "osx" => for Excluded_Source_Files use Common_Excluded & ("spawn-windows_api.ads", + "spawn-windows_api.adb", "spawn-internal-windows.ads", "spawn-internal-windows.adb"); diff --git a/source/spawn/spawn-channels__glib_posix.adb b/source/spawn/spawn-channels__glib_posix.adb index 8b75ed4..d794264 100644 --- a/source/spawn/spawn-channels__glib_posix.adb +++ b/source/spawn/spawn-channels__glib_posix.adb @@ -1,5 +1,5 @@ -- --- Copyright (C) 2018-2022, AdaCore +-- Copyright (C) 2018-2023, AdaCore -- -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -- @@ -76,7 +76,28 @@ package body Spawn.Channels is with Convention => C; -- Common code to start (continue) watching of the IO channel. - procedure On_Close_Channels (Self : Channels); + procedure Channel_Error (Self : Channels); + -- Executed on IO channel failure to report postponed Finished signal. + + ------------------- + -- Channel_Error -- + ------------------- + + procedure Channel_Error (Self : Channels) is + begin + if Self.Process.Pending_Finish then + -- Check whether all IO operations are done, then emit Finished + -- callback. + + if not Is_Active (Self) then + Self.Process.Pending_Finish := False; + Self.Process.Status := Not_Running; + + Self.Process.Emit_Finished + (Self.Process.Exit_Status, Self.Process.Exit_Code); + end if; + end if; + end Channel_Error; ----------------------------- -- Close_Child_Descriptors -- @@ -113,28 +134,12 @@ package body Spawn.Channels is function Is_Active (Self : Channels) return Boolean is begin - return Self.Stdout_Event /= Glib.Main.No_Source_Id - or Self.Stderr_Event /= Glib.Main.No_Source_Id; + return + Self.Stdin_Event /= Glib.Main.No_Source_Id + or Self.Stdout_Event /= Glib.Main.No_Source_Id + or Self.Stderr_Event /= Glib.Main.No_Source_Id; end Is_Active; - ----------------------- - -- On_Close_Channels -- - ----------------------- - - procedure On_Close_Channels (Self : Channels) is - begin - if Self.Process.Pending_Finish then - Self.Process.Pending_Finish := False; - Self.Process.Status := Not_Running; - - Self.Process.Emit_Finished - (Self.Process.Exit_Status, Self.Process.Exit_Code); - end if; - exception - when others => - null; - end On_Close_Channels; - --------------------- -- On_Stderr_Event -- --------------------- @@ -149,23 +154,26 @@ package body Spawn.Channels is Self : Channels renames data.Self.Channels; begin - if (condition and Glib.IOChannel.G_Io_In) /= 0 then - Self.Stderr_Lock := @ - 1; + Self.Stderr_Lock := @ - 1; + if (condition and Glib.IOChannel.G_Io_In) /= 0 then Self.Process.Emit_Stderr_Available; - if Self.Stderr_Lock = 0 then - Self.Stderr_Event := Glib.Main.No_Source_Id; - end if; + elsif (condition and Glib.IOChannel.G_Io_Hup) /= 0 + or (condition and Glib.IOChannel.G_Io_Err) /= 0 + then + Self.Process.Emit_Standard_Error_Stream_Error + ("GIOChannel IO error"); end if; - if (condition and Glib.IOChannel.G_Io_Hup) /= 0 then - Self.Stderr_Lock := 0; + if Self.Stderr_Lock = 0 then Self.Stderr_Event := Glib.Main.No_Source_Id; + end if; - if Self.Stdout_Event = Glib.Main.No_Source_Id then - On_Close_Channels (Self); - end if; + if (condition and Glib.IOChannel.G_Io_Hup) /= 0 + or (condition and Glib.IOChannel.G_Io_Err) /= 0 + then + Channel_Error (Self); end if; return Self.Stderr_Lock; @@ -181,19 +189,32 @@ package body Spawn.Channels is data : access Internal.Process_Reference) return Glib.Gboolean is pragma Unreferenced (source); - pragma Unreferenced (condition); Self : Channels renames data.Self.Channels; begin Self.Stdin_Lock := @ - 1; - Self.Process.Emit_Stdin_Available; + if (condition and Glib.IOChannel.G_Io_Out) /= 0 then + Self.Process.Emit_Stdin_Available; + + elsif (condition and Glib.IOChannel.G_Io_Hup) /= 0 + or (condition and Glib.IOChannel.G_Io_Err) /= 0 + then + Self.Process.Emit_Standard_Error_Stream_Error + ("GIOChannel IO error"); + end if; if Self.Stdin_Lock = 0 then Self.Stdin_Event := Glib.Main.No_Source_Id; end if; + if (condition and Glib.IOChannel.G_Io_Hup) /= 0 + or (condition and Glib.IOChannel.G_Io_Err) /= 0 + then + Channel_Error (Self); + end if; + return Self.Stdin_Lock; end On_Stdin_Event; @@ -211,23 +232,26 @@ package body Spawn.Channels is Self : Channels renames data.Self.Channels; begin - if (condition and Glib.IOChannel.G_Io_In) /= 0 then - Self.Stdout_Lock := @ - 1; + Self.Stdout_Lock := @ - 1; + if (condition and Glib.IOChannel.G_Io_In) /= 0 then Self.Process.Emit_Stdout_Available; - if Self.Stdout_Lock = 0 then - Self.Stdout_Event := Glib.Main.No_Source_Id; - end if; + elsif (condition and Glib.IOChannel.G_Io_Hup) /= 0 + or (condition and Glib.IOChannel.G_Io_Err) /= 0 + then + Self.Process.Emit_Standard_Output_Stream_Error + ("GIOChannel IO error"); end if; - if (condition and Glib.IOChannel.G_Io_Hup) /= 0 then - Self.Stdout_Lock := 0; + if Self.Stdout_Lock = 0 then Self.Stdout_Event := Glib.Main.No_Source_Id; + end if; - if Self.Stderr_Event = Glib.Main.No_Source_Id then - On_Close_Channels (Self); - end if; + if (condition and Glib.IOChannel.G_Io_Hup) /= 0 + or (condition and Glib.IOChannel.G_Io_Err) /= 0 + then + Channel_Error (Self); end if; return Self.Stdout_Lock; @@ -247,9 +271,10 @@ package body Spawn.Channels is ----------------- procedure Read_Stderr - (Self : in out Channels; - Data : out Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset) + (Self : in out Channels; + Data : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset; + Success : in out Boolean) is use type Glib.Gsize; @@ -272,6 +297,7 @@ package body Spawn.Channels is Buf => Data, Bytes_Read => Count'Access, Error => Error'Access); + case Status is when Glib.IOChannel.G_Io_Status_Eof => -- Reading is completed, so no watching is required @@ -292,8 +318,7 @@ package body Spawn.Channels is Start_Stderr_Watch (Self); when Glib.IOChannel.G_Io_Status_Error => - Self.Process.Emit_Error_Occurred - (Integer (Glib.Error.Get_Code (Error))); + Success := False; end case; end Read_Stderr; @@ -302,9 +327,10 @@ package body Spawn.Channels is ----------------- procedure Read_Stdout - (Self : in out Channels; - Data : out Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset) + (Self : in out Channels; + Data : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset; + Success : in out Boolean) is use type Glib.Gsize; @@ -346,8 +372,7 @@ package body Spawn.Channels is Start_Stdout_Watch (Self); when Glib.IOChannel.G_Io_Status_Error => - Self.Process.Emit_Error_Occurred - (Integer (Glib.Error.Get_Code (Error))); + Success := False; end case; end Read_Stdout; @@ -756,7 +781,9 @@ package body Spawn.Channels is (Self.Stderr_Parent, Self.Stderr_Event, Self.Stderr_Lock, - Glib.IOChannel.G_Io_In + Glib.IOChannel.G_Io_Hup, + Glib.IOChannel.G_Io_In + + Glib.IOChannel.G_Io_Hup + + Glib.IOChannel.G_Io_Err, On_Stderr_Event'Access, Self.Process.Reference'Unchecked_Access); end if; @@ -772,7 +799,9 @@ package body Spawn.Channels is (Self.Stdin_Parent, Self.Stdin_Event, Self.Stdin_Lock, - Glib.IOChannel.G_Io_Out, + Glib.IOChannel.G_Io_Out + + Glib.IOChannel.G_Io_Hup + + Glib.IOChannel.G_Io_Err, On_Stdin_Event'Access, Self.Process.Reference'Unchecked_Access); end Start_Stdin_Watch; @@ -787,7 +816,9 @@ package body Spawn.Channels is (Self.Stdout_Parent, Self.Stdout_Event, Self.Stdout_Lock, - Glib.IOChannel.G_Io_In + Glib.IOChannel.G_Io_Hup, + Glib.IOChannel.G_Io_In + + Glib.IOChannel.G_Io_Hup + + Glib.IOChannel.G_Io_Err, On_Stdout_Event'Access, Self.Process.Reference'Unchecked_Access); end Start_Stdout_Watch; @@ -835,9 +866,10 @@ package body Spawn.Channels is ----------------- procedure Write_Stdin - (Self : in out Channels; - Data : Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset) + (Self : in out Channels; + Data : Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset; + Success : in out Boolean) is Error : aliased Glib.Error.GError; Count : aliased Glib.Gsize; @@ -871,8 +903,7 @@ package body Spawn.Channels is Start_Stdin_Watch (Self); when Glib.IOChannel.G_Io_Status_Error => - Self.Process.Emit_Error_Occurred - (Integer (Glib.Error.Get_Code (Error))); + Success := False; when others => raise Program_Error; diff --git a/source/spawn/spawn-channels__glib_posix.ads b/source/spawn/spawn-channels__glib_posix.ads index 02e3d69..d22718e 100644 --- a/source/spawn/spawn-channels__glib_posix.ads +++ b/source/spawn/spawn-channels__glib_posix.ads @@ -1,5 +1,5 @@ -- --- Copyright (C) 2018-2022, AdaCore +-- Copyright (C) 2018-2023, AdaCore -- -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -- @@ -42,19 +42,22 @@ private package Spawn.Channels is procedure Start_Watch (Self : in out Channels); procedure Write_Stdin - (Self : in out Channels; - Data : Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset); + (Self : in out Channels; + Data : Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset; + Success : in out Boolean); procedure Read_Stdout - (Self : in out Channels; - Data : out Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset); + (Self : in out Channels; + Data : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset; + Success : in out Boolean); procedure Read_Stderr - (Self : in out Channels; - Data : out Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset); + (Self : in out Channels; + Data : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset; + Success : in out Boolean); function Is_Active (Self : Channels) return Boolean; @@ -68,16 +71,25 @@ private Stdin_Child : Glib.Gint := -1; Stdin_Event : Glib.Main.G_Source_Id := Glib.Main.No_Source_Id; Stdin_Lock : Glib.Gboolean := 0; + -- Lock of the Stdin_Event field. Lock is managed as counter + -- to prevent reset of the Stdin_Event field by the nested IO + -- operation on the channel. Stdout_Parent : Glib.IOChannel.Giochannel := null; Stdout_Child : Glib.Gint := -1; Stdout_Event : Glib.Main.G_Source_Id := Glib.Main.No_Source_Id; Stdout_Lock : Glib.Gboolean := 0; + -- Lock of the Stdout_Event field. Lock is managed as counter + -- to prevent reset of the Stdout_Event field by the nested IO + -- operation on the channel. Stderr_Parent : Glib.IOChannel.Giochannel := null; Stderr_Child : Glib.Gint := -1; Stderr_Event : Glib.Main.G_Source_Id := Glib.Main.No_Source_Id; Stderr_Lock : Glib.Gboolean := 0; + -- Lock of the Stderr_Event field. Lock is managed as counter + -- to prevent reset of the Stderr_Event field by the nested IO + -- operation on the channel. PTY_Slave : Glib.Gint := -1; end record; diff --git a/source/spawn/spawn-channels__posix.adb b/source/spawn/spawn-channels__posix.adb index e3a5dad..4cca0b4 100644 --- a/source/spawn/spawn-channels__posix.adb +++ b/source/spawn/spawn-channels__posix.adb @@ -1,5 +1,5 @@ -- --- Copyright (C) 2018-2022, AdaCore +-- Copyright (C) 2018-2023, AdaCore -- -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -- @@ -255,10 +255,11 @@ package body Spawn.Channels is ---------- procedure Read - (Self : in out Channels; - Kind : Spawn.Common.Pipe_Kinds; - Data : out Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset) + (Self : in out Channels; + Kind : Spawn.Common.Pipe_Kinds; + Data : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset; + Success : in out Boolean) is use type Ada.Streams.Stream_Element_Offset; use type Interfaces.C.size_t; @@ -267,13 +268,15 @@ package body Spawn.Channels is Posix.read (Self.Parent (Kind), Data, Data'Length); Error : constant Interfaces.C.int := Errno; + begin Last := Data'First - 1; if Count /= Interfaces.C.size_t'Last then Last := Data'First + Ada.Streams.Stream_Element_Offset (Count) - 1; + elsif Error not in Posix.EAGAIN | Posix.EINTR then - Self.Process.Emit_Error_Occurred (Integer (Error)); + Success := False; end if; end Read; @@ -535,10 +538,15 @@ package body Spawn.Channels is Listener => Self'Unchecked_Access); end Start_Watch; + ----------------- + -- Write_Stdin -- + ----------------- + procedure Write_Stdin - (Self : in out Channels; - Data : Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset) + (Self : in out Channels; + Data : Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset; + Success : in out Boolean) is use type Ada.Streams.Stream_Element_Offset; use type Interfaces.C.size_t; @@ -552,8 +560,9 @@ package body Spawn.Channels is if Count /= Interfaces.C.size_t'Last then Last := Data'First + Ada.Streams.Stream_Element_Offset (Count) - 1; + elsif Error not in Posix.EAGAIN | Posix.EINTR then - Self.Process.Emit_Error_Occurred (Integer (Error)); + Success := False; end if; end Write_Stdin; end Spawn.Channels; diff --git a/source/spawn/spawn-channels__posix.ads b/source/spawn/spawn-channels__posix.ads index 5c9514e..f44b2be 100644 --- a/source/spawn/spawn-channels__posix.ads +++ b/source/spawn/spawn-channels__posix.ads @@ -1,5 +1,5 @@ -- --- Copyright (C) 2018-2022, AdaCore +-- Copyright (C) 2018-2023, AdaCore -- -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -- @@ -45,15 +45,17 @@ package Spawn.Channels is Poll : Spawn.Polls.Poll_Access); procedure Write_Stdin - (Self : in out Channels; - Data : Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset); + (Self : in out Channels; + Data : Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset; + Success : in out Boolean); procedure Read - (Self : in out Channels; - Kind : Spawn.Common.Pipe_Kinds; - Data : out Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset); + (Self : in out Channels; + Kind : Spawn.Common.Pipe_Kinds; + Data : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset; + Success : in out Boolean); function Is_Active (Self : Channels) return Boolean; diff --git a/source/spawn/spawn-common.adb b/source/spawn/spawn-common.adb index 4dd06a6..4ea9ab8 100644 --- a/source/spawn/spawn-common.adb +++ b/source/spawn/spawn-common.adb @@ -1,5 +1,5 @@ -- --- Copyright (C) 2018-2022, AdaCore +-- Copyright (C) 2018-2023, AdaCore -- -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -- @@ -84,6 +84,57 @@ package body Spawn.Common is null; end Emit_Stderr_Available; + -------------------------------------- + -- Emit_Standard_Error_Stream_Error -- + -------------------------------------- + + procedure Emit_Standard_Error_Stream_Error + (Self : Process'Class; + Message : String) is + begin + if Self.Listener /= null then + Self.Listener.Standard_Output_Stream_Error (Message); + end if; + + exception + when others => + null; + end Emit_Standard_Error_Stream_Error; + + -------------------------------------- + -- Emit_Standard_Input_Stream_Error -- + -------------------------------------- + + procedure Emit_Standard_Input_Stream_Error + (Self : Process'Class; + Message : String) is + begin + if Self.Listener /= null then + Self.Listener.Standard_Input_Stream_Error (Message); + end if; + + exception + when others => + null; + end Emit_Standard_Input_Stream_Error; + + --------------------------------------- + -- Emit_Standard_Output_Stream_Error -- + --------------------------------------- + + procedure Emit_Standard_Output_Stream_Error + (Self : Process'Class; + Message : String) is + begin + if Self.Listener /= null then + Self.Listener.Standard_Output_Stream_Error (Message); + end if; + + exception + when others => + null; + end Emit_Standard_Output_Stream_Error; + -------------------------- -- Emit_Stdin_Available -- -------------------------- diff --git a/source/spawn/spawn-common.ads b/source/spawn/spawn-common.ads index b402511..d9c045f 100644 --- a/source/spawn/spawn-common.ads +++ b/source/spawn/spawn-common.ads @@ -1,5 +1,5 @@ -- --- Copyright (C) 2018-2022, AdaCore +-- Copyright (C) 2018-2023, AdaCore -- -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -- @@ -78,9 +78,6 @@ package Spawn.Common is procedure Set_Standard_Error_PTY (Self : in out Process'Class); procedure Emit_Started (Self : Process'Class); - procedure Emit_Stdin_Available (Self : Process'Class); - procedure Emit_Stderr_Available (Self : Process'Class); - procedure Emit_Stdout_Available (Self : Process'Class); procedure Emit_Error_Occurred (Self : Process'Class; @@ -95,6 +92,22 @@ package Spawn.Common is Exit_Status : Process_Exit_Status; Exit_Code : Process_Exit_Code); + procedure Emit_Stdin_Available (Self : Process'Class); + procedure Emit_Stderr_Available (Self : Process'Class); + procedure Emit_Stdout_Available (Self : Process'Class); + + procedure Emit_Standard_Error_Stream_Error + (Self : Process'Class; + Message : String); + + procedure Emit_Standard_Input_Stream_Error + (Self : Process'Class; + Message : String); + + procedure Emit_Standard_Output_Stream_Error + (Self : Process'Class; + Message : String); + function Status (Self : Process'Class) return Process_Status is (Self.Status); diff --git a/source/spawn/spawn-internal-windows.adb b/source/spawn/spawn-internal-windows.adb index 5d1d444..4d290c7 100644 --- a/source/spawn/spawn-internal-windows.adb +++ b/source/spawn/spawn-internal-windows.adb @@ -1,5 +1,5 @@ -- --- Copyright (C) 2018-2022, AdaCore +-- Copyright (C) 2018-2023, AdaCore -- -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -- @@ -9,6 +9,7 @@ with Ada.Strings.UTF_Encoding.Wide_Strings; with Ada.Strings.Wide_Fixed; with Ada.Strings.Wide_Unbounded; with Ada.Strings.Unbounded; +with Ada.Unchecked_Conversion; with Interfaces.C.Strings; pragma Warnings (Off); @@ -175,38 +176,30 @@ package body Spawn.Internal.Windows is is use type Windows_API.HANDLE; - procedure Check_Error (Value : Windows_API.BOOL); + Dummy : Spawn.Windows_API.BOOL; - ----------------- - -- Check_Error -- - ----------------- + begin + if Self.pipe (Kind).Handle = System.Win32.INVALID_HANDLE_VALUE then + return; + end if; - procedure Check_Error (Value : Windows_API.BOOL) is - use type Windows_API.BOOL; - begin - if Value = System.Win32.FALSE then - Self.Emit_Error_Occurred (Integer (System.Win32.GetLastError)); - end if; - end Check_Error; + if Self.pipe (Kind).Waiting_IO then + Self.pipe (Kind).Close_IO := True; - Handle : Windows_API.HANDLE renames Self.pipe (Kind).Handle; - begin - if Handle /= System.Win32.INVALID_HANDLE_VALUE then - if Self.pipe (Kind).Waiting_IO then - Self.pipe (Kind).Close_IO := True; - Check_Error (Windows_API.CancelIo (Self.pipe (Kind).Handle)); - else - Check_Error (System.Win32.CloseHandle (Self.pipe (Kind).Handle)); - Self.pipe (Kind).Handle := System.Win32.INVALID_HANDLE_VALUE; + Dummy := Windows_API.CancelIo (Self.pipe (Kind).Handle); - if Self.Pending_Finish and then - (for all Pipe of Self.pipe => - Pipe.Handle = System.Win32.INVALID_HANDLE_VALUE) - then - Self.Pending_Finish := False; - Self.Status := Not_Running; - Self.Emit_Finished (Self.Exit_Status, Self.Exit_Code); - end if; + else + Dummy := System.Win32.CloseHandle (Self.pipe (Kind).Handle); + + Self.pipe (Kind).Handle := System.Win32.INVALID_HANDLE_VALUE; + + if Self.Pending_Finish and then + (for all Pipe of Self.pipe => + Pipe.Handle = System.Win32.INVALID_HANDLE_VALUE) + then + Self.Pending_Finish := False; + Self.Status := Not_Running; + Self.Emit_Finished (Self.Exit_Status, Self.Exit_Code); end if; end if; end Do_Close_Pipe; @@ -667,6 +660,60 @@ package body Spawn.Internal.Windows is end if; end Do_Write; + ------------------- + -- Error_Message -- + ------------------- + + function Error_Message + (dwErrorCode : Spawn.Windows_API.DWORD) return String + is + use type Spawn.Windows_API.DWORD; + + Len : Spawn.Windows_API.DWORD; + Buf : Spawn.Windows_API.LPWSTR; + + begin + Len := + Spawn.Windows_API.FormatMessageW + (dwFlags => + Spawn.Windows_API.FORMAT_MESSAGE_ALLOCATE_BUFFER + + Spawn.Windows_API.FORMAT_MESSAGE_FROM_SYSTEM + + Spawn.Windows_API.FORMAT_MESSAGE_IGNORE_INSERTS, + lpSource => System.Null_Address, + dwMessageId => dwErrorCode, + dwLanguageId => + Spawn.Windows_API.MAKELANGID + (Spawn.Windows_API.LANG_NEUTRAL, + Spawn.Windows_API.SUBLANG_DEFAULT), + lpBuffer => Buf, + nSize => 0, + Arguments => System.Null_Address); + + if Len = 0 then + return ""; + end if; + + declare + WB : Wide_String (1 .. Natural (Len)) with Address => Buf.all'Address; + + begin + return Result : constant String := + Ada.Strings.UTF_Encoding.Wide_Strings.Encode (WB) + do + declare + function To_Address is + new Ada.Unchecked_Conversion + (Spawn.Windows_API.LPWSTR, System.Address); + + Dummy : System.Address; + + begin + Dummy := Spawn.Windows_API.LocalFree (To_Address (Buf)); + end; + end return; + end; + end Error_Message; + ----------------- -- IO_Callback -- ----------------- @@ -691,6 +738,7 @@ package body Spawn.Internal.Windows is (if Kind = Stdin then Transfered in Last | Last - Spawn.Internal.Buffer_Size else Transfered > 0); -- Should be True + begin Self.pipe (Kind).Waiting_IO := False; @@ -718,11 +766,26 @@ package body Spawn.Internal.Windows is Self.pipe (Kind).Close_IO := False; Do_Close_Pipe (Self, Kind); end if; + elsif dwErrorCode in 0 | Windows_API.ERROR_OPERATION_ABORTED then Do_Close_Pipe (Self, Kind); + else - Self.Emit_Error_Occurred (Integer (dwErrorCode)); Do_Close_Pipe (Self, Kind); + + case Kind is + when Stdin => + Self.Emit_Standard_Input_Stream_Error + (Error_Message (dwErrorCode)); + + when Stdout => + Self.Emit_Standard_Output_Stream_Error + (Error_Message (dwErrorCode)); + + when Stderr => + Self.Emit_Standard_Error_Stream_Error + (Error_Message (dwErrorCode)); + end case; end if; end IO_Callback; @@ -731,42 +794,25 @@ package body Spawn.Internal.Windows is --------------------- procedure On_Process_Died (Self : in out Process'Class) is - + use type Windows_API.BOOL; use type Windows_API.DWORD; use type Windows_API.HANDLE; - 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.Emit_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 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)) + if Windows_API.GetExitCodeProcess (Self.pid.hProcess, Exit_Code'Access) + /= System.Win32.FALSE + and then System.Win32.CloseHandle (Self.pid.hProcess) + /= System.Win32.FALSE + and then System.Win32.CloseHandle (Self.pid.hThread) + /= System.Win32.FALSE then -- Process exit code can be application defined code, Win32 error -- code, HRESULT code (including Win32 code or NTSTATUS code diff --git a/source/spawn/spawn-internal-windows.ads b/source/spawn/spawn-internal-windows.ads index 3cff8b8..4ee926a 100644 --- a/source/spawn/spawn-internal-windows.ads +++ b/source/spawn/spawn-internal-windows.ads @@ -1,5 +1,5 @@ -- --- Copyright (C) 2018-2022, AdaCore +-- Copyright (C) 2018-2023, AdaCore -- -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -- @@ -21,6 +21,7 @@ package Spawn.Internal.Windows is procedure Do_Close_Pipe (Self : in out Process'Class; Kind : Pipe_Kinds); + -- Close pipe. Ignore errors if any. procedure Do_Write (Self : in out Process'Class; @@ -42,6 +43,10 @@ package Spawn.Internal.Windows is dwNumberOfBytesTransfered : Windows_API.DWORD; lpOverlapped : access Internal.Context; Kind : Spawn.Common.Standard_Pipe); - -- Implementation shared between Standard_[Output/Error]_Callback + -- Implementation shared between Standard_[Input/Output/Error]_Callback + + function Error_Message + (dwErrorCode : Spawn.Windows_API.DWORD) return String; + -- Return message for the current error retrived with GetLastError. end Spawn.Internal.Windows; diff --git a/source/spawn/spawn-internal__glib_posix.adb b/source/spawn/spawn-internal__glib_posix.adb index 0239561..b8b1471 100644 --- a/source/spawn/spawn-internal__glib_posix.adb +++ b/source/spawn/spawn-internal__glib_posix.adb @@ -286,11 +286,12 @@ package body Spawn.Internal is ------------------------- procedure Read_Standard_Error - (Self : in out Process'Class; - Data : out Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset) is + (Self : in out Process'Class; + Data : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset; + Success : in out Boolean) is begin - Spawn.Channels.Read_Stderr (Self.Channels, Data, Last); + Spawn.Channels.Read_Stderr (Self.Channels, Data, Last, Success); end Read_Standard_Error; -------------------------- @@ -298,11 +299,12 @@ package body Spawn.Internal is -------------------------- procedure Read_Standard_Output - (Self : in out Process'Class; - Data : out Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset) is + (Self : in out Process'Class; + Data : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset; + Success : in out Boolean) is begin - Spawn.Channels.Read_Stdout (Self.Channels, Data, Last); + Spawn.Channels.Read_Stdout (Self.Channels, Data, Last, Success); end Read_Standard_Output; ------------------------- @@ -354,11 +356,12 @@ package body Spawn.Internal is -------------------------- procedure Write_Standard_Input - (Self : in out Process'Class; - Data : Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset) is + (Self : in out Process'Class; + Data : Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset; + Success : in out Boolean) is begin - Spawn.Channels.Write_Stdin (Self.Channels, Data, Last); + Spawn.Channels.Write_Stdin (Self.Channels, Data, Last, Success); end Write_Standard_Input; end Spawn.Internal; diff --git a/source/spawn/spawn-internal__glib_posix.ads b/source/spawn/spawn-internal__glib_posix.ads index c8ddb68..eed4461 100644 --- a/source/spawn/spawn-internal__glib_posix.ads +++ b/source/spawn/spawn-internal__glib_posix.ads @@ -55,27 +55,30 @@ private package Spawn.Internal is -- See documentation in Spawn.Processes. procedure Write_Standard_Input - (Self : in out Process'Class; - Data : Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset); + (Self : in out Process'Class; + Data : Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset; + Success : in out Boolean); -- See documentation in Spawn.Processes. procedure Close_Standard_Output (Self : in out Process'Class); -- See documentation in Spawn.Processes. procedure Read_Standard_Output - (Self : in out Process'Class; - Data : out Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset); + (Self : in out Process'Class; + Data : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset; + Success : in out Boolean); -- See documentation in Spawn.Processes. procedure Close_Standard_Error (Self : in out Process'Class); -- See documentation in Spawn.Processes. procedure Read_Standard_Error - (Self : in out Process'Class; - Data : out Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset); + (Self : in out Process'Class; + Data : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset; + Success : in out Boolean); -- See documentation in Spawn.Processes. end Spawn.Internal; diff --git a/source/spawn/spawn-internal__glib_windows.adb b/source/spawn/spawn-internal__glib_windows.adb index 0fa4712..decb60b 100644 --- a/source/spawn/spawn-internal__glib_windows.adb +++ b/source/spawn/spawn-internal__glib_windows.adb @@ -6,6 +6,7 @@ with Ada.Strings.UTF_Encoding.Wide_Strings; with Ada.Wide_Characters.Unicode; +with System; with Glib.Spawn; @@ -56,11 +57,12 @@ package body Spawn.Internal is procedure Do_Start_Process (Self : aliased in out Process'Class); - procedure Do_Read - (Self : in out Process'Class; - Data : out Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset; - Kind : Spawn.Common.Standard_Pipe); + procedure Read_Standard_Stream + (Self : in out Process'Class; + Data : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset; + Kind : Spawn.Common.Standard_Pipe; + Success : in out Boolean); function Child_Watch is new Glib.Main.Generic_Child_Add_Watch (User_Data => Internal.Process_Reference); @@ -123,44 +125,6 @@ package body Spawn.Internal is Windows.Do_Close_Pipe (Self, Stdout); end Close_Standard_Output; - ------------- - -- 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 : Spawn.Common.Standard_Pipe) - is - procedure On_No_Data; - - ---------------- - -- On_No_Data -- - ---------------- - - procedure On_No_Data is - use type Windows_API.BOOL; - - Ok : Windows_API.BOOL; - Pipe : Context renames Self.pipe (Kind); - begin - Ok := Read_Write_Ex.ReadFileEx - (hFile => Pipe.Handle, - lpBuffer => Pipe.Buffer, - nNumberOfBytesToRead => Pipe.Buffer'Length, - lpOverlapped => Pipe'Access, - lpCompletionRoutine => Callback (Kind)); - - if Ok = System.Win32.FALSE then - Self.Emit_Error_Occurred (Integer (System.Win32.GetLastError)); - end if; - end On_No_Data; - - begin - Windows.Do_Read (Self, Data, Last, Kind, On_No_Data'Access); - end Do_Read; - ---------------------- -- Do_Start_Process -- ---------------------- @@ -244,11 +208,12 @@ package body Spawn.Internal is ------------------------- procedure Read_Standard_Error - (Self : in out Process'Class; - Data : out Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset) is + (Self : in out Process'Class; + Data : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset; + Success : in out Boolean) is begin - Do_Read (Self, Data, Last, Stderr); + Read_Standard_Stream (Self, Data, Last, Stderr, Success); end Read_Standard_Error; -------------------------- @@ -256,13 +221,69 @@ package body Spawn.Internal is -------------------------- procedure Read_Standard_Output - (Self : in out Process'Class; - Data : out Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset) is + (Self : in out Process'Class; + Data : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset; + Success : in out Boolean) is begin - Do_Read (Self, Data, Last, Stdout); + Read_Standard_Stream (Self, Data, Last, Stdout, Success); end Read_Standard_Output; + -------------------------- + -- Read_Standard_Stream -- + -------------------------- + + procedure Read_Standard_Stream + (Self : in out Process'Class; + Data : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset; + Kind : Spawn.Common.Standard_Pipe; + Success : in out Boolean) + is + procedure On_No_Data; + + ---------------- + -- On_No_Data -- + ---------------- + + procedure On_No_Data is + use type Windows_API.BOOL; + + Ok : Windows_API.BOOL; + Pipe : Context renames Self.pipe (Kind); + begin + Ok := Read_Write_Ex.ReadFileEx + (hFile => Pipe.Handle, + lpBuffer => Pipe.Buffer, + nNumberOfBytesToRead => Pipe.Buffer'Length, + lpOverlapped => Pipe'Access, + lpCompletionRoutine => Callback (Kind)); + + if Ok = System.Win32.FALSE then + case Kind is + when Stderr => + Self.Emit_Standard_Error_Stream_Error + (Spawn.Internal.Windows.Error_Message + (System.Win32.GetLastError)); + + when Stdout => + Self.Emit_Standard_Output_Stream_Error + (Spawn.Internal.Windows.Error_Message + (System.Win32.GetLastError)); + + when others => + null; + end case; + + else + Success := False; + end if; + end On_No_Data; + + begin + Windows.Do_Read (Self, Data, Last, Kind, On_No_Data'Access); + end Read_Standard_Stream; + ----------------------------- -- Standard_Error_Callback -- ----------------------------- @@ -327,9 +348,10 @@ package body Spawn.Internal is -------------------------- procedure Write_Standard_Input - (Self : in out Process'Class; - Data : Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset) + (Self : in out Process'Class; + Data : Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset; + Success : in out Boolean) is procedure On_Has_Data; @@ -339,6 +361,7 @@ package body Spawn.Internal is procedure On_Has_Data is use type Windows_API.BOOL; + use type Windows_API.DWORD; Ok : Windows_API.BOOL; Pipe : Context renames Self.pipe (Stdin); @@ -358,8 +381,11 @@ package body Spawn.Internal is lpOverlapped => Pipe'Access, lpCompletionRoutine => Standard_Input_Callback'Access); - if Ok = System.Win32.FALSE then - Self.Emit_Error_Occurred (Integer (System.Win32.GetLastError)); + if Ok = System.Win32.FALSE + or else System.Win32.GetLastError + /= Spawn.Windows_API.ERROR_SUCCESS + then + Success := False; end if; end On_Has_Data; diff --git a/source/spawn/spawn-internal__glib_windows.ads b/source/spawn/spawn-internal__glib_windows.ads index 20ad786..fe982c5 100644 --- a/source/spawn/spawn-internal__glib_windows.ads +++ b/source/spawn/spawn-internal__glib_windows.ads @@ -83,27 +83,30 @@ private package Spawn.Internal is -- See documentation in Spawn.Processes. procedure Write_Standard_Input - (Self : in out Process'Class; - Data : Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset); + (Self : in out Process'Class; + Data : Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset; + Success : in out Boolean); -- See documentation in Spawn.Processes. procedure Close_Standard_Output (Self : in out Process'Class); -- See documentation in Spawn.Processes. procedure Read_Standard_Output - (Self : in out Process'Class; - Data : out Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset); + (Self : in out Process'Class; + Data : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset; + Success : in out Boolean); -- See documentation in Spawn.Processes. procedure Close_Standard_Error (Self : in out Process'Class); -- See documentation in Spawn.Processes. procedure Read_Standard_Error - (Self : in out Process'Class; - Data : out Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset); + (Self : in out Process'Class; + Data : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset; + Success : in out Boolean); -- See documentation in Spawn.Processes. end Spawn.Internal; diff --git a/source/spawn/spawn-internal__posix.adb b/source/spawn/spawn-internal__posix.adb index 22dad6b..5983496 100644 --- a/source/spawn/spawn-internal__posix.adb +++ b/source/spawn/spawn-internal__posix.adb @@ -111,9 +111,10 @@ package body Spawn.Internal is ------------------------- procedure Read_Standard_Error - (Self : in out Process'Class; - Data : out Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset) + (Self : in out Process'Class; + Data : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset; + Success : in out Boolean) is use type Ada.Streams.Stream_Element_Offset; @@ -123,9 +124,9 @@ package body Spawn.Internal is return; end if; - Spawn.Channels.Read (Self.Channels, Stderr, Data, Last); + Spawn.Channels.Read (Self.Channels, Stderr, Data, Last, Success); - if Last = Data'First - 1 then + if Success and Last = Data'First - 1 then Monitor.Enqueue ((Monitor.Watch_Pipe, Self'Unchecked_Access, Stderr)); end if; @@ -136,9 +137,10 @@ package body Spawn.Internal is -------------------------- procedure Read_Standard_Output - (Self : in out Process'Class; - Data : out Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset) + (Self : in out Process'Class; + Data : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset; + Success : in out Boolean) is use type Ada.Streams.Stream_Element_Offset; @@ -148,9 +150,9 @@ package body Spawn.Internal is return; end if; - Spawn.Channels.Read (Self.Channels, Stdout, Data, Last); + Spawn.Channels.Read (Self.Channels, Stdout, Data, Last, Success); - if Last = Data'First - 1 then + if Success and Last = Data'First - 1 then Monitor.Enqueue ((Monitor.Watch_Pipe, Self'Unchecked_Access, Stdout)); end if; @@ -186,9 +188,10 @@ package body Spawn.Internal is -------------------------- procedure Write_Standard_Input - (Self : in out Process'Class; - Data : Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset) + (Self : in out Process'Class; + Data : Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset; + Success : in out Boolean) is use type Ada.Streams.Stream_Element_Offset; @@ -198,9 +201,9 @@ package body Spawn.Internal is return; end if; - Spawn.Channels.Write_Stdin (Self.Channels, Data, Last); + Spawn.Channels.Write_Stdin (Self.Channels, Data, Last, Success); - if Last /= Data'Length then + if Success and Last /= Data'Length then Monitor.Enqueue ((Monitor.Watch_Pipe, Self'Unchecked_Access, Stdin)); end if; end Write_Standard_Input; diff --git a/source/spawn/spawn-internal__posix.ads b/source/spawn/spawn-internal__posix.ads index 32a590d..dcbaa8d 100644 --- a/source/spawn/spawn-internal__posix.ads +++ b/source/spawn/spawn-internal__posix.ads @@ -49,27 +49,30 @@ private package Spawn.Internal is -- See documentation in Spawn.Processes. procedure Write_Standard_Input - (Self : in out Process'Class; - Data : Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset); + (Self : in out Process'Class; + Data : Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset; + Success : in out Boolean); -- See documentation in Spawn.Processes. procedure Close_Standard_Output (Self : in out Process'Class); -- See documentation in Spawn.Processes. procedure Read_Standard_Output - (Self : in out Process'Class; - Data : out Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset); + (Self : in out Process'Class; + Data : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset; + Success : in out Boolean); -- See documentation in Spawn.Processes. procedure Close_Standard_Error (Self : in out Process'Class); -- See documentation in Spawn.Processes. procedure Read_Standard_Error - (Self : in out Process'Class; - Data : out Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset); + (Self : in out Process'Class; + Data : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset; + Success : in out Boolean); -- See documentation in Spawn.Processes. private diff --git a/source/spawn/spawn-internal__windows.adb b/source/spawn/spawn-internal__windows.adb index 8486d60..7f5b735 100644 --- a/source/spawn/spawn-internal__windows.adb +++ b/source/spawn/spawn-internal__windows.adb @@ -123,16 +123,25 @@ package body Spawn.Internal is ------------------------- procedure Read_Standard_Error - (Self : in out Process'Class; - Data : out Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset) + (Self : in out Process'Class; + Data : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset; + Success : in out Boolean) is + pragma Unreferenced (Success); + -- There are no synchronous IO errors in this implementation + procedure On_No_Data; + ---------------- + -- On_No_Data -- + ---------------- + procedure On_No_Data is begin Monitor.Enqueue ((Monitor.Watch_Pipe, Self'Unchecked_Access, Stderr)); end On_No_Data; + begin if Self.Status /= Running then Last := Data'First - 1; @@ -147,16 +156,25 @@ package body Spawn.Internal is -------------------------- procedure Read_Standard_Output - (Self : in out Process'Class; - Data : out Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset) + (Self : in out Process'Class; + Data : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset; + Success : in out Boolean) is + pragma Unreferenced (Success); + -- There are no synchronous IO errors in this implementation + procedure On_No_Data; + ---------------- + -- On_No_Data -- + ---------------- + procedure On_No_Data is begin Monitor.Enqueue ((Monitor.Watch_Pipe, Self'Unchecked_Access, Stdout)); end On_No_Data; + begin if Self.Status /= Running then Last := Data'First - 1; @@ -191,10 +209,14 @@ package body Spawn.Internal is -------------------------- procedure Write_Standard_Input - (Self : in out Process'Class; - Data : Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset) + (Self : in out Process'Class; + Data : Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset; + Success : in out Boolean) is + pragma Unreferenced (Success); + -- There are no synchronous IO errors in this implementation + procedure On_Has_Data; ----------------- diff --git a/source/spawn/spawn-internal__windows.ads b/source/spawn/spawn-internal__windows.ads index 8ad9411..fbaa347 100644 --- a/source/spawn/spawn-internal__windows.ads +++ b/source/spawn/spawn-internal__windows.ads @@ -85,27 +85,30 @@ private package Spawn.Internal is -- See documentation in Spawn.Processes. procedure Write_Standard_Input - (Self : in out Process'Class; - Data : Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset); + (Self : in out Process'Class; + Data : Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset; + Success : in out Boolean); -- See documentation in Spawn.Processes. procedure Close_Standard_Output (Self : in out Process'Class); -- See documentation in Spawn.Processes. procedure Read_Standard_Output - (Self : in out Process'Class; - Data : out Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset); + (Self : in out Process'Class; + Data : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset; + Success : in out Boolean); -- See documentation in Spawn.Processes. procedure Close_Standard_Error (Self : in out Process'Class); -- See documentation in Spawn.Processes. procedure Read_Standard_Error - (Self : in out Process'Class; - Data : out Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset); + (Self : in out Process'Class; + Data : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset; + Success : in out Boolean); -- See documentation in Spawn.Processes. end Spawn.Internal; diff --git a/source/spawn/spawn-process_listeners.ads b/source/spawn/spawn-process_listeners.ads index 3f1f70d..9579824 100644 --- a/source/spawn/spawn-process_listeners.ads +++ b/source/spawn/spawn-process_listeners.ads @@ -48,4 +48,22 @@ package Spawn.Process_Listeners is -- This will be called when an exception occurred in one of the -- callbacks set in place + procedure Standard_Output_Stream_Error + (Self : in out Process_Listener; + Message : String) is null; + -- Called on error condition of operation on standard output stream. It + -- reports asynchronous errors only. + + procedure Standard_Error_Stream_Error + (Self : in out Process_Listener; + Message : String) is null; + -- Called on error condition of operation on standard error stream. It + -- reports asynchronous errors only. + + procedure Standard_Input_Stream_Error + (Self : in out Process_Listener; + Message : String) is null; + -- Called on error of operation on standard input stream. It reports + -- asynchronous errors only. + end Spawn.Process_Listeners; diff --git a/source/spawn/spawn-processes.adb b/source/spawn/spawn-processes.adb index 5d15bbf..e3f378c 100644 --- a/source/spawn/spawn-processes.adb +++ b/source/spawn/spawn-processes.adb @@ -1,11 +1,13 @@ -- --- Copyright (C) 2018-2022, AdaCore +-- Copyright (C) 2018-2023, AdaCore -- -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -- package body Spawn.Processes is + use type Ada.Streams.Stream_Element_Offset; + -------------------------- -- Close_Standard_Error -- -------------------------- @@ -39,7 +41,9 @@ package body Spawn.Processes is procedure Kill_Process (Self : in out Process'Class) is begin - Self.Interal.Kill_Process; + if Self.Status = Running then + Self.Interal.Kill_Process; + end if; end Kill_Process; ------------------------- @@ -47,11 +51,18 @@ package body Spawn.Processes is ------------------------- procedure Read_Standard_Error - (Self : in out Process'Class; - Data : out Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset) is + (Self : in out Process'Class; + Data : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset; + Success : in out Boolean) is begin - Self.Interal.Read_Standard_Error (Data, Last); + if not Success then + Last := Data'First - 1; + + return; + end if; + + Self.Interal.Read_Standard_Error (Data, Last, Success); end Read_Standard_Error; -------------------------- @@ -59,11 +70,18 @@ package body Spawn.Processes is -------------------------- procedure Read_Standard_Output - (Self : in out Process'Class; - Data : out Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset) is + (Self : in out Process'Class; + Data : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset; + Success : in out Boolean) is begin - Self.Interal.Read_Standard_Output (Data, Last); + if not Success then + Last := Data'First - 1; + + return; + end if; + + Self.Interal.Read_Standard_Output (Data, Last, Success); end Read_Standard_Output; ------------------- @@ -170,11 +188,18 @@ package body Spawn.Processes is -------------------------- procedure Write_Standard_Input - (Self : in out Process'Class; - Data : Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset) is + (Self : in out Process'Class; + Data : Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset; + Success : in out Boolean) is begin - Self.Interal.Write_Standard_Input (Data, Last); + if not Success then + Last := Data'First - 1; + + return; + end if; + + Self.Interal.Write_Standard_Input (Data, Last, Success); end Write_Standard_Input; end Spawn.Processes; diff --git a/source/spawn/spawn-processes.ads b/source/spawn/spawn-processes.ads index 843af09..10543d4 100644 --- a/source/spawn/spawn-processes.ads +++ b/source/spawn/spawn-processes.ads @@ -141,14 +141,18 @@ package Spawn.Processes is -- Do nothing if Self.Status /= Running procedure Write_Standard_Input - (Self : in out Process'Class; - Data : Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset); - -- Do nothing if Self.Status /= Running. Last is set to index of the last - -- element to be written. If Last < Data'Last it means incomplete + (Self : in out Process'Class; + Data : Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset; + Success : in out Boolean); + -- Do nothing if Self.Status /= Running. Last is set to index of the + -- last element to be written. If Last < Data'Last it means incomplete -- operation, Standard_Input_Available notification will be called once -- operation can be continued. Application is responsible to call this - -- subprogram again for remaining data. + -- subprogram again for remaining data. Sets Success to False when some + -- non-recoverable error appears during execution of the subprogram. + -- Errors that appear asynchronously are reported by call of + -- Standard_Input_Stream_Error subprogram of the listener. procedure Close_Standard_Output (Self : in out Process'Class); -- Close standard output stream to the child process. Application can't @@ -160,12 +164,16 @@ package Spawn.Processes is -- Do nothing if Self.Status /= Running procedure Read_Standard_Output - (Self : in out Process'Class; - Data : out Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset); - -- Returns available data received through standard output stream. If no - -- data was read, the Standard_Output_Available notification will be - -- emitted later. + (Self : in out Process'Class; + Data : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset; + Success : in out Boolean); + -- Returns available data received through standard output stream. If + -- no data was read, the Standard_Output_Available notification will + -- be emitted later. Sets Success to False when some non-recoverable + -- error appears during execution of the subprogram. Errors that appear + -- asynchronously are reported by call of Standard_Output_Stream_Error + -- subprogram of the listener. procedure Close_Standard_Error (Self : in out Process'Class); -- Do nothing if Self.Status /= Running @@ -176,12 +184,16 @@ package Spawn.Processes is -- Do nothing if Self.Status /= Running procedure Read_Standard_Error - (Self : in out Process'Class; - Data : out Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset); - -- Returns available data received through standard error stream. If no - -- data was read, the Standard_Error_Available notification will be - -- emitted later. + (Self : in out Process'Class; + Data : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset; + Success : in out Boolean); + -- Returns available data received through standard error stream. If + -- no data was read, the Standard_Error_Available notification will + -- be emitted later. Sets Success to False when some non-recoverable + -- error appears during execution of the subprogram. Errors that appear + -- asynchronously are reported by call of Standard_Error_Stream_Error + -- subprogram of the listener. -- For compatibility with older API: subtype Process_Listener is Spawn.Process_Listeners.Process_Listener; diff --git a/source/spawn/spawn-windows_api.adb b/source/spawn/spawn-windows_api.adb new file mode 100755 index 0000000..c5b81ac --- /dev/null +++ b/source/spawn/spawn-windows_api.adb @@ -0,0 +1,21 @@ +-- +-- Copyright (C) 2023, AdaCore +-- +-- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +-- + +package body Spawn.Windows_API is + + ---------------- + -- MAKELANGID -- + ---------------- + + function MAKELANGID (P : DWORD; S : DWORD) return DWORD is + use type System.Win32.DWORD; + + begin + return + DWORD (Interfaces.Shift_Left (Interfaces.Unsigned_32 (S), 10)) or P; + end MAKELANGID; + +end Spawn.Windows_API; diff --git a/source/spawn/spawn-windows_api.ads b/source/spawn/spawn-windows_api.ads index 9e4cd90..f211e10 100644 --- a/source/spawn/spawn-windows_api.ads +++ b/source/spawn/spawn-windows_api.ads @@ -235,6 +235,7 @@ package Spawn.Windows_API is with Import, Convention => Stdcall, External_Name => "_get_osfhandle"; + ERROR_SUCCESS : constant DWORD := 0; ERROR_PIPE_BUSY : constant DWORD := 231; ERROR_PIPE_CONNECTED : constant DWORD := 535; ERROR_OPERATION_ABORTED : constant DWORD := 995; @@ -293,4 +294,26 @@ package Spawn.Windows_API is lParam : Windows_API.LPARAM) return BOOL with Import, Convention => Stdcall, External_Name => "PostThreadMessageW"; + function FormatMessageW + (dwFlags : DWORD; + lpSource : System.Address; + dwMessageId : DWORD; + dwLanguageId : DWORD; + lpBuffer : out LPWSTR; + nSize : DWORD; + Arguments : System.Address) return DWORD + with Import, Convention => Stdcall, External_Name => "FormatMessageW"; + + FORMAT_MESSAGE_ALLOCATE_BUFFER : constant DWORD := 16#100#; + FORMAT_MESSAGE_FROM_SYSTEM : constant DWORD := 16#10000#; + FORMAT_MESSAGE_IGNORE_INSERTS : constant DWORD := 16#200#; + + function MAKELANGID (P : DWORD; S : DWORD) return DWORD; + + LANG_NEUTRAL : constant := 16#0#; + SUBLANG_DEFAULT : constant := 16#1#; + + function LocalFree (hMem : System.Address) return System.Address + with Import, Convention => Stdcall, External_Name => "LocalAlloc"; + end Spawn.Windows_API; diff --git a/testsuite/spawn/spawn_kill.adb b/testsuite/spawn/spawn_kill.adb index 95b372d..7955d20 100644 --- a/testsuite/spawn/spawn_kill.adb +++ b/testsuite/spawn/spawn_kill.adb @@ -1,3 +1,9 @@ +-- +-- Copyright (C) 2021-2023, AdaCore +-- +-- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception +-- + with Ada.Command_Line; with Ada.Directories; with Ada.Streams; @@ -52,10 +58,13 @@ procedure Spawn_Kill is begin loop declare - Data : Ada.Streams.Stream_Element_Array (1 .. 5); - Last : Ada.Streams.Stream_Element_Count; + Data : Ada.Streams.Stream_Element_Array (1 .. 5); + Last : Ada.Streams.Stream_Element_Count; + Success : Boolean := True; + begin - Self.Proc.Read_Standard_Output (Data, Last); + Self.Proc.Read_Standard_Output (Data, Last, Success); + pragma Assert (Success); exit when Last < Data'First; @@ -76,10 +85,12 @@ procedure Spawn_Kill is begin loop declare - Data : Ada.Streams.Stream_Element_Array (1 .. 5); - Last : Ada.Streams.Stream_Element_Count; + Data : Ada.Streams.Stream_Element_Array (1 .. 5); + Last : Ada.Streams.Stream_Element_Count; + Success : Boolean := True; + begin - Self.Proc.Read_Standard_Error (Data, Last); + Self.Proc.Read_Standard_Error (Data, Last, Success); exit when Last < Data'First; diff --git a/testsuite/spawn/spawn_stty.adb b/testsuite/spawn/spawn_stty.adb index c229dd7..0b117b5 100644 --- a/testsuite/spawn/spawn_stty.adb +++ b/testsuite/spawn/spawn_stty.adb @@ -1,5 +1,5 @@ -- --- Copyright (C) 2018-2021, AdaCore +-- Copyright (C) 2018-2023, AdaCore -- -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -- @@ -58,10 +58,12 @@ procedure Spawn_STTY is begin loop declare - Data : Ada.Streams.Stream_Element_Array (1 .. 5); - Last : Ada.Streams.Stream_Element_Count; + Data : Ada.Streams.Stream_Element_Array (1 .. 5); + Last : Ada.Streams.Stream_Element_Count; + Success : Boolean := True; + begin - Self.Process.Read_Standard_Output (Data, Last); + Self.Process.Read_Standard_Output (Data, Last, Success); exit when Last < Data'First; @@ -82,10 +84,12 @@ procedure Spawn_STTY is begin loop declare - Data : Ada.Streams.Stream_Element_Array (1 .. 5); - Last : Ada.Streams.Stream_Element_Count; + Data : Ada.Streams.Stream_Element_Array (1 .. 5); + Last : Ada.Streams.Stream_Element_Count; + Success : Boolean := True; + begin - Self.Process.Read_Standard_Error (Data, Last); + Self.Process.Read_Standard_Error (Data, Last, Success); exit when Last < Data'First; diff --git a/testsuite/spawn/spawn_test.adb b/testsuite/spawn/spawn_test.adb index 3da7605..33bedb5 100644 --- a/testsuite/spawn/spawn_test.adb +++ b/testsuite/spawn/spawn_test.adb @@ -1,5 +1,5 @@ -- --- Copyright (C) 2018-2021, AdaCore +-- Copyright (C) 2018-2023, AdaCore -- -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -- @@ -71,10 +71,12 @@ procedure Spawn_Test is begin loop declare - Data : Ada.Streams.Stream_Element_Array (1 .. 5); - Last : Ada.Streams.Stream_Element_Count; + Data : Ada.Streams.Stream_Element_Array (1 .. 5); + Last : Ada.Streams.Stream_Element_Count; + Success : Boolean := True; + begin - P.Read_Standard_Output (Data, Last); + P.Read_Standard_Output (Data, Last, Success); exit when Last < Data'First; @@ -95,10 +97,12 @@ procedure Spawn_Test is begin loop declare - Data : Ada.Streams.Stream_Element_Array (1 .. 5); - Last : Ada.Streams.Stream_Element_Count; + Data : Ada.Streams.Stream_Element_Array (1 .. 5); + Last : Ada.Streams.Stream_Element_Count; + Success : Boolean := True; + begin - P.Read_Standard_Error (Data, Last); + P.Read_Standard_Error (Data, Last, Success); exit when Last < Data'First; @@ -119,16 +123,18 @@ procedure Spawn_Test is is use type Ada.Streams.Stream_Element_Count; - Text : constant String := + Text : constant String := Ada.Strings.Unbounded.To_String (Self.Stdin); - Last : Ada.Streams.Stream_Element_Count := Text'Length; - Data : Ada.Streams.Stream_Element_Array (1 .. Last); + Last : Ada.Streams.Stream_Element_Count := Text'Length; + Data : Ada.Streams.Stream_Element_Array (1 .. Last); + Success : Boolean := True; + begin for J in Data'Range loop Data (J) := Character'Pos (Text (Positive (J))); end loop; - P.Write_Standard_Input (Data, Last); + P.Write_Standard_Input (Data, Last, Success); pragma Assert (Last = Data'Last); Self.Stdin := Ada.Strings.Unbounded.Null_Unbounded_String; diff --git a/testsuite/spawn/spawn_unexpected.adb b/testsuite/spawn/spawn_unexpected.adb index cca73e4..db3aedc 100644 --- a/testsuite/spawn/spawn_unexpected.adb +++ b/testsuite/spawn/spawn_unexpected.adb @@ -1,5 +1,5 @@ -- --- Copyright (C) 2018-2021, AdaCore +-- Copyright (C) 2018-2023, AdaCore -- -- SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception -- @@ -97,11 +97,13 @@ procedure Spawn_Unexpected is is use type Ada.Streams.Stream_Element_Offset; - Chunk : constant Ada.Streams.Stream_Element_Array := + Chunk : constant Ada.Streams.Stream_Element_Array := (1 .. 10 => Character'Pos (Sample)); - Last : Ada.Streams.Stream_Element_Offset; + Last : Ada.Streams.Stream_Element_Offset; + Success : Boolean := True; + begin - Process.Write_Standard_Input (Chunk, Last); + Process.Write_Standard_Input (Chunk, Last, Success); pragma Assert (Last < Chunk'First); end Write_Standard_Input;