diff --git a/gnat/spawn.gpr b/gnat/spawn.gpr index 549eb14..fc45f3e 100644 --- a/gnat/spawn.gpr +++ b/gnat/spawn.gpr @@ -39,8 +39,8 @@ library project Spawn is for Excluded_Source_Files use Common_Excluded & ("pipe2.c", "spawn-windows_api.ads", - "spawn-processes-windows.ads", - "spawn-processes-windows.adb"); + "spawn-internal-windows.ads", + "spawn-internal-windows.adb"); when "Windows_NT" => for Excluded_Source_Files use Common_Excluded & @@ -50,8 +50,8 @@ library project Spawn is when "osx" => for Excluded_Source_Files use Common_Excluded & ("spawn-windows_api.ads", - "spawn-processes-windows.ads", - "spawn-processes-windows.adb"); + "spawn-internal-windows.ads", + "spawn-internal-windows.adb"); end case; Ada_Switches := (); @@ -131,14 +131,12 @@ library project Spawn is use "spawn-environments-internal__posix.ads"; for Body ("Spawn.Environments.Internal") use "spawn-environments-internal__posix.adb"; - for Body ("Spawn.Processes.Platform") - use "spawn-processes-platform__posix.adb"; for Body ("Spawn.Environments.Search_In_Path") use "spawn-environments-search_in_path__posix.adb"; - for Body ("Spawn.Processes.Monitor") - use "spawn-processes-monitor__posix.adb"; - for Body ("Spawn.Processes.Monitor.Initialize") - use "spawn-processes-monitor-" & OS_API & "_initialize.adb"; + for Body ("Spawn.Internal.Monitor") + use "spawn-internal-monitor__posix.adb"; + for Body ("Spawn.Internal.Monitor.Initialize") + use "spawn-internal-monitor-" & OS_API & "_initialize.adb"; when "Windows_NT" => for Spec ("Spawn.Internal") use "spawn-internal__windows.ads"; @@ -150,12 +148,10 @@ library project Spawn is use "spawn-environments-internal__windows.ads"; for Body ("Spawn.Environments.Internal") use "spawn-environments-internal__windows.adb"; - for Body ("Spawn.Processes.Platform") - use "spawn-processes-platform__windows.adb"; for Body ("Spawn.Environments.Search_In_Path") use "spawn-environments-search_in_path__windows.adb"; - for Body ("Spawn.Processes.Monitor") - use "spawn-processes-monitor__windows.adb"; + for Body ("Spawn.Internal.Monitor") + use "spawn-internal-monitor__windows.adb"; end case; end Naming; diff --git a/gnat/spawn_glib.gpr b/gnat/spawn_glib.gpr index f928fc9..49b037c 100644 --- a/gnat/spawn_glib.gpr +++ b/gnat/spawn_glib.gpr @@ -40,7 +40,7 @@ library project Spawn_Glib is end case; Common_Excluded := - ("spawn-processes-monitor.ads", + ("spawn-internal-monitor.ads", "spawn-processes-monitor_loop.ads", "spawn-processes-monitor_loop.adb"); @@ -48,8 +48,8 @@ library project Spawn_Glib is when "unix" | "osx" => for Excluded_Source_Files use Common_Excluded & ("spawn-windows_api.ads", - "spawn-processes-windows.ads", - "spawn-processes-windows.adb"); + "spawn-internal-windows.ads", + "spawn-internal-windows.adb"); when "Windows_NT" => for Excluded_Source_Files use Common_Excluded & @@ -118,9 +118,9 @@ library project Spawn_Glib is case OS_API is when "unix" | "osx" => for Spec ("Spawn.Internal") - use "spawn-internal__glib.ads"; + use "spawn-internal__glib_posix.ads"; for Body ("Spawn.Internal") - use "spawn-internal__posix.adb"; + use "spawn-internal__glib_posix.adb"; for Body ("Spawn.Environments.Initialize_Default") use "spawn-environments-initialize_default__glib.adb"; for Spec ("Spawn.Environments.Internal") @@ -129,13 +129,11 @@ library project Spawn_Glib is use "spawn-environments-internal__glib.adb"; for Body ("Spawn.Environments.Search_In_Path") use "spawn-environments-search_in_path__posix.adb"; - for Body ("Spawn.Processes.Platform") - use "spawn-processes-platform__glib.adb"; when "Windows_NT" => for Spec ("Spawn.Internal") use "spawn-internal__glib_windows.ads"; for Body ("Spawn.Internal") - use "spawn-internal__windows.adb"; + use "spawn-internal__glib_windows.adb"; for Body ("Spawn.Environments.Initialize_Default") use "spawn-environments-initialize_default__windows.adb"; for Spec ("Spawn.Environments.Internal") @@ -144,8 +142,6 @@ library project Spawn_Glib is use "spawn-environments-internal__windows.adb"; for Body ("Spawn.Environments.Search_In_Path") use "spawn-environments-search_in_path__windows.adb"; - for Body ("Spawn.Processes.Platform") - use "spawn-processes-platform__glib_windows.adb"; end case; end Naming; diff --git a/packages/glib/alire.toml b/packages/glib/alire.toml index 9f9f598..b16ab46 100644 --- a/packages/glib/alire.toml +++ b/packages/glib/alire.toml @@ -14,7 +14,7 @@ tags = ["process", "launch", "pipe", "glib"] disabled = true [[depends-on]] -gtkada = "^19" # GtkAda 2019 and latter +gtkada = "^23" # GtkAda 23 and latter [gpr-externals] OS = ["unix", "osx", "Windows_NT"] diff --git a/source/spawn/spawn-channels.adb b/source/spawn/spawn-channels.adb index 8394a6a..10cee6b 100644 --- a/source/spawn/spawn-channels.adb +++ b/source/spawn/spawn-channels.adb @@ -77,6 +77,15 @@ package body Spawn.Channels is with Convention => C; -- Common code to start (continue) watching of the IO channel. + procedure Emit_Error_Occurred + (Self : Channels; + Process_Error : Integer); + + procedure Emit_Stderr_Available (Self : Channels); + procedure Emit_Stdin_Available (Self : Channels); + procedure Emit_Stdout_Available (Self : Channels); + procedure On_Close_Channels (Self : Channels); + ------------------ -- Child_Stderr -- ------------------ @@ -139,6 +148,56 @@ package body Spawn.Channels is end if; end Close_Child_Descriptors; + ------------------------- + -- Emit_Error_Occurred -- + ------------------------- + + procedure Emit_Error_Occurred + (Self : Channels; + Process_Error : Integer) is + begin + Self.Process.Listener.Error_Occurred (Process_Error); + exception + when others => + null; + end Emit_Error_Occurred; + + --------------------------- + -- Emit_Stderr_Available -- + --------------------------- + + procedure Emit_Stderr_Available (Self : Channels) is + begin + Self.Process.Listener.Standard_Error_Available; + exception + when others => + null; + end Emit_Stderr_Available; + + -------------------------- + -- Emit_Stdin_Available -- + -------------------------- + + procedure Emit_Stdin_Available (Self : Channels) is + begin + Self.Process.Listener.Standard_Input_Available; + exception + when others => + null; + end Emit_Stdin_Available; + + --------------------------- + -- Emit_Stdout_Available -- + --------------------------- + + procedure Emit_Stdout_Available (Self : Channels) is + begin + Self.Process.Listener.Standard_Output_Available; + exception + when others => + null; + end Emit_Stdout_Available; + --------------- -- Is_Active -- --------------- @@ -149,6 +208,23 @@ package body Spawn.Channels is 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.Listener.Finished + (Self.Process.Exit_Status, Self.Process.Exit_Code); + end if; + exception + when others => + null; + end On_Close_Channels; + --------------------- -- On_Stderr_Event -- --------------------- @@ -166,7 +242,7 @@ package body Spawn.Channels is if (condition and Glib.IOChannel.G_Io_In) /= 0 then Self.Stderr_Lock := @ - 1; - Self.Process.Emit_Stderr_Available; + Emit_Stderr_Available (Self); if Self.Stderr_Lock = 0 then Self.Stderr_Event := Glib.Main.No_Source_Id; @@ -178,7 +254,7 @@ package body Spawn.Channels is Self.Stderr_Event := Glib.Main.No_Source_Id; if Self.Stdout_Event = Glib.Main.No_Source_Id then - Self.Process.On_Close_Channels; + On_Close_Channels (Self); end if; end if; @@ -202,7 +278,7 @@ package body Spawn.Channels is begin Self.Stdin_Lock := @ - 1; - Self.Process.Emit_Stdin_Available; + Emit_Stdin_Available (Self); if Self.Stdin_Lock = 0 then Self.Stdin_Event := Glib.Main.No_Source_Id; @@ -228,7 +304,7 @@ package body Spawn.Channels is if (condition and Glib.IOChannel.G_Io_In) /= 0 then Self.Stdout_Lock := @ - 1; - Self.Process.Emit_Stdout_Available; + Emit_Stdout_Available (Self); if Self.Stdout_Lock = 0 then Self.Stdout_Event := Glib.Main.No_Source_Id; @@ -240,7 +316,7 @@ package body Spawn.Channels is Self.Stdout_Event := Glib.Main.No_Source_Id; if Self.Stderr_Event = Glib.Main.No_Source_Id then - Self.Process.On_Close_Channels; + On_Close_Channels (Self); end if; end if; @@ -306,8 +382,8 @@ 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))); + Emit_Error_Occurred (Self, + Integer (Glib.Error.Get_Code (Error))); end case; end Read_Stderr; @@ -360,8 +436,8 @@ 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))); + Emit_Error_Occurred (Self, + Integer (Glib.Error.Get_Code (Error))); end case; end Read_Stdout; @@ -433,8 +509,8 @@ package body Spawn.Channels is -- Create pipe if Spawn.Posix.pipe2 (Fds, Posix.O_CLOEXEC) /= 0 then - Self.Process.Emit_Error_Occurred - (Integer (System.OS_Interface.errno)); + Emit_Error_Occurred (Self, + Integer (System.OS_Interface.errno)); Success := False; return; @@ -457,8 +533,8 @@ package body Spawn.Channels is Glib.IOChannel.G_Io_Flag_Nonblock, Error'Access) /= Glib.IOChannel.G_Io_Status_Normal then - Self.Process.Emit_Error_Occurred - (Integer (Glib.Error.Get_Code (Error))); + Emit_Error_Occurred (Self, + Integer (Glib.Error.Get_Code (Error))); Cleanup; Success := False; @@ -470,8 +546,8 @@ package body Spawn.Channels is if Glib.IOChannel.Set_Encoding (Read, "", Error'Access) /= Glib.IOChannel.G_Io_Status_Normal then - Self.Process.Emit_Error_Occurred - (Integer (Glib.Error.Get_Code (Error))); + Emit_Error_Occurred (Self, + Integer (Glib.Error.Get_Code (Error))); Cleanup; Success := False; @@ -526,8 +602,8 @@ package body Spawn.Channels is -- Create pipe if Spawn.Posix.pipe2 (Fds, Posix.O_CLOEXEC) /= 0 then - Self.Process.Emit_Error_Occurred - (Integer (System.OS_Interface.errno)); + Emit_Error_Occurred (Self, + Integer (System.OS_Interface.errno)); Success := False; return; @@ -550,8 +626,8 @@ package body Spawn.Channels is Glib.IOChannel.G_Io_Flag_Nonblock, Error'Access) /= Glib.IOChannel.G_Io_Status_Normal then - Self.Process.Emit_Error_Occurred - (Integer (Glib.Error.Get_Code (Error))); + Emit_Error_Occurred (Self, + Integer (Glib.Error.Get_Code (Error))); Cleanup; Success := False; @@ -563,8 +639,8 @@ package body Spawn.Channels is if Glib.IOChannel.Set_Encoding (Write, "", Error'Access) /= Glib.IOChannel.G_Io_Status_Normal then - Self.Process.Emit_Error_Occurred - (Integer (Glib.Error.Get_Code (Error))); + Emit_Error_Occurred (Self, + Integer (Glib.Error.Get_Code (Error))); Cleanup; Success := False; @@ -630,8 +706,8 @@ package body Spawn.Channels is (Spawn.Posix.O_RDWR + Spawn.Posix.O_NOCTTY); if PTY_Master = -1 then - Self.Process.Emit_Error_Occurred - (Integer (System.OS_Interface.errno)); + Emit_Error_Occurred (Self, + Integer (System.OS_Interface.errno)); Success := False; @@ -645,8 +721,8 @@ package body Spawn.Channels is = -1 then Cleanup; - Self.Process.Emit_Error_Occurred - (Integer (System.OS_Interface.errno)); + Emit_Error_Occurred (Self, + Integer (System.OS_Interface.errno)); Success := False; return; @@ -656,8 +732,8 @@ package body Spawn.Channels is if Spawn.Posix.grantpt (PTY_Master) /= 0 then Cleanup; - Self.Process.Emit_Error_Occurred - (Integer (System.OS_Interface.errno)); + Emit_Error_Occurred (Self, + Integer (System.OS_Interface.errno)); Success := False; return; @@ -667,8 +743,8 @@ package body Spawn.Channels is if Spawn.Posix.unlockpt (PTY_Master) /= 0 then Cleanup; - Self.Process.Emit_Error_Occurred - (Integer (System.OS_Interface.errno)); + Emit_Error_Occurred (Self, + Integer (System.OS_Interface.errno)); Success := False; return; @@ -682,7 +758,7 @@ package body Spawn.Channels is if Status /= 0 then Cleanup; - Self.Process.Emit_Error_Occurred (Integer (Status)); + Emit_Error_Occurred (Self, Integer (Status)); Success := False; return; @@ -697,8 +773,8 @@ package body Spawn.Channels is if Self.PTY_Slave = -1 then Cleanup; - Self.Process.Emit_Error_Occurred - (Integer (System.OS_Interface.errno)); + Emit_Error_Occurred (Self, + Integer (System.OS_Interface.errno)); Success := False; return; @@ -719,8 +795,8 @@ package body Spawn.Channels is Glib.IOChannel.G_Io_Flag_Nonblock, Error'Access) /= Glib.IOChannel.G_Io_Status_Normal then - Self.Process.Emit_Error_Occurred - (Integer (Glib.Error.Get_Code (Error))); + Emit_Error_Occurred (Self, + Integer (Glib.Error.Get_Code (Error))); Cleanup; Success := False; @@ -732,8 +808,8 @@ package body Spawn.Channels is if Glib.IOChannel.Set_Encoding (PTY_Channel, "", Error'Access) /= Glib.IOChannel.G_Io_Status_Normal then - Self.Process.Emit_Error_Occurred - (Integer (Glib.Error.Get_Code (Error))); + Emit_Error_Occurred (Self, + Integer (Glib.Error.Get_Code (Error))); Cleanup; Success := False; @@ -977,8 +1053,8 @@ 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))); + Emit_Error_Occurred (Self, + Integer (Glib.Error.Get_Code (Error))); when others => raise Program_Error; diff --git a/source/spawn/spawn-common.adb b/source/spawn/spawn-common.adb new file mode 100644 index 0000000..f0b7b56 --- /dev/null +++ b/source/spawn/spawn-common.adb @@ -0,0 +1,90 @@ +-- +-- Copyright (C) 2018-2022, AdaCore +-- +-- SPDX-License-Identifier: Apache-2.0 +-- + +package body Spawn.Common is + + ------------------- + -- Set_Arguments -- + ------------------- + + procedure Set_Arguments + (Self : in out Process'Class; + Arguments : Spawn.String_Vectors.UTF_8_String_Vector) is + begin + Self.Arguments := Arguments; + end Set_Arguments; + + --------------------- + -- Set_Environment -- + --------------------- + + procedure Set_Environment + (Self : in out Process'Class; + Environment : Spawn.Environments.Process_Environment) is + begin + Self.Environment := Environment; + end Set_Environment; + + ------------------ + -- Set_Listener -- + ------------------ + + procedure Set_Listener + (Self : in out Process'Class; + Listener : Spawn.Process_Listeners.Process_Listener_Access) is + begin + Self.Listener := Listener; + end Set_Listener; + + ----------------- + -- Set_Program -- + ----------------- + + procedure Set_Program + (Self : in out Process'Class; + Program : UTF_8_String) is + begin + Self.Command := Ada.Strings.Unbounded.To_Unbounded_String (Program); + end Set_Program; + + ---------------------------- + -- Set_Standard_Error_PTY -- + ---------------------------- + + procedure Set_Standard_Error_PTY (Self : in out Process'Class) is + begin + Self.Use_PTY (Stderr) := True; + end Set_Standard_Error_PTY; + + ---------------------------- + -- Set_Standard_Input_PTY -- + ---------------------------- + + procedure Set_Standard_Input_PTY (Self : in out Process'Class) is + begin + Self.Use_PTY (Stdin) := True; + end Set_Standard_Input_PTY; + + ----------------------------- + -- Set_Standard_Output_PTY -- + ----------------------------- + + procedure Set_Standard_Output_PTY (Self : in out Process'Class) is + begin + Self.Use_PTY (Stdout) := True; + end Set_Standard_Output_PTY; + + --------------------------- + -- Set_Working_Directory -- + --------------------------- + + procedure Set_Working_Directory + (Self : in out Process'Class; Directory : UTF_8_String) is + begin + Self.Directory := Ada.Strings.Unbounded.To_Unbounded_String (Directory); + end Set_Working_Directory; + +end Spawn.Common; diff --git a/source/spawn/spawn-common.ads b/source/spawn/spawn-common.ads new file mode 100644 index 0000000..c312abd --- /dev/null +++ b/source/spawn/spawn-common.ads @@ -0,0 +1,91 @@ +-- +-- Copyright (C) 2018-2022, AdaCore +-- +-- SPDX-License-Identifier: Apache-2.0 +-- + +-- Base type for process implementation on all platforms. + +with Ada.Finalization; +with Ada.Strings.Unbounded; + +with Spawn.Environments; +with Spawn.Process_Listeners; +with Spawn.String_Vectors; + +private +package Spawn.Common is + + type Pipe_Kinds is (Stdin, Stdout, Stderr, Launch); + + subtype Standard_Pipe is Pipe_Kinds range Stdin .. Stderr; + + type Pipe_Flags is array (Standard_Pipe) of Boolean; + + type Process is new Ada.Finalization.Limited_Controlled with record + Arguments : Spawn.String_Vectors.UTF_8_String_Vector; + Environment : Spawn.Environments.Process_Environment := + Spawn.Environments.System_Environment; + Exit_Status : Process_Exit_Status := Normal; + Exit_Code : Process_Exit_Code := Process_Exit_Code'Last; + Status : Process_Status := Not_Running; + + Listener : Spawn.Process_Listeners.Process_Listener_Access; + -- The associated listener. Note: this may be null. + + Command : Ada.Strings.Unbounded.Unbounded_String; + Directory : Ada.Strings.Unbounded.Unbounded_String; + Use_PTY : Pipe_Flags := (others => False); + end record; + + function Arguments (Self : Process'Class) + return Spawn.String_Vectors.UTF_8_String_Vector is + (Self.Arguments); + procedure Set_Arguments + (Self : in out Process'Class; + Arguments : Spawn.String_Vectors.UTF_8_String_Vector); + + function Environment (Self : Process'Class) + return Spawn.Environments.Process_Environment is + (Self.Environment); + procedure Set_Environment + (Self : in out Process'Class; + Environment : Spawn.Environments.Process_Environment); + + function Working_Directory (Self : Process'Class) return UTF_8_String is + (Ada.Strings.Unbounded.To_String (Self.Directory)); + procedure Set_Working_Directory + (Self : in out Process'Class; + Directory : UTF_8_String); + + function Program (Self : Process'Class) return UTF_8_String is + (Ada.Strings.Unbounded.To_String (Self.Command)); + procedure Set_Program + (Self : in out Process'Class; + Program : UTF_8_String); + + procedure Set_Standard_Input_PTY (Self : in out Process'Class); + + procedure Set_Standard_Output_PTY (Self : in out Process'Class); + + procedure Set_Standard_Error_PTY (Self : in out Process'Class); + + function Status (Self : Process'Class) return Process_Status is + (Self.Status); + + function Exit_Status (Self : Process'Class) return Process_Exit_Status is + (Self.Exit_Status); + -- Return the exit status of last process that finishes. + + function Exit_Code (Self : Process'Class) return Process_Exit_Code is + (Self.Exit_Code); + + function Listener (Self : Process'Class) + return Spawn.Process_Listeners.Process_Listener_Access is + (Self.Listener); + + procedure Set_Listener + (Self : in out Process'Class; + Listener : Spawn.Process_Listeners.Process_Listener_Access); + +end Spawn.Common; diff --git a/source/spawn/spawn-environments.adb b/source/spawn/spawn-environments.adb index ff4a7ae..be703a2 100644 --- a/source/spawn/spawn-environments.adb +++ b/source/spawn/spawn-environments.adb @@ -1,9 +1,11 @@ -- --- Copyright (C) 2018-2019, AdaCore +-- Copyright (C) 2018-2022, AdaCore -- -- SPDX-License-Identifier: Apache-2.0 -- +private with Spawn.Internal; + package body Spawn.Environments is procedure Initialize_Default (Default : out Process_Environment); @@ -15,6 +17,12 @@ package body Spawn.Environments is Default : Process_Environment; + function Less (Left, Right : UTF_8_String) return Boolean + renames Spawn.Internal.Environments."<"; + + function Equal (Left, Right : UTF_8_String) return Boolean + renames Spawn.Internal.Environments."="; + ----------- -- Clear -- ----------- diff --git a/source/spawn/spawn-environments.ads b/source/spawn/spawn-environments.ads index 775e3b6..799604b 100644 --- a/source/spawn/spawn-environments.ads +++ b/source/spawn/spawn-environments.ads @@ -1,5 +1,5 @@ -- --- Copyright (C) 2018-2019, AdaCore +-- Copyright (C) 2018-2022, AdaCore -- -- SPDX-License-Identifier: Apache-2.0 -- @@ -10,7 +10,6 @@ with Spawn.String_Vectors; private with Ada.Containers.Indefinite_Ordered_Maps; -private with Spawn.Internal; package Spawn.Environments is @@ -62,11 +61,14 @@ package Spawn.Environments is private + function Less (Left, Right : UTF_8_String) return Boolean; + function Equal (Left, Right : UTF_8_String) return Boolean; + package UTF_8_String_Maps is new Ada.Containers.Indefinite_Ordered_Maps (Key_Type => UTF_8_String, Element_Type => UTF_8_String, - "<" => Spawn.Internal.Environments."<", - "=" => Spawn.Internal.Environments."="); + "<" => Less, + "=" => Equal); -- Spawn.Internal.Environments."="); type Process_Environment is tagged record Map : UTF_8_String_Maps.Map; diff --git a/source/spawn/spawn-processes-monitor-osx_initialize.adb b/source/spawn/spawn-internal-monitor-osx_initialize.adb similarity index 92% rename from source/spawn/spawn-processes-monitor-osx_initialize.adb rename to source/spawn/spawn-internal-monitor-osx_initialize.adb index 6e73a3e..64a1d8b 100644 --- a/source/spawn/spawn-processes-monitor-osx_initialize.adb +++ b/source/spawn/spawn-internal-monitor-osx_initialize.adb @@ -1,5 +1,5 @@ -- --- Copyright (C) 2018-2020, AdaCore +-- Copyright (C) 2018-2022, AdaCore -- -- SPDX-License-Identifier: Apache-2.0 -- @@ -16,7 +16,7 @@ pragma Warnings (Off); with System.OS_Interface; pragma Warnings (Off); -separate (Spawn.Processes.Monitor) +separate (Spawn.Internal.Monitor) procedure Initialize is Ignore : Interfaces.C.int; Value : aliased System.OS_Interface.struct_sigaction := diff --git a/source/spawn/spawn-processes-monitor-unix_initialize.adb b/source/spawn/spawn-internal-monitor-unix_initialize.adb similarity index 69% rename from source/spawn/spawn-processes-monitor-unix_initialize.adb rename to source/spawn/spawn-internal-monitor-unix_initialize.adb index 1ed5204..abdb1ef 100644 --- a/source/spawn/spawn-processes-monitor-unix_initialize.adb +++ b/source/spawn/spawn-internal-monitor-unix_initialize.adb @@ -1,5 +1,5 @@ -- --- Copyright (C) 2018-2020, AdaCore +-- Copyright (C) 2018-2022, AdaCore -- -- SPDX-License-Identifier: Apache-2.0 -- @@ -7,7 +7,7 @@ -- -- This is an empty implementation used in Linux. -- -separate (Spawn.Processes.Monitor) +separate (Spawn.Internal.Monitor) procedure Initialize is begin null; diff --git a/source/spawn/spawn-processes-monitor.ads b/source/spawn/spawn-internal-monitor.ads similarity index 67% rename from source/spawn/spawn-processes-monitor.ads rename to source/spawn/spawn-internal-monitor.ads index 8e71f28..69829ed 100644 --- a/source/spawn/spawn-processes-monitor.ads +++ b/source/spawn/spawn-internal-monitor.ads @@ -1,21 +1,23 @@ -- --- Copyright (C) 2018-2019, AdaCore +-- Copyright (C) 2018-2022, AdaCore -- -- SPDX-License-Identifier: Apache-2.0 -- -private package Spawn.Processes.Monitor is +with Spawn.Common; + +private package Spawn.Internal.Monitor is type Command_Kind is (Start, Close_Pipe, Watch_Pipe); type Command (Kind : Command_Kind := Start) is record - Process : access Spawn.Processes.Process'Class; + Process : access Spawn.Internal.Process'Class; case Kind is when Start => null; when Close_Pipe | Watch_Pipe => - Pipe : Standard_Pipe; + Pipe : Spawn.Common.Standard_Pipe; end case; end record; @@ -24,4 +26,4 @@ private package Spawn.Processes.Monitor is procedure Loop_Cycle (Timeout : Integer); -- Timeout in milliseconds. Dont wait if zero. Wait forever if < 0 -end Spawn.Processes.Monitor; +end Spawn.Internal.Monitor; diff --git a/source/spawn/spawn-processes-monitor__posix.adb b/source/spawn/spawn-internal-monitor__posix.adb similarity index 97% rename from source/spawn/spawn-processes-monitor__posix.adb rename to source/spawn/spawn-internal-monitor__posix.adb index e31156c..6b356ae 100644 --- a/source/spawn/spawn-processes-monitor__posix.adb +++ b/source/spawn/spawn-internal-monitor__posix.adb @@ -1,5 +1,5 @@ -- --- Copyright (C) 2018-2021, AdaCore +-- Copyright (C) 2018-2022, AdaCore -- -- SPDX-License-Identifier: Apache-2.0 -- @@ -9,16 +9,21 @@ with Ada.Containers.Synchronized_Queue_Interfaces; with Ada.Containers.Unbounded_Synchronized_Queues; with Ada.Containers.Vectors; with Ada.Interrupts.Names; +with Ada.Strings.Unbounded; with Ada.Unchecked_Deallocation; +with Interfaces.C.Strings; + with GNAT.OS_Lib; -with Spawn.Posix; with Spawn.Environments.Internal; -with Interfaces.C.Strings; +with Spawn.Posix; +with Spawn.Process_Listeners; -package body Spawn.Processes.Monitor is +package body Spawn.Internal.Monitor is use type Interfaces.C.int; + use type Spawn.Process_Listeners.Process_Listener_Access; + use all type Pipe_Kinds; type Process_Access is access all Process'Class; @@ -26,7 +31,7 @@ package body Spawn.Processes.Monitor is procedure Do_Close_Pipe (Self : Process_Access; - Kind : Standard_Pipe); + Kind : Common.Standard_Pipe); procedure My_IO_Callback (Process : Process_Access; @@ -97,7 +102,7 @@ package body Spawn.Processes.Monitor is procedure Watch_Pipe (Self : Process_Access; - Kind : Standard_Pipe); + Kind : Common.Standard_Pipe); procedure Wait (Timeout : Interfaces.C.int; @@ -321,9 +326,9 @@ package body Spawn.Processes.Monitor is procedure Watch_Pipe (Self : Process_Access; - Kind : Standard_Pipe) + Kind : Common.Standard_Pipe) is - Event_Map : constant array (Standard_Pipe) of + Event_Map : constant array (Common.Standard_Pipe) of Interfaces.C.unsigned_short := (Stdin => Posix.POLLOUT, others => Posix.POLLIN); @@ -424,7 +429,7 @@ package body Spawn.Processes.Monitor is procedure Do_Close_Pipe (Self : Process_Access; - Kind : Standard_Pipe) + Kind : Common.Standard_Pipe) is Ignore : Interfaces.C.int := Posix.close (Self.pipe (Kind)); begin @@ -588,8 +593,7 @@ package body Spawn.Processes.Monitor is procedure Prepare_Arguments (argv : out Posix.chars_ptr_array) is begin - argv (0) := Interfaces.C.Strings.New_String - (To_String (Self.Program)); + argv (0) := Interfaces.C.Strings.New_String (Self.Program); for J in 1 .. Self.Arguments.Last_Index loop argv (J) := Interfaces.C.Strings.New_String @@ -697,7 +701,7 @@ package body Spawn.Processes.Monitor is end if; -- Make stdio non-blocking - if (for some X in Standard_Pipe => + if (for some X in Common.Standard_Pipe => Posix.fcntl (std (X) (Parent_Ends (X)), Posix.F_SETFL, @@ -728,4 +732,4 @@ package body Spawn.Processes.Monitor is begin Initialize; -end Spawn.Processes.Monitor; +end Spawn.Internal.Monitor; diff --git a/source/spawn/spawn-processes-monitor__windows.adb b/source/spawn/spawn-internal-monitor__windows.adb similarity index 95% rename from source/spawn/spawn-processes-monitor__windows.adb rename to source/spawn/spawn-internal-monitor__windows.adb index d4f5c83..7038604 100644 --- a/source/spawn/spawn-processes-monitor__windows.adb +++ b/source/spawn/spawn-internal-monitor__windows.adb @@ -1,5 +1,5 @@ -- --- Copyright (C) 2018-2020, AdaCore +-- Copyright (C) 2018-2022, AdaCore -- -- SPDX-License-Identifier: Apache-2.0 -- @@ -13,17 +13,18 @@ pragma Warnings (Off); with System.Win32; pragma Warnings (On); -with Spawn.Processes.Windows; with Spawn.Windows_API; +with Spawn.Internal.Windows; -package body Spawn.Processes.Monitor is +package body Spawn.Internal.Monitor is + use all type Spawn.Common.Pipe_Kinds; subtype Context is Internal.Context; subtype Stream_Element_Buffer is Internal.Stream_Element_Buffer; - type Process_Access is access all Processes.Process'Class; + type Process_Access is access all Process'Class; - procedure Start_Process (Self : access Processes.Process'Class); + procedure Start_Process (Self : access Process'Class); package Command_Queue_Interfaces is new Ada.Containers.Synchronized_Queue_Interfaces (Command); @@ -54,7 +55,7 @@ package body Spawn.Processes.Monitor is procedure Do_Watch_Pipe (Process : not null Process_Access; - Kind : Standard_Pipe); + Kind : Spawn.Common.Standard_Pipe); Callback : constant array (Stdout .. Stderr) of Read_Write_Ex.Callback := (Standard_Output_Callback'Access, @@ -197,7 +198,7 @@ package body Spawn.Processes.Monitor is procedure Do_Watch_Pipe (Process : not null Process_Access; - Kind : Standard_Pipe) + Kind : Spawn.Common.Standard_Pipe) is use type Ada.Streams.Stream_Element_Count; use type Windows_API.BOOL; @@ -315,7 +316,7 @@ package body Spawn.Processes.Monitor is -- Start_Process -- ------------------- - procedure Start_Process (Self : access Processes.Process'Class) is + procedure Start_Process (Self : access Process'Class) is procedure On_Start; procedure On_Start is @@ -326,4 +327,4 @@ package body Spawn.Processes.Monitor is Windows.Do_Start_Process (Self.all, On_Start'Access); end Start_Process; -end Spawn.Processes.Monitor; +end Spawn.Internal.Monitor; diff --git a/source/spawn/spawn-processes-windows.adb b/source/spawn/spawn-internal-windows.adb similarity index 96% rename from source/spawn/spawn-processes-windows.adb rename to source/spawn/spawn-internal-windows.adb index b6ba508..27eb4e5 100644 --- a/source/spawn/spawn-processes-windows.adb +++ b/source/spawn/spawn-internal-windows.adb @@ -1,5 +1,5 @@ -- --- Copyright (C) 2018-2021, AdaCore +-- Copyright (C) 2018-2022, AdaCore -- -- SPDX-License-Identifier: Apache-2.0 -- @@ -8,6 +8,7 @@ with Ada.Characters.Wide_Latin_1; with Ada.Strings.UTF_Encoding.Wide_Strings; with Ada.Strings.Wide_Fixed; with Ada.Strings.Wide_Unbounded; +with Ada.Strings.Unbounded; with Interfaces.C.Strings; pragma Warnings (Off); @@ -17,7 +18,8 @@ pragma Warnings (On); with Spawn.Environments.Internal; -package body Spawn.Processes.Windows is +package body Spawn.Internal.Windows is + use all type Spawn.Common.Pipe_Kinds; Terminate_Code : constant Windows_API.UINT := 16#F291#; -- Arbitrary code to use as exit code for TerminateProcess call. @@ -39,7 +41,7 @@ package body Spawn.Processes.Windows is procedure Append_Escaped_String (Command_Line : in out Ada.Strings.Wide_Unbounded.Unbounded_Wide_String; - Argument : Ada.Strings.Unbounded.Unbounded_String); + Argument : UTF_8_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. @@ -64,7 +66,7 @@ package body Spawn.Processes.Windows is procedure Append_Escaped_String (Command_Line : in out Ada.Strings.Wide_Unbounded.Unbounded_Wide_String; - Argument : Ada.Strings.Unbounded.Unbounded_String) + Argument : UTF_8_String) is -- Implementation of the subprogram based on Microsoft's blog post -- "Everyone quotes command line arguments the wrong way". @@ -78,9 +80,8 @@ package body Spawn.Processes.Windows is & 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)); + S : constant Wide_String := Ada.Strings.UTF_Encoding.Wide_Strings.Decode + (Argument); J : Natural; -- Iterator N : Natural; -- Number of sequential backslashes. @@ -255,7 +256,7 @@ package body Spawn.Processes.Windows 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 Request_Read (Kind : Spawn.Common.Standard_Pipe); procedure Create_Pipe (Parent_Handle : out Windows_API.HANDLE; @@ -459,7 +460,7 @@ package body Spawn.Processes.Windows is function Create_Pipes (Start : access Windows_API.STARTUPINFOW) return Boolean is - Child : constant array (Standard_Pipe) of + Child : constant array (Spawn.Common.Standard_Pipe) of not null access Windows_API.HANDLE := (Stdin => Start.hStdInput'Access, Stdout => Start.hStdOutput'Access, @@ -467,7 +468,7 @@ package body Spawn.Processes.Windows is Ok : Boolean := True; begin - for J in Standard_Pipe loop + for J in Spawn.Common.Standard_Pipe loop Self.pipe (J).Process := Self'Unchecked_Access; Self.pipe (J).Kind := J; Create_Pipe @@ -508,8 +509,7 @@ package body Spawn.Processes.Windows is for Arg of Self.Arguments loop Ada.Strings.Wide_Unbounded.Append (Result, ' '); - Append_Escaped_String - (Result, Ada.Strings.Unbounded.To_Unbounded_String (Arg)); + Append_Escaped_String (Result, Arg); end loop; return Interfaces.C.To_C @@ -520,7 +520,7 @@ package body Spawn.Processes.Windows is -- Request_Read -- ------------------ - procedure Request_Read (Kind : Standard_Pipe) is + procedure Request_Read (Kind : Spawn.Common.Standard_Pipe) is begin if Is_Error (Read_Write_Ex.ReadFileEx @@ -552,8 +552,7 @@ package body Spawn.Processes.Windows is Exe : constant Interfaces.C.wchar_array := Interfaces.C.To_C - (Ada.Strings.UTF_Encoding.Wide_Strings.Decode - (Ada.Strings.Unbounded.To_String (Self.Program))); + (Ada.Strings.UTF_Encoding.Wide_Strings.Decode (Self.Program)); Args : Interfaces.C.wchar_array := Make_Command_Line; @@ -664,7 +663,7 @@ package body Spawn.Processes.Windows is (dwErrorCode : Windows_API.DWORD; dwNumberOfBytesTransfered : Windows_API.DWORD; lpOverlapped : access Internal.Context; - Kind : Standard_Pipe) + Kind : Spawn.Common.Standard_Pipe) is use type Windows_API.DWORD; use type Windows_API.HANDLE; @@ -805,8 +804,7 @@ package body Spawn.Processes.Windows is Self.Exit_Code := Process_Exit_Code (Exit_Code); Self.Status := Not_Running; - Self.Listener.Finished - (Self.Exit_Status, Self.Exit_Code); + Self.Listener.Finished (Self.Exit_Status, Self.Exit_Code); end if; end On_Process_Died; @@ -836,4 +834,4 @@ package body Spawn.Processes.Windows is (dwErrorCode, dwNumberOfBytesTransfered, lpOverlapped, Stdout); end Standard_Output_Callback; -end Spawn.Processes.Windows; +end Spawn.Internal.Windows; diff --git a/source/spawn/spawn-processes-windows.ads b/source/spawn/spawn-internal-windows.ads similarity index 86% rename from source/spawn/spawn-processes-windows.ads rename to source/spawn/spawn-internal-windows.ads index bcb7d60..bd8e111 100644 --- a/source/spawn/spawn-processes-windows.ads +++ b/source/spawn/spawn-internal-windows.ads @@ -1,13 +1,14 @@ -- --- Copyright (C) 2018-2021, AdaCore +-- Copyright (C) 2018-2022, AdaCore -- -- SPDX-License-Identifier: Apache-2.0 -- with Spawn.Windows_API; +with Spawn.Common; private -package Spawn.Processes.Windows is +package Spawn.Internal.Windows is procedure Do_Start_Process (Self : aliased in out Process'Class; @@ -40,7 +41,7 @@ package Spawn.Processes.Windows is (dwErrorCode : Windows_API.DWORD; dwNumberOfBytesTransfered : Windows_API.DWORD; lpOverlapped : access Internal.Context; - Kind : Standard_Pipe); + Kind : Spawn.Common.Standard_Pipe); -- Implementation shared between Standard_[Output/Error]_Callback -end Spawn.Processes.Windows; +end Spawn.Internal.Windows; diff --git a/source/spawn/spawn-internal__glib.ads b/source/spawn/spawn-internal__glib.ads deleted file mode 100644 index de05eb9..0000000 --- a/source/spawn/spawn-internal__glib.ads +++ /dev/null @@ -1,53 +0,0 @@ --- --- Copyright (C) 2018-2022, AdaCore --- --- SPDX-License-Identifier: Apache-2.0 --- - -with Ada.Finalization; - -with Glib.Main; -with Glib.Spawn; - -with Spawn.Channels; - -private package Spawn.Internal is - - package Environments is - - function "=" (Left, Right : UTF_8_String) return Boolean; - function "<" (Left, Right : UTF_8_String) return Boolean; - - end Environments; - - type Pipe_Kinds is (Stdin, Stdout, Stderr); - - type Process is tagged; - - type Process_Reference is record - Self : access Process'Class; - end record; - -- A wrapper to pass process pointer to C binding functions - - type Process is - abstract new Ada.Finalization.Limited_Controlled with record - Reference : aliased Process_Reference; - Channels : Spawn.Channels.Channels (Process'Unchecked_Access); - Event : Glib.Main.G_Source_Id := 0; - pid : aliased Glib.Spawn.GPid := 0; - end record; - - procedure Emit_Stdin_Available (Self : in out Process) is abstract; - - procedure Emit_Stdout_Available (Self : in out Process) is abstract; - - procedure Emit_Stderr_Available (Self : in out Process) is abstract; - - procedure Emit_Error_Occurred - (Self : in out Process; - Process_Error : Integer) is abstract; - - procedure On_Close_Channels (Self : in out Process) is null; - -- This callback is called when last channel is closed - -end Spawn.Internal; diff --git a/source/spawn/spawn-processes-platform__glib.adb b/source/spawn/spawn-internal__glib_posix.adb similarity index 86% rename from source/spawn/spawn-processes-platform__glib.adb rename to source/spawn/spawn-internal__glib_posix.adb index 604950d..23b554f 100644 --- a/source/spawn/spawn-processes-platform__glib.adb +++ b/source/spawn/spawn-internal__glib_posix.adb @@ -4,25 +4,25 @@ -- SPDX-License-Identifier: Apache-2.0 -- -with Interfaces.C; - pragma Warnings (Off, "internal GNAT unit"); with System.OS_Interface; pragma Warnings (On); with Glib.Error; -with Glib.Main; with Glib.Spawn; with Gtkada.Types; -with Spawn.Channels; with Spawn.Environments.Internal; with Spawn.Posix; -separate (Spawn.Processes) -package body Platform is +package body Spawn.Internal is + use all type Spawn.Common.Pipe_Kinds; - procedure Do_Start_Process (Self : aliased in out Process'Class); + type Process_Access is access all Process'Class; + + function Spawn_Async_With_Fds is + new Glib.Spawn.Generic_Spawn_Async_With_Fds + (User_Data => Glib.Gint); function Child_Watch is new Glib.Main.Generic_Child_Add_Watch (User_Data => Internal.Process_Reference); @@ -33,17 +33,35 @@ package body Platform is data : access Internal.Process_Reference) with Convention => C; - type Process_Access is access all Process'Class; - - function Spawn_Async_With_Fds is - new Glib.Spawn.Generic_Spawn_Async_With_Fds - (User_Data => Glib.Gint); + procedure Do_Start_Process (Self : aliased in out Process'Class); procedure Setup_Child_Process (Fd : access Glib.Gint) with Convention => C; -- Setup session and controlling terminal when pseudoterminal is used -- for interprocess communication. + package body Environments is + + --------- + -- "=" -- + --------- + + function "=" (Left, Right : UTF_8_String) return Boolean is + begin + return Standard."=" (Left, Right); + end "="; + + --------- + -- "<" -- + --------- + + function "<" (Left, Right : UTF_8_String) return Boolean is + begin + return Standard."<" (Left, Right); + end "<"; + + end Environments; + -------------------------- -- Close_Standard_Error -- -------------------------- @@ -76,7 +94,6 @@ package body Platform is ---------------------- procedure Do_Start_Process (Self : aliased in out Process'Class) is - use Ada.Strings.Unbounded; use Glib; use type Interfaces.C.size_t; @@ -89,8 +106,7 @@ package body Platform is procedure Prepare_Arguments (argv : out Gtkada.Types.Chars_Ptr_Array) is begin - argv (0) := Gtkada.Types.New_String - (To_String (Self.Program)); + argv (0) := Gtkada.Types.New_String (Self.Program); for J in 1 .. Self.Arguments.Last_Index loop argv (Interfaces.C.size_t (J)) := Gtkada.Types.New_String @@ -100,10 +116,12 @@ package body Platform is argv (argv'Last) := Gtkada.Types.Null_Ptr; end Prepare_Arguments; + pid : aliased Glib.Spawn.GPid + with Import, Address => Self.pid'Address; + dir : Gtkada.Types.Chars_Ptr := - (if Length (Self.Directory) = 0 then Gtkada.Types.Null_Ptr - else Gtkada.Types.New_String - (To_String (Self.Directory))); + (if Self.Working_Directory'Length = 0 then Gtkada.Types.Null_Ptr + else Gtkada.Types.New_String (Self.Working_Directory)); argv : aliased Gtkada.Types.Chars_Ptr_Array := (0 .. Interfaces.C.size_t (Self.Arguments.Length) + 1 => <>); @@ -133,7 +151,7 @@ package body Platform is Flags => Glib.Spawn.G_Spawn_Do_Not_Reap_Child, Child_Setup => Setup_Child_Process'Access, Data => PTY'Unchecked_Access, - Child_Pid => Self.pid'Access, + Child_Pid => pid'Access, Stdin_Fd => Spawn.Channels.Child_Stdin (Self.Channels), Stdout_Fd => Spawn.Channels.Child_Stdout (Self.Channels), Stderr_Fd => Spawn.Channels.Child_Stderr (Self.Channels), @@ -153,7 +171,7 @@ package body Platform is end if; Self.Event := Child_Watch - (Self.pid, + (pid, My_Death_Callback'Access, Self.Reference'Access); @@ -167,22 +185,11 @@ package body Platform is -- Finalize -- -------------- - procedure Finalize - (Self : in out Process'Class; - Status : Process_Status) - is - pragma Unreferenced (Status); - use type Glib.Main.G_Source_Id; + overriding procedure Finalize (Self : in out Process) is begin - Spawn.Channels.Shutdown_Channels (Self.Channels); - - if Self.Event /= Glib.Main.No_Source_Id then - Glib.Main.Remove (Self.Event); - Self.Event := Glib.Main.No_Source_Id; + if Self.Status = Running then + raise Program_Error; end if; - - Glib.Spawn.Spawn_Close_Pid (Self.pid); - Self.pid := 0; end Finalize; ------------------ @@ -192,9 +199,9 @@ package body Platform is procedure Kill_Process (Self : in out Process'Class) is use type Interfaces.C.int; - Code : constant Interfaces.C.int := Spawn.Posix.kill - (Interfaces.C.int (Self.pid), - Interfaces.C.int (System.OS_Interface.SIGKILL)); + Code : constant Interfaces.C.int := + Spawn.Posix.kill + (Self.pid, Interfaces.C.int (System.OS_Interface.SIGKILL)); begin pragma Assert (Code = 0); end Kill_Process; @@ -321,9 +328,9 @@ package body Platform is procedure Terminate_Process (Self : in out Process'Class) is use type Interfaces.C.int; - Code : constant Interfaces.C.int := Spawn.Posix.kill - (Interfaces.C.int (Self.pid), - Interfaces.C.int (System.OS_Interface.SIGTERM)); + Code : constant Interfaces.C.int := + Spawn.Posix.kill + (Self.pid, Interfaces.C.int (System.OS_Interface.SIGTERM)); begin pragma Assert (Code = 0); end Terminate_Process; @@ -340,4 +347,4 @@ package body Platform is Spawn.Channels.Write_Stdin (Self.Channels, Data, Last); end Write_Standard_Input; -end Platform; +end Spawn.Internal; diff --git a/source/spawn/spawn-internal__glib_posix.ads b/source/spawn/spawn-internal__glib_posix.ads new file mode 100644 index 0000000..698d3e5 --- /dev/null +++ b/source/spawn/spawn-internal__glib_posix.ads @@ -0,0 +1,80 @@ +-- +-- Copyright (C) 2018-2022, AdaCore +-- +-- SPDX-License-Identifier: Apache-2.0 +-- + +with Ada.Streams; +with Interfaces.C; + +with Glib.Main; + +with Spawn.Channels; +with Spawn.Common; + +private package Spawn.Internal is + + package Environments is + + function "=" (Left, Right : UTF_8_String) return Boolean; + function "<" (Left, Right : UTF_8_String) return Boolean; + + end Environments; + + type Process is tagged; + + type Process_Reference is record + Self : access Process'Class; + end record; + -- A wrapper to pass process pointer to C binding functions + + type Process is new Spawn.Common.Process with record + Reference : aliased Process_Reference; + Channels : Spawn.Channels.Channels (Process'Unchecked_Access); + Event : Glib.Main.G_Source_Id := 0; + pid : Interfaces.C.int := 0; + + Pending_Finish : Boolean := False; + -- We have got pid closed but channels are still active. + -- In this case delay Finished callback until channels are closed. + end record; + + overriding procedure Finalize (Self : in out Process); + + procedure Start (Self : in out Process'Class); + -- See documentation in Spawn.Processes. + + procedure Terminate_Process (Self : in out Process'Class); + -- See documentation in Spawn.Processes. + + procedure Kill_Process (Self : in out Process'Class); + -- See documentation in Spawn.Processes. + + procedure Close_Standard_Input (Self : in out Process'Class); + -- 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); + -- 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); + -- 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); + -- See documentation in Spawn.Processes. + +end Spawn.Internal; diff --git a/source/spawn/spawn-processes-platform__glib_windows.adb b/source/spawn/spawn-internal__glib_windows.adb similarity index 87% rename from source/spawn/spawn-processes-platform__glib_windows.adb rename to source/spawn/spawn-internal__glib_windows.adb index 266aed9..7e2eceb 100644 --- a/source/spawn/spawn-processes-platform__glib_windows.adb +++ b/source/spawn/spawn-internal__glib_windows.adb @@ -4,22 +4,53 @@ -- SPDX-License-Identifier: Apache-2.0 -- -with Glib.Main; -with Glib.Spawn; +with Ada.Strings.UTF_Encoding.Wide_Strings; +with Ada.Wide_Characters.Unicode; -with Spawn.Processes.Windows; +with Spawn.Internal.Windows; -with Spawn.Windows_API; -pragma Warnings (Off); -with System.Win32; -pragma Warnings (On); +package body Spawn.Internal is + use type Ada.Streams.Stream_Element_Offset; + use all type Spawn.Common.Pipe_Kinds; -separate (Spawn.Processes) -package body Platform is + package body Environments is - subtype Context is Internal.Context; + --------- + -- "=" -- + --------- - type Process_Access is access all Processes.Process'Class; + function "=" (Left, Right : UTF_8_String) return Boolean is + begin + return To_Key (Left) = To_Key (Right); + end "="; + + --------- + -- "<" -- + --------- + + function "<" (Left, Right : UTF_8_String) return Boolean is + begin + return To_Key (Left) < To_Key (Right); + end "<"; + + ------------ + -- To_Key -- + ------------ + + function To_Key (Text : UTF_8_String) return Wide_String is + Value : Wide_String := + Ada.Strings.UTF_Encoding.Wide_Strings.Decode (Text); + begin + for Char of Value loop + Char := Ada.Wide_Characters.Unicode.To_Upper_Case (Char); + end loop; + + return Value; + end To_Key; + + end Environments; + + type Process_Access is access all Process'Class; procedure Do_Start_Process (Self : aliased in out Process'Class); @@ -27,7 +58,7 @@ package body Platform is (Self : in out Process'Class; Data : out Ada.Streams.Stream_Element_Array; Last : out Ada.Streams.Stream_Element_Offset; - Kind : Standard_Pipe); + Kind : Spawn.Common.Standard_Pipe); function Child_Watch is new Glib.Main.Generic_Child_Add_Watch (User_Data => Internal.Process_Reference); @@ -98,7 +129,7 @@ package body Platform is (Self : in out Process'Class; Data : out Ada.Streams.Stream_Element_Array; Last : out Ada.Streams.Stream_Element_Offset; - Kind : Standard_Pipe) + Kind : Spawn.Common.Standard_Pipe) is procedure On_No_Data; @@ -153,11 +184,7 @@ package body Platform is -- Finalize -- -------------- - procedure Finalize - (Self : in out Process'Class; - Status : Process_Status) - is - pragma Unreferenced (Status); + overriding procedure Finalize (Self : in out Process) is use type Glib.Main.G_Source_Id; begin @@ -328,4 +355,4 @@ package body Platform is Windows.Do_Write (Self, Data, Last, On_No_Data'Access); end Write_Standard_Input; -end Platform; +end Spawn.Internal; diff --git a/source/spawn/spawn-internal__glib_windows.ads b/source/spawn/spawn-internal__glib_windows.ads index dc5e8ae..c3554ac 100644 --- a/source/spawn/spawn-internal__glib_windows.ads +++ b/source/spawn/spawn-internal__glib_windows.ads @@ -6,15 +6,17 @@ with Ada.Finalization; with Ada.Streams; --- with Interfaces.C; with Glib.Main; +with Glib.Spawn; with Spawn.Windows_API; pragma Warnings (Off); with System.Win32; pragma Warnings (On); +with Spawn.Common; + private package Spawn.Internal is package Environments is @@ -32,7 +34,7 @@ private package Spawn.Internal is subtype Stream_Element_Buffer is Ada.Streams.Stream_Element_Array (1 .. Buffer_Size); - type Pipe_Kinds is (Stdin, Stdout, Stderr); + subtype Pipe_Kinds is Spawn.Common.Pipe_Kinds; type Context is record lpOverlapped : Windows_API.OVERLAPPED; @@ -52,24 +54,51 @@ private package Spawn.Internal is end record; -- A wrapper to pass process pointer to C binding functions - type Process is - abstract new Ada.Finalization.Limited_Controlled with record + type Process is new Spawn.Common.Process with record Reference : aliased Process_Reference; Event : Glib.Main.G_Source_Id := 0; pid : aliased Windows_API.PROCESS_INFORMATION; pipe : Pipe_Array; end record; + -- Process implementation type provides the same interface as + -- Spawn.Processes.Process type. - procedure Emit_Stdin_Available (Self : in out Process) is abstract; + overriding procedure Finalize (Self : in out Process); - procedure Emit_Stdout_Available (Self : in out Process) is abstract; + procedure Start (Self : in out Process'Class); + -- See documentation in Spawn.Processes. - procedure Emit_Stderr_Available (Self : in out Process) is abstract; + procedure Terminate_Process (Self : in out Process'Class); + -- See documentation in Spawn.Processes. - procedure Emit_Error_Occurred - (Self : in out Process; - Process_Error : Integer) is abstract; + procedure Kill_Process (Self : in out Process'Class); + -- See documentation in Spawn.Processes. - procedure On_Close_Channels (Self : in out Process) is null; + procedure Close_Standard_Input (Self : in out Process'Class); + -- 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); + -- 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); + -- 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); + -- 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 f3313a7..35386f6 100644 --- a/source/spawn/spawn-internal__posix.adb +++ b/source/spawn/spawn-internal__posix.adb @@ -1,10 +1,20 @@ -- --- Copyright (C) 2018-2019, AdaCore +-- Copyright (C) 2018-2022, AdaCore -- -- SPDX-License-Identifier: Apache-2.0 -- +pragma Warnings (Off, "internal GNAT unit"); +with System.OS_Interface; +pragma Warnings (On); + +with GNAT.OS_Lib; + +with Spawn.Internal.Monitor; +with Spawn.Posix; + package body Spawn.Internal is + use all type Spawn.Common.Pipe_Kinds; package body Environments is @@ -28,4 +38,201 @@ package body Spawn.Internal is end Environments; + function Errno return Interfaces.C.int is + (Interfaces.C.int (GNAT.OS_Lib.Errno)); + -- return errno, number of last error + + -------------------------- + -- Close_Standard_Error -- + -------------------------- + + procedure Close_Standard_Error (Self : in out Process'Class) is + begin + Monitor.Enqueue ((Monitor.Close_Pipe, Self'Unchecked_Access, Stderr)); + end Close_Standard_Error; + + -------------------------- + -- Close_Standard_Input -- + -------------------------- + + procedure Close_Standard_Input (Self : in out Process'Class) is + begin + Monitor.Enqueue ((Monitor.Close_Pipe, Self'Unchecked_Access, Stdin)); + end Close_Standard_Input; + + --------------------------- + -- Close_Standard_Output -- + --------------------------- + + procedure Close_Standard_Output (Self : in out Process'Class) is + begin + Monitor.Enqueue ((Monitor.Close_Pipe, Self'Unchecked_Access, Stdout)); + end Close_Standard_Output; + + -------------- + -- Finalize -- + -------------- + + overriding procedure Finalize (Self : in out Process) is + begin + if Self.Status = Running then + raise Program_Error; + end if; + end Finalize; + + ------------------ + -- Kill_Process -- + ------------------ + + procedure Kill_Process (Self : in out Process'Class) is + use type Interfaces.C.int; + + Code : constant Interfaces.C.int := + Spawn.Posix.kill + (Self.pid, Interfaces.C.int (System.OS_Interface.SIGKILL)); + begin + pragma Assert (Code = 0); + end Kill_Process; + + ---------------- + -- Loop_Cycle -- + ---------------- + + procedure Loop_Cycle (Timeout : Integer) + renames Spawn.Internal.Monitor.Loop_Cycle; + + ------------------------- + -- Read_Standard_Error -- + ------------------------- + + procedure Read_Standard_Error + (Self : in out Process'Class; + Data : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset) + is + use type Ada.Streams.Stream_Element_Offset; + use type Interfaces.C.size_t; + + Count : Interfaces.C.size_t; + begin + if Self.Status /= Running then + Last := Data'First - 1; + return; + end if; + + Count := Posix.read (Self.pipe (Stderr), Data, Data'Length); + + if Count = Interfaces.C.size_t'Last then + if Errno in Posix.EAGAIN | Posix.EINTR then + Last := Data'First - 1; + Monitor.Enqueue + ((Monitor.Watch_Pipe, Self'Unchecked_Access, Stderr)); + else + raise Program_Error with + "read error: " & GNAT.OS_Lib.Errno_Message; + end if; + else + Last := Data'First + Ada.Streams.Stream_Element_Offset (Count) - 1; + end if; + end Read_Standard_Error; + + -------------------------- + -- Read_Standard_Output -- + -------------------------- + + procedure Read_Standard_Output + (Self : in out Process'Class; + Data : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset) + is + use type Ada.Streams.Stream_Element_Offset; + use type Interfaces.C.size_t; + + Count : Interfaces.C.size_t; + begin + if Self.Status /= Running then + Last := Data'First - 1; + return; + end if; + + Count := Posix.read (Self.pipe (Stdout), Data, Data'Length); + + if Count = Interfaces.C.size_t'Last then + if Errno in Posix.EAGAIN | Posix.EINTR then + Last := Data'First - 1; + Monitor.Enqueue + ((Monitor.Watch_Pipe, Self'Unchecked_Access, Stdout)); + else + raise Program_Error with + "read error: " & GNAT.OS_Lib.Errno_Message; + end if; + else + Last := Data'First + Ada.Streams.Stream_Element_Offset (Count) - 1; + end if; + end Read_Standard_Output; + + ----------- + -- Start -- + ----------- + + procedure Start (Self : in out Process'Class) is + begin + Self.Status := Starting; + Self.Exit_Code := -1; + Monitor.Enqueue ((Monitor.Start, Self'Unchecked_Access)); + end Start; + + ----------------------- + -- Terminate_Process -- + ----------------------- + + procedure Terminate_Process (Self : in out Process'Class) is + use type Interfaces.C.int; + + Code : constant Interfaces.C.int := + Spawn.Posix.kill + (Self.pid, Interfaces.C.int (System.OS_Interface.SIGTERM)); + begin + pragma Assert (Code = 0); + end Terminate_Process; + + -------------------------- + -- Write_Standard_Input -- + -------------------------- + + procedure Write_Standard_Input + (Self : in out Process'Class; + Data : Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset) + is + use type Ada.Streams.Stream_Element_Offset; + use type Interfaces.C.size_t; + + Count : Interfaces.C.size_t; + + begin + if Self.Status /= Running then + Last := Data'First - 1; + return; + end if; + + Count := Posix.write (Self.pipe (Stdin), Data, Data'Length); + Last := Data'First - 1; + + if Count = Interfaces.C.size_t'Last then + if Errno not in Posix.EAGAIN | Posix.EINTR then + raise Program_Error with + "write error: " & GNAT.OS_Lib.Errno_Message; + end if; + + else + Last := Data'First + Ada.Streams.Stream_Element_Offset (Count) - 1; + end if; + + if Count /= Data'Length then + Monitor.Enqueue + ((Monitor.Watch_Pipe, Self'Unchecked_Access, Stdin)); + end if; + end Write_Standard_Input; + end Spawn.Internal; diff --git a/source/spawn/spawn-internal__posix.ads b/source/spawn/spawn-internal__posix.ads index 0b459a7..cafa2e6 100644 --- a/source/spawn/spawn-internal__posix.ads +++ b/source/spawn/spawn-internal__posix.ads @@ -4,9 +4,13 @@ -- SPDX-License-Identifier: Apache-2.0 -- -with Ada.Finalization; +-- Process implementation for POSIX without Glib integration. + +with Ada.Streams; with Interfaces.C; +with Spawn.Common; + private package Spawn.Internal is package Environments is @@ -16,7 +20,10 @@ private package Spawn.Internal is end Environments; - type Pipe_Kinds is (Stdin, Stdout, Stderr, Launch); + procedure Loop_Cycle (Timeout : Integer); + -- See Spawn.Internal.Monitor + + subtype Pipe_Kinds is Spawn.Common.Pipe_Kinds; type Pipe_Array is array (Pipe_Kinds) of Interfaces.C.int; -- File descriptors array @@ -24,23 +31,50 @@ private package Spawn.Internal is type Index_Array is array (Pipe_Kinds) of Natural; -- Index in poll for each descriptors array - type Process is - abstract new Ada.Finalization.Limited_Controlled with record + type Process is new Spawn.Common.Process with record pid : Interfaces.C.int := 0; pipe : Pipe_Array := (others => 0); Index : Index_Array := (others => 0); end record; + -- Process implementation type provides the same interface as + -- Spawn.Processes.Process type. - procedure Emit_Stdin_Available (Self : in out Process) is abstract; + overriding procedure Finalize (Self : in out Process); - procedure Emit_Stdout_Available (Self : in out Process) is abstract; + procedure Start (Self : in out Process'Class); + -- See documentation in Spawn.Processes. - procedure Emit_Stderr_Available (Self : in out Process) is abstract; + procedure Terminate_Process (Self : in out Process'Class); + -- See documentation in Spawn.Processes. - procedure Emit_Error_Occurred - (Self : in out Process; - Process_Error : Integer) is abstract; + procedure Kill_Process (Self : in out Process'Class); + -- See documentation in Spawn.Processes. - procedure On_Close_Channels (Self : in out Process) is null; + procedure Close_Standard_Input (Self : in out Process'Class); + -- 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); + -- 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); + -- 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); + -- See documentation in Spawn.Processes. end Spawn.Internal; diff --git a/source/spawn/spawn-internal__windows.adb b/source/spawn/spawn-internal__windows.adb index b67fe0d..13ac45d 100644 --- a/source/spawn/spawn-internal__windows.adb +++ b/source/spawn/spawn-internal__windows.adb @@ -1,5 +1,5 @@ -- --- Copyright (C) 2018-2019, AdaCore +-- Copyright (C) 2018-2022, AdaCore -- -- SPDX-License-Identifier: Apache-2.0 -- @@ -7,7 +7,12 @@ with Ada.Strings.UTF_Encoding.Wide_Strings; with Ada.Wide_Characters.Unicode; +with Spawn.Internal.Monitor; +with Spawn.Internal.Windows; + package body Spawn.Internal is + use type Ada.Streams.Stream_Element_Offset; + use all type Spawn.Common.Pipe_Kinds; package body Environments is @@ -46,4 +51,155 @@ package body Spawn.Internal is end Environments; + -------------------------- + -- Close_Standard_Error -- + -------------------------- + + procedure Close_Standard_Error (Self : in out Process'Class) is + begin + Monitor.Enqueue ((Monitor.Close_Pipe, Self'Unchecked_Access, Stderr)); + end Close_Standard_Error; + + -------------------------- + -- Close_Standard_Input -- + -------------------------- + + procedure Close_Standard_Input (Self : in out Process'Class) is + begin + Monitor.Enqueue ((Monitor.Close_Pipe, Self'Unchecked_Access, Stdin)); + end Close_Standard_Input; + + --------------------------- + -- Close_Standard_Output -- + --------------------------- + + procedure Close_Standard_Output (Self : in out Process'Class) is + begin + Monitor.Enqueue ((Monitor.Close_Pipe, Self'Unchecked_Access, Stdout)); + end Close_Standard_Output; + + -------------- + -- Finalize -- + -------------- + + overriding procedure Finalize (Self : in out Process) is + begin + if Self.Status = Running then + raise Program_Error; + end if; + end Finalize; + + ------------------ + -- Kill_Process -- + ------------------ + + procedure Kill_Process (Self : in out Process'Class) is + begin + Windows.Do_Kill_Process (Self); + end Kill_Process; + + ---------------- + -- Loop_Cycle -- + ---------------- + + procedure Loop_Cycle (Timeout : Integer) + renames Spawn.Internal.Monitor.Loop_Cycle; + + ------------------------- + -- Read_Standard_Error -- + ------------------------- + + procedure Read_Standard_Error + (Self : in out Process'Class; + Data : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset) + is + procedure 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; + return; + end if; + + Windows.Do_Read (Self, Data, Last, Stderr, On_No_Data'Access); + end Read_Standard_Error; + + -------------------------- + -- Read_Standard_Output -- + -------------------------- + + procedure Read_Standard_Output + (Self : in out Process'Class; + Data : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset) + is + procedure 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; + return; + end if; + + Windows.Do_Read (Self, Data, Last, Stdout, On_No_Data'Access); + end Read_Standard_Output; + + ----------- + -- Start -- + ----------- + + procedure Start (Self : in out Process'Class) is + begin + Self.Status := Starting; + Self.Exit_Code := -1; + Monitor.Enqueue ((Monitor.Start, Self'Unchecked_Access)); + end Start; + + ----------------------- + -- Terminate_Process -- + ----------------------- + + procedure Terminate_Process (Self : in out Process'Class) is + begin + Windows.Do_Terminate_Process (Self); + end Terminate_Process; + + -------------------------- + -- Write_Standard_Input -- + -------------------------- + + procedure Write_Standard_Input + (Self : in out Process'Class; + Data : Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset) + is + procedure On_No_Data; + + ---------------- + -- On_No_Data -- + ---------------- + + procedure On_No_Data is + begin + Monitor.Enqueue ((Monitor.Watch_Pipe, Self'Unchecked_Access, Stdin)); + end On_No_Data; + + begin + if Self.Status /= Running or Data'Length = 0 then + Last := Data'First - 1; + return; + end if; + + Windows.Do_Write (Self, Data, Last, On_No_Data'Access); + end Write_Standard_Input; + end Spawn.Internal; diff --git a/source/spawn/spawn-internal__windows.ads b/source/spawn/spawn-internal__windows.ads index bf2edcd..9c9ff64 100644 --- a/source/spawn/spawn-internal__windows.ads +++ b/source/spawn/spawn-internal__windows.ads @@ -12,8 +12,9 @@ pragma Warnings (Off); with System.Win32; pragma Warnings (On); -package Spawn.Internal is - pragma Preelaborate; +with Spawn.Common; + +private package Spawn.Internal is package Environments is function To_Key (Text : UTF_8_String) return Wide_String; @@ -22,9 +23,12 @@ package Spawn.Internal is function "<" (Left, Right : UTF_8_String) return Boolean; end Environments; + procedure Loop_Cycle (Timeout : Integer); + -- See Spawn.Internal.Monitor + type Process is tagged; - type Pipe_Kinds is (Stdin, Stdout, Stderr); + subtype Pipe_Kinds is Spawn.Common.Pipe_Kinds; Buffer_Size : constant Ada.Streams.Stream_Element_Count := 512; @@ -52,23 +56,50 @@ package Spawn.Internal is type Pipe_Array is array (Pipe_Kinds) of aliased Context; -- Context for each pipe kind - type Process is - abstract new Ada.Finalization.Limited_Controlled with record + type Process is new Spawn.Common.Process with record pid : aliased Windows_API.PROCESS_INFORMATION; pipe : Pipe_Array; Index : Natural := 0; end record; + -- Process implementation type provides the same interface as + -- Spawn.Processes.Process type. - procedure Emit_Stdin_Available (Self : in out Process) is abstract; + overriding procedure Finalize (Self : in out Process); - procedure Emit_Stdout_Available (Self : in out Process) is abstract; + procedure Start (Self : in out Process'Class); + -- See documentation in Spawn.Processes. - procedure Emit_Stderr_Available (Self : in out Process) is abstract; + procedure Terminate_Process (Self : in out Process'Class); + -- See documentation in Spawn.Processes. - procedure Emit_Error_Occurred - (Self : in out Process; - Process_Error : Integer) is abstract; + procedure Kill_Process (Self : in out Process'Class); + -- See documentation in Spawn.Processes. - procedure On_Close_Channels (Self : in out Process) is null; + procedure Close_Standard_Input (Self : in out Process'Class); + -- 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); + -- 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); + -- 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); + -- See documentation in Spawn.Processes. end Spawn.Internal; diff --git a/source/spawn/spawn-process_listeners.ads b/source/spawn/spawn-process_listeners.ads new file mode 100644 index 0000000..024cc1d --- /dev/null +++ b/source/spawn/spawn-process_listeners.ads @@ -0,0 +1,51 @@ +-- +-- Copyright (C) 2018-2022, AdaCore +-- +-- SPDX-License-Identifier: Apache-2.0 +-- + +with Ada.Exceptions; + +package Spawn.Process_Listeners is + pragma Preelaborate; + + type Process_Listener is limited interface; + -- A process status event listener. + type Process_Listener_Access is access all Process_Listener'Class; + + procedure Standard_Output_Available + (Self : in out Process_Listener) is null; + -- Called once when it's possible to read data again. + + procedure Standard_Error_Available + (Self : in out Process_Listener) is null; + -- Called once when it's possible to read data again. + + procedure Standard_Input_Available + (Self : in out Process_Listener) is null; + -- Called once when it's possible to write data again. + + procedure Started (Self : in out Process_Listener) is null; + -- Called when the process is started + + procedure Finished + (Self : in out Process_Listener; + Exit_Status : Process_Exit_Status; + Exit_Code : Process_Exit_Code) is null; + -- Called when the process finishes. Exit_Status is exit status of the + -- process. On normal exit, Exit_Code is the exit code of the process, + -- on crash its meaning depends on the operating system. For POSIX systems + -- it is number of signal when available, on Windows it is process exit + -- code. + + procedure Error_Occurred + (Self : in out Process_Listener; + Process_Error : Integer) is null; + + procedure Exception_Occurred + (Self : in out Process_Listener; + Occurrence : Ada.Exceptions.Exception_Occurrence) is null; + -- This will be called when an exception occurred in one of the + -- callbacks set in place + +end Spawn.Process_Listeners; diff --git a/source/spawn/spawn-processes-monitor_loop.adb b/source/spawn/spawn-processes-monitor_loop.adb index 04e18b7..be3568d 100644 --- a/source/spawn/spawn-processes-monitor_loop.adb +++ b/source/spawn/spawn-processes-monitor_loop.adb @@ -1,12 +1,12 @@ -- --- Copyright (C) 2018-2019, AdaCore +-- Copyright (C) 2018-2022, AdaCore -- -- SPDX-License-Identifier: Apache-2.0 -- -with Spawn.Processes.Monitor; +with Spawn.Internal; procedure Spawn.Processes.Monitor_Loop (Timeout : Integer) is begin - Spawn.Processes.Monitor.Loop_Cycle (Timeout); + Spawn.Internal.Loop_Cycle (Timeout); end Spawn.Processes.Monitor_Loop; diff --git a/source/spawn/spawn-processes-platform__posix.adb b/source/spawn/spawn-processes-platform__posix.adb deleted file mode 100644 index 6ccf742..0000000 --- a/source/spawn/spawn-processes-platform__posix.adb +++ /dev/null @@ -1,222 +0,0 @@ --- --- Copyright (C) 2018-2022, AdaCore --- --- SPDX-License-Identifier: Apache-2.0 --- - -with Spawn.Processes.Monitor; -with Spawn.Posix; -with GNAT.OS_Lib; - -pragma Warnings (Off, "internal GNAT unit"); -with System.OS_Interface; -pragma Warnings (On); - -with Interfaces.C; - -separate (Spawn.Processes) -package body Platform is - - function Errno return Interfaces.C.int; - -- return errno, number of last error - - -------------------------- - -- Close_Standard_Error -- - -------------------------- - - procedure Close_Standard_Error (Self : in out Process'Class) is - begin - Monitor.Enqueue ((Monitor.Close_Pipe, Self'Unchecked_Access, Stderr)); - end Close_Standard_Error; - - -------------------------- - -- Close_Standard_Input -- - -------------------------- - - procedure Close_Standard_Input (Self : in out Process'Class) is - begin - Monitor.Enqueue ((Monitor.Close_Pipe, Self'Unchecked_Access, Stdin)); - end Close_Standard_Input; - - --------------------------- - -- Close_Standard_Output -- - --------------------------- - - procedure Close_Standard_Output (Self : in out Process'Class) is - begin - Monitor.Enqueue ((Monitor.Close_Pipe, Self'Unchecked_Access, Stdout)); - end Close_Standard_Output; - - ----------- - -- Errno -- - ----------- - - function Errno return Interfaces.C.int is - begin - return Interfaces.C.int (GNAT.OS_Lib.Errno); - end Errno; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize - (Self : in out Process'Class; - Status : Process_Status) - is - pragma Unreferenced (Self); - begin - if Status = Running then - raise Program_Error; - end if; - end Finalize; - - ------------------ - -- Kill_Process -- - ------------------ - - procedure Kill_Process (Self : in out Process'Class) is - use type Interfaces.C.int; - - Code : constant Interfaces.C.int := - Spawn.Posix.kill - (Self.pid, Interfaces.C.int (System.OS_Interface.SIGKILL)); - begin - pragma Assert (Code = 0); - end Kill_Process; - - ------------------------- - -- Read_Standard_Error -- - ------------------------- - - procedure Read_Standard_Error - (Self : in out Process'Class; - Data : out Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset) - is - use type Ada.Streams.Stream_Element_Offset; - use type Interfaces.C.size_t; - - Count : Interfaces.C.size_t; - begin - if Self.Status /= Running then - Last := Data'First - 1; - return; - end if; - - Count := Posix.read (Self.pipe (Stderr), Data, Data'Length); - - if Count = Interfaces.C.size_t'Last then - if Errno in Posix.EAGAIN | Posix.EINTR then - Last := Data'First - 1; - Monitor.Enqueue - ((Monitor.Watch_Pipe, Self'Unchecked_Access, Stderr)); - else - raise Program_Error with - "read error: " & GNAT.OS_Lib.Errno_Message; - end if; - else - Last := Data'First + Ada.Streams.Stream_Element_Offset (Count) - 1; - end if; - end Read_Standard_Error; - - -------------------------- - -- Read_Standard_Output -- - -------------------------- - - procedure Read_Standard_Output - (Self : in out Process'Class; - Data : out Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset) - is - use type Ada.Streams.Stream_Element_Offset; - use type Interfaces.C.size_t; - - Count : Interfaces.C.size_t; - begin - if Self.Status /= Running then - Last := Data'First - 1; - return; - end if; - - Count := Posix.read (Self.pipe (Stdout), Data, Data'Length); - - if Count = Interfaces.C.size_t'Last then - if Errno in Posix.EAGAIN | Posix.EINTR then - Last := Data'First - 1; - Monitor.Enqueue - ((Monitor.Watch_Pipe, Self'Unchecked_Access, Stdout)); - else - raise Program_Error with - "read error: " & GNAT.OS_Lib.Errno_Message; - end if; - else - Last := Data'First + Ada.Streams.Stream_Element_Offset (Count) - 1; - end if; - end Read_Standard_Output; - - ----------- - -- Start -- - ----------- - - procedure Start (Self : in out Process'Class) is - begin - Self.Status := Starting; - Self.Exit_Code := -1; - Monitor.Enqueue ((Monitor.Start, Self'Unchecked_Access)); - end Start; - - ----------------------- - -- Terminate_Process -- - ----------------------- - - procedure Terminate_Process (Self : in out Process'Class) is - use type Interfaces.C.int; - - Code : constant Interfaces.C.int := - Spawn.Posix.kill - (Self.pid, Interfaces.C.int (System.OS_Interface.SIGTERM)); - begin - pragma Assert (Code = 0); - end Terminate_Process; - - -------------------------- - -- Write_Standard_Input -- - -------------------------- - - procedure Write_Standard_Input - (Self : in out Process'Class; - Data : Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset) - is - use type Ada.Streams.Stream_Element_Offset; - use type Interfaces.C.size_t; - - Count : Interfaces.C.size_t; - - begin - if Self.Status /= Running then - Last := Data'First - 1; - return; - end if; - - Count := Posix.write (Self.pipe (Stdin), Data, Data'Length); - Last := Data'First - 1; - - if Count = Interfaces.C.size_t'Last then - if Errno not in Posix.EAGAIN | Posix.EINTR then - raise Program_Error with - "write error: " & GNAT.OS_Lib.Errno_Message; - end if; - - else - Last := Data'First + Ada.Streams.Stream_Element_Offset (Count) - 1; - end if; - - if Count /= Data'Length then - Monitor.Enqueue - ((Monitor.Watch_Pipe, Self'Unchecked_Access, Stdin)); - end if; - end Write_Standard_Input; - -end Platform; diff --git a/source/spawn/spawn-processes-platform__windows.adb b/source/spawn/spawn-processes-platform__windows.adb deleted file mode 100644 index af3d2f9..0000000 --- a/source/spawn/spawn-processes-platform__windows.adb +++ /dev/null @@ -1,163 +0,0 @@ --- --- Copyright (C) 2018-2022, AdaCore --- --- SPDX-License-Identifier: Apache-2.0 --- - -with Spawn.Processes.Monitor; -with Spawn.Processes.Windows; - -separate (Spawn.Processes) -package body Platform is - - use type Ada.Streams.Stream_Element_Offset; - - -------------------------- - -- Close_Standard_Error -- - -------------------------- - - procedure Close_Standard_Error (Self : in out Process'Class) is - begin - Monitor.Enqueue ((Monitor.Close_Pipe, Self'Unchecked_Access, Stderr)); - end Close_Standard_Error; - - -------------------------- - -- Close_Standard_Input -- - -------------------------- - - procedure Close_Standard_Input (Self : in out Process'Class) is - begin - Monitor.Enqueue ((Monitor.Close_Pipe, Self'Unchecked_Access, Stdin)); - end Close_Standard_Input; - - --------------------------- - -- Close_Standard_Output -- - --------------------------- - - procedure Close_Standard_Output (Self : in out Process'Class) is - begin - Monitor.Enqueue ((Monitor.Close_Pipe, Self'Unchecked_Access, Stdout)); - end Close_Standard_Output; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize - (Self : in out Process'Class; - Status : Process_Status) - is - pragma Unreferenced (Self); - begin - if Status = Running then - raise Program_Error; - end if; - end Finalize; - - ------------------ - -- Kill_Process -- - ------------------ - - procedure Kill_Process (Self : in out Process'Class) is - begin - Windows.Do_Kill_Process (Self); - end Kill_Process; - - ------------------------- - -- Read_Standard_Error -- - ------------------------- - - procedure Read_Standard_Error - (Self : in out Process'Class; - Data : out Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset) - is - procedure 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; - return; - end if; - - Windows.Do_Read (Self, Data, Last, Stderr, On_No_Data'Access); - end Read_Standard_Error; - - -------------------------- - -- Read_Standard_Output -- - -------------------------- - - procedure Read_Standard_Output - (Self : in out Process'Class; - Data : out Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset) - is - procedure 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; - return; - end if; - - Windows.Do_Read (Self, Data, Last, Stdout, On_No_Data'Access); - end Read_Standard_Output; - - ----------- - -- Start -- - ----------- - - procedure Start (Self : in out Process'Class) is - begin - Self.Status := Starting; - Self.Exit_Code := -1; - Monitor.Enqueue ((Monitor.Start, Self'Unchecked_Access)); - end Start; - - ----------------------- - -- Terminate_Process -- - ----------------------- - - procedure Terminate_Process (Self : in out Process'Class) is - begin - Windows.Do_Terminate_Process (Self); - end Terminate_Process; - - -------------------------- - -- Write_Standard_Input -- - -------------------------- - - procedure Write_Standard_Input - (Self : in out Process'Class; - Data : Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset) - is - procedure On_No_Data; - - ---------------- - -- On_No_Data -- - ---------------- - - procedure On_No_Data is - begin - Monitor.Enqueue ((Monitor.Watch_Pipe, Self'Unchecked_Access, Stdin)); - end On_No_Data; - - begin - if Self.Status /= Running or Data'Length = 0 then - Last := Data'First - 1; - return; - end if; - - Windows.Do_Write (Self, Data, Last, On_No_Data'Access); - end Write_Standard_Input; - -end Platform; diff --git a/source/spawn/spawn-processes.adb b/source/spawn/spawn-processes.adb index c473f7c..153f46e 100644 --- a/source/spawn/spawn-processes.adb +++ b/source/spawn/spawn-processes.adb @@ -6,164 +6,32 @@ package body Spawn.Processes is - package Platform is - - procedure Close_Standard_Error (Self : in out Process'Class); - - procedure Close_Standard_Input (Self : in out Process'Class); - - procedure Close_Standard_Output (Self : in out Process'Class); - - procedure Finalize - (Self : in out Process'Class; - Status : Process_Status); - - procedure Kill_Process (Self : in out Process'Class); - - procedure Read_Standard_Error - (Self : in out Process'Class; - Data : out Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset); - - procedure Read_Standard_Output - (Self : in out Process'Class; - Data : out Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset); - - procedure Start (Self : in out Process'Class); - - procedure Terminate_Process (Self : in out Process'Class); - - procedure Write_Standard_Input - (Self : in out Process'Class; - Data : Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset); - - end Platform; - - --------------- - -- Arguments -- - --------------- - - function Arguments - (Self : Process'Class) - return Spawn.String_Vectors.UTF_8_String_Vector is - begin - return Self.Arguments; - end Arguments; - -------------------------- -- Close_Standard_Error -- -------------------------- - procedure Close_Standard_Error (Self : in out Process'Class) - renames Platform.Close_Standard_Error; + procedure Close_Standard_Error (Self : in out Process'Class) is + begin + Self.Interal.Close_Standard_Error; + end Close_Standard_Error; -------------------------- -- Close_Standard_Input -- -------------------------- - procedure Close_Standard_Input (Self : in out Process'Class) - renames Platform.Close_Standard_Input; + procedure Close_Standard_Input (Self : in out Process'Class) is + begin + Self.Interal.Close_Standard_Input; + end Close_Standard_Input; --------------------------- -- Close_Standard_Output -- --------------------------- - procedure Close_Standard_Output (Self : in out Process'Class) - renames Platform.Close_Standard_Output; - - ------------------------- - -- Emit_Error_Occurred -- - ------------------------- - - overriding procedure Emit_Error_Occurred - (Self : in out Process; - Error : Integer) is + procedure Close_Standard_Output (Self : in out Process'Class) is begin - Self.Listener.Error_Occurred (Error); - - exception - when others => - null; - end Emit_Error_Occurred; - - --------------------------- - -- Emit_Stderr_Available -- - --------------------------- - - overriding procedure Emit_Stderr_Available (Self : in out Process) is - begin - Self.Listener.Standard_Error_Available; - - exception - when others => - null; - end Emit_Stderr_Available; - - -------------------------- - -- Emit_Stdin_Available -- - -------------------------- - - overriding procedure Emit_Stdin_Available (Self : in out Process) is - begin - Self.Listener.Standard_Input_Available; - - exception - when others => - null; - end Emit_Stdin_Available; - - --------------------------- - -- Emit_Stdout_Available -- - --------------------------- - - overriding procedure Emit_Stdout_Available (Self : in out Process) is - begin - Self.Listener.Standard_Output_Available; - - exception - when others => - null; - end Emit_Stdout_Available; - - ----------------- - -- Environment -- - ----------------- - - function Environment - (Self : Process'Class) - return Spawn.Environments.Process_Environment is - begin - return Self.Environment; - end Environment; - - --------------- - -- Exit_Code -- - --------------- - - function Exit_Code (Self : Process'Class) return Process_Exit_Code is - begin - return Self.Exit_Code; - end Exit_Code; - - ----------------- - -- Exit_Status -- - ----------------- - - function Exit_Status (Self : Process'Class) return Process_Exit_Status is - begin - return Self.Exit_Status; - end Exit_Status; - - -------------- - -- Finalize -- - -------------- - - overriding procedure Finalize (Self : in out Process) is - begin - Platform.Finalize (Self, Self.Status); - end Finalize; + Self.Interal.Close_Standard_Output; + end Close_Standard_Output; ------------------ -- Kill_Process -- @@ -171,54 +39,9 @@ package body Spawn.Processes is procedure Kill_Process (Self : in out Process'Class) is begin - if Self.Status = Running then - Platform.Kill_Process (Self); - end if; + Self.Interal.Kill_Process; end Kill_Process; - -------------- - -- Listener -- - -------------- - - function Listener (Self : Process'Class) return Process_Listener_Access is - begin - return Self.Listener; - end Listener; - - -------------- - -- Platform -- - -------------- - - package body Platform is separate; - - ----------------------- - -- On_Close_Channels -- - ----------------------- - - overriding procedure On_Close_Channels (Self : in out Process) is - begin - if Self.Pending_Finish then - Self.Pending_Finish := False; - - begin - Self.Listener.Finished (Self.Exit_Status, Self.Exit_Code); - - exception - when others => - null; - end; - end if; - end On_Close_Channels; - - ------------- - -- Program -- - ------------- - - function Program (Self : Process'Class) return UTF_8_String is - begin - return Ada.Strings.Unbounded.To_String (Self.Program); - end Program; - ------------------------- -- Read_Standard_Error -- ------------------------- @@ -226,8 +49,10 @@ 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) - renames Platform.Read_Standard_Error; + Last : out Ada.Streams.Stream_Element_Offset) is + begin + Self.Interal.Read_Standard_Error (Data, Last); + end Read_Standard_Error; -------------------------- -- Read_Standard_Output -- @@ -236,8 +61,10 @@ 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) - renames Platform.Read_Standard_Output; + Last : out Ada.Streams.Stream_Element_Offset) is + begin + Self.Interal.Read_Standard_Output (Data, Last); + end Read_Standard_Output; ------------------- -- Set_Arguments -- @@ -247,7 +74,7 @@ package body Spawn.Processes is (Self : in out Process'Class; Arguments : Spawn.String_Vectors.UTF_8_String_Vector) is begin - Self.Arguments := Arguments; + Self.Interal.Set_Arguments (Arguments); end Set_Arguments; --------------------- @@ -258,7 +85,7 @@ package body Spawn.Processes is (Self : in out Process'Class; Environment : Spawn.Environments.Process_Environment) is begin - Self.Environment := Environment; + Self.Interal.Set_Environment (Environment); end Set_Environment; ------------------ @@ -267,10 +94,9 @@ package body Spawn.Processes is procedure Set_Listener (Self : in out Process'Class; - Listener : Process_Listener_Access) - is + Listener : Spawn.Process_Listeners.Process_Listener_Access) is begin - Self.Listener := Listener; + Self.Interal.Set_Listener (Listener); end Set_Listener; ----------------- @@ -281,7 +107,7 @@ package body Spawn.Processes is (Self : in out Process'Class; Program : UTF_8_String) is begin - Self.Program := Ada.Strings.Unbounded.To_Unbounded_String (Program); + Self.Interal.Set_Program (Program); end Set_Program; ---------------------------- @@ -290,7 +116,7 @@ package body Spawn.Processes is procedure Set_Standard_Error_PTY (Self : in out Process'Class) is begin - Self.Use_PTY (Stderr) := True; + Self.Interal.Set_Standard_Error_PTY; end Set_Standard_Error_PTY; ---------------------------- @@ -299,7 +125,7 @@ package body Spawn.Processes is procedure Set_Standard_Input_PTY (Self : in out Process'Class) is begin - Self.Use_PTY (Stdin) := True; + Self.Interal.Set_Standard_Input_PTY; end Set_Standard_Input_PTY; ----------------------------- @@ -308,7 +134,7 @@ package body Spawn.Processes is procedure Set_Standard_Output_PTY (Self : in out Process'Class) is begin - Self.Use_PTY (Stdout) := True; + Self.Interal.Set_Standard_Output_PTY; end Set_Standard_Output_PTY; --------------------------- @@ -316,27 +142,19 @@ package body Spawn.Processes is --------------------------- procedure Set_Working_Directory - (Self : in out Process'Class; - Directory : UTF_8_String) is + (Self : in out Process'Class; Directory : UTF_8_String) is begin - Self.Directory := Ada.Strings.Unbounded.To_Unbounded_String (Directory); + Self.Interal.Set_Working_Directory (Directory); end Set_Working_Directory; ----------- -- Start -- ----------- - procedure Start (Self : in out Process'Class) - renames Platform.Start; - - ------------ - -- Status -- - ------------ - - function Status (Self : Process'Class) return Process_Status is + procedure Start (Self : in out Process'Class) is begin - return Self.Status; - end Status; + Self.Interal.Start; + end Start; ----------------------- -- Terminate_Process -- @@ -344,20 +162,9 @@ package body Spawn.Processes is procedure Terminate_Process (Self : in out Process'Class) is begin - if Self.Status = Running then - Platform.Terminate_Process (Self); - end if; + Self.Interal.Terminate_Process; end Terminate_Process; - ----------------------- - -- Working_Directory -- - ----------------------- - - function Working_Directory (Self : Process'Class) return UTF_8_String is - begin - return Ada.Strings.Unbounded.To_String (Self.Directory); - end Working_Directory; - -------------------------- -- Write_Standard_Input -- -------------------------- @@ -365,7 +172,9 @@ 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) - renames Platform.Write_Standard_Input; + Last : out Ada.Streams.Stream_Element_Offset) is + begin + Self.Interal.Write_Standard_Input (Data, Last); + end Write_Standard_Input; end Spawn.Processes; diff --git a/source/spawn/spawn-processes.ads b/source/spawn/spawn-processes.ads index c370474..e59842e 100644 --- a/source/spawn/spawn-processes.ads +++ b/source/spawn/spawn-processes.ads @@ -6,13 +6,11 @@ -- Asynchronous process control API with listener pattern -with Ada.Exceptions; with Ada.Streams; -with Ada.Strings.Unbounded; -with Interfaces; with Spawn.Environments; with Spawn.String_Vectors; +with Spawn.Process_Listeners; private with Spawn.Internal; @@ -42,69 +40,8 @@ package Spawn.Processes is -- read from and standard input stream to write. Corresponding events -- notify the listener when such calls are available. - type Process_Exit_Status is (Normal, Crash); - -- Process exit status - -- @value Normal The normal process termination case - -- @value Crash The abnormal process termination case - - type Process_Exit_Code is new Interfaces.Unsigned_32; - -- Exit status reported by the child process on normal exit. - -- For crash the meaning depends on the OS. - - type Process_Listener is limited interface; - -- A process status event listener. - type Process_Listener_Access is access all Process_Listener'Class; - - procedure Standard_Output_Available - (Self : in out Process_Listener) is null; - -- Called once when it's possible to read data again. - - procedure Standard_Error_Available - (Self : in out Process_Listener) is null; - -- Called once when it's possible to read data again. - - procedure Standard_Input_Available - (Self : in out Process_Listener) is null; - -- Called once when it's possible to write data again. - - procedure Started (Self : in out Process_Listener) is null; - -- Called when the process is started - - procedure Finished - (Self : in out Process_Listener; - Exit_Status : Process_Exit_Status; - Exit_Code : Process_Exit_Code) is null; - -- Called when the process finishes. Exit_Status is exit status of the - -- process. On normal exit, Exit_Code is the exit code of the process, - -- on crash its meaning depends on the operating system. For POSIX systems - -- it is number of signal when available, on Windows it is process exit - -- code. - - procedure Error_Occurred - (Self : in out Process_Listener; - Process_Error : Integer) is null; - - procedure Exception_Occurred - (Self : in out Process_Listener; - Occurrence : Ada.Exceptions.Exception_Occurrence) is null; - -- This will be called when an exception occurred in one of the - -- callbacks set in place - type Process_Error is (Failed_To_Start); - type Process_Status is - (Not_Running, - Starting, - Running); - -- Current process status. - -- - -- @value Not_Running The process has not been started yet or has been - -- exited/crashed already. Call Start to run it. - -- - -- @value Starting The process is launching, but it isn't run yet. - -- - -- @value Running The process is running. - function Arguments (Self : Process'Class) return Spawn.String_Vectors.UTF_8_String_Vector; procedure Set_Arguments @@ -179,10 +116,12 @@ package Spawn.Processes is -- On Windows, TerminateProcess() is called, and on POSIX, the SIGKILL -- signal is sent. - function Listener (Self : Process'Class) return Process_Listener_Access; + function Listener (Self : Process'Class) + return Spawn.Process_Listeners.Process_Listener_Access; + procedure Set_Listener (Self : in out Process'Class; - Listener : Process_Listener_Access) + Listener : Spawn.Process_Listeners.Process_Listener_Access) with Pre => Self.Status = Not_Running; -- Associate a Listener to this event. There may be either zero or one -- listener associated to each Process. @@ -239,46 +178,44 @@ package Spawn.Processes is -- data was read, the Standard_Error_Available notification will be -- emitted later. + -- For compatibility with older API: + subtype Process_Listener is Spawn.Process_Listeners.Process_Listener; + subtype Process_Exit_Code is Spawn.Process_Exit_Code; + subtype Process_Exit_Status is Spawn.Process_Exit_Status; + subtype Process_Status is Spawn.Process_Status; + private - use all type Internal.Pipe_Kinds; - subtype Pipe_Kinds is Internal.Pipe_Kinds; - subtype Standard_Pipe is Pipe_Kinds range Stdin .. Stderr; - - type Pipe_Flags is array (Standard_Pipe) of Boolean; - - type Process is new Spawn.Internal.Process with record - Arguments : Spawn.String_Vectors.UTF_8_String_Vector; - Environment : Spawn.Environments.Process_Environment := - Spawn.Environments.System_Environment; - Exit_Status : Process_Exit_Status := Normal; - Exit_Code : Process_Exit_Code := Process_Exit_Code'Last; - Status : Process_Status := Not_Running; - - Listener : Process_Listener_Access; - -- The associated listener. Note: this may be null. - - Program : Ada.Strings.Unbounded.Unbounded_String; - Directory : Ada.Strings.Unbounded.Unbounded_String; - Use_PTY : Pipe_Flags := (others => False); - - Pending_Finish : Boolean := False; - -- We have got pid closed but channels are still active. - -- In this case delay Finished callback until channels are closed. + type Process is tagged limited record + Interal : Spawn.Internal.Process; end record; - overriding procedure Finalize (Self : in out Process); + function Arguments (Self : Process'Class) + return Spawn.String_Vectors.UTF_8_String_Vector is + (Self.Interal.Arguments); - overriding procedure Emit_Stdin_Available (Self : in out Process); + function Environment (Self : Process'Class) + return Spawn.Environments.Process_Environment is + (Self.Interal.Environment); - overriding procedure Emit_Stdout_Available (Self : in out Process); + function Working_Directory (Self : Process'Class) return UTF_8_String is + (Self.Interal.Working_Directory); - overriding procedure Emit_Stderr_Available (Self : in out Process); + function Program (Self : Process'Class) return UTF_8_String is + (Self.Interal.Program); - overriding procedure Emit_Error_Occurred - (Self : in out Process; - Error : Integer); + function Status (Self : Process'Class) return Process_Status is + (Self.Interal.Status); - overriding procedure On_Close_Channels (Self : in out Process); + function Exit_Status (Self : Process'Class) return Process_Exit_Status is + (Self.Interal.Exit_Status); + -- Return the exit status of last process that finishes. + + function Exit_Code (Self : Process'Class) return Process_Exit_Code is + (Self.Interal.Exit_Code); + + function Listener (Self : Process'Class) + return Spawn.Process_Listeners.Process_Listener_Access is + (Self.Interal.Listener); end Spawn.Processes; diff --git a/source/spawn/spawn.ads b/source/spawn/spawn.ads index 161bcf8..e9a5811 100644 --- a/source/spawn/spawn.ads +++ b/source/spawn/spawn.ads @@ -1,14 +1,37 @@ -- --- Copyright (C) 2018-2019, AdaCore +-- Copyright (C) 2018-2022, AdaCore -- -- SPDX-License-Identifier: Apache-2.0 -- with Ada.Strings.UTF_Encoding; +with Interfaces; package Spawn is pragma Pure; subtype UTF_8_String is Ada.Strings.UTF_Encoding.UTF_8_String; + type Process_Status is + (Not_Running, + Starting, + Running); + -- Current process status. + -- + -- @value Not_Running The process has not been started yet or has been + -- exited/crashed already. Call Start to run it. + -- + -- @value Starting The process is launching, but it isn't run yet. + -- + -- @value Running The process is running. + + type Process_Exit_Status is (Normal, Crash); + -- Process exit status + -- @value Normal The normal process termination case + -- @value Crash The abnormal process termination case + + type Process_Exit_Code is new Interfaces.Unsigned_32; + -- Exit status reported by the child process on normal exit. + -- For crash the meaning depends on the OS. + end Spawn;