diff --git a/Makefile b/Makefile index 9b6569a..32b9c1d 100644 --- a/Makefile +++ b/Makefile @@ -13,6 +13,10 @@ GPRINSTALL_FLAGS = --prefix=$(PREFIX) --sources-subdir=$(INSTALL_INCLUDE_DIR)\ SPAWN_TESTS=.obj/spawn_test/spawn_test .obj/spawn_test/spawn_unexpected +ifneq ($(OS),Windows_NT) + SPAWN_TESTS += .obj/spawn_test/spawn_kill +endif + all: gprbuild $(GPRBUILD_FLAGS) -P gnat/spawn.gpr gprbuild $(GPRBUILD_FLAGS) -P gnat/spawn_tests.gpr diff --git a/gnat/spawn_tests.gpr b/gnat/spawn_tests.gpr index 3b1f713..9f30c61 100644 --- a/gnat/spawn_tests.gpr +++ b/gnat/spawn_tests.gpr @@ -1,7 +1,7 @@ ------------------------------------------------------------------------------ -- Language Server Protocol -- -- -- --- Copyright (C) 2018, AdaCore -- +-- Copyright (C) 2018-2021, AdaCore -- -- -- -- This is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -23,9 +23,19 @@ with "spawn"; project Spawn_Tests is + Main := ("spawn_test.adb", "spawn_unexpected.adb"); + + case Spawn.OS_API is + when "unix" | "osx" => + Main := Main & ("spawn_kill.adb"); + + when "Windows_NT" => + null; + end case; + for Source_Dirs use ("../testsuite/spawn"); for Object_Dir use "../.obj/spawn_test"; - for Main use ("spawn_test.adb", "spawn_unexpected.adb"); + for Main use Main; package Compiler renames Spawn.Compiler; @@ -34,4 +44,3 @@ project Spawn_Tests is end Binder; end Spawn_Tests; - diff --git a/source/spawn/spawn-posix.ads b/source/spawn/spawn-posix.ads index 641c64c..11bde4d 100644 --- a/source/spawn/spawn-posix.ads +++ b/source/spawn/spawn-posix.ads @@ -1,7 +1,7 @@ ------------------------------------------------------------------------------ -- Language Server Protocol -- -- -- --- Copyright (C) 2018-2019, AdaCore -- +-- Copyright (C) 2018-2021, AdaCore -- -- -- -- This is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -62,6 +62,11 @@ package Spawn.Posix is function fork return Interfaces.C.int with Import, Convention => C, External_Name => "fork"; + function kill + (pid : Interfaces.C.int; + sig : Interfaces.C.int) return Interfaces.C.int + with Import, Convention => C, External_Name => "kill"; + function dup2 (oldfd : Interfaces.C.int; newfd : Interfaces.C.int) diff --git a/source/spawn/spawn-processes__glib.adb b/source/spawn/spawn-processes__glib.adb index 58877b5..b50d269 100644 --- a/source/spawn/spawn-processes__glib.adb +++ b/source/spawn/spawn-processes__glib.adb @@ -19,9 +19,11 @@ -- version 3.1, as published by the Free Software Foundation. -- ------------------------------------------------------------------------------ +with Ada.Interrupts.Names; with Interfaces.C; with Spawn.Environments.Internal; +with Spawn.Posix; with Glib.Error; with Glib.IOChannel; @@ -360,8 +362,13 @@ package body Spawn.Processes 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 (Ada.Interrupts.Names.SIGKILL)); begin - raise Program_Error; + pragma Assert (Code = 0); end Kill_Process; -------------- @@ -602,8 +609,13 @@ package body Spawn.Processes 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 (Ada.Interrupts.Names.SIGTERM)); begin - raise Program_Error; + pragma Assert (Code = 0); end Terminate_Process; ----------------------- diff --git a/source/spawn/spawn-processes__posix.adb b/source/spawn/spawn-processes__posix.adb index cefd503..27a7ea5 100644 --- a/source/spawn/spawn-processes__posix.adb +++ b/source/spawn/spawn-processes__posix.adb @@ -22,6 +22,7 @@ with Spawn.Processes.Monitor; with Spawn.Posix; with GNAT.OS_Lib; +with Ada.Interrupts.Names; with Interfaces.C; @@ -121,8 +122,13 @@ package body Spawn.Processes is ------------------ 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 (Ada.Interrupts.Names.SIGKILL)); begin - raise Program_Error; + pragma Assert (Code = 0); end Kill_Process; -------------- @@ -294,8 +300,13 @@ package body Spawn.Processes is ----------------------- 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 (Ada.Interrupts.Names.SIGTERM)); begin - raise Program_Error; + pragma Assert (Code = 0); end Terminate_Process; ----------------------- diff --git a/testsuite/spawn/signals.adb b/testsuite/spawn/signals.adb new file mode 100644 index 0000000..e4536cf --- /dev/null +++ b/testsuite/spawn/signals.adb @@ -0,0 +1,22 @@ +with Ada.Text_IO; + +package body Signals is + + -------------------- + -- Signal_Handler -- + -------------------- + + protected body Signal_Handler is + + -------------------- + -- On_Term_Signal -- + -------------------- + + procedure On_Term_Signal is + begin + Ada.Text_IO.Put_Line ("Got TERM"); + end On_Term_Signal; + + end Signal_Handler; + +end Signals; diff --git a/testsuite/spawn/signals.ads b/testsuite/spawn/signals.ads new file mode 100644 index 0000000..1a6271b --- /dev/null +++ b/testsuite/spawn/signals.ads @@ -0,0 +1,14 @@ +with Ada.Interrupts.Names; + +package Signals is + + pragma Unreserve_All_Interrupts; + + protected Signal_Handler is + + procedure On_Term_Signal; + + pragma Attach_Handler (On_Term_Signal, Ada.Interrupts.Names.SIGTERM); + + end Signal_Handler; +end Signals; diff --git a/testsuite/spawn/spawn_glib_args_test.adb b/testsuite/spawn/spawn_glib_args_test.adb index 5270864..57de8e4 100644 --- a/testsuite/spawn/spawn_glib_args_test.adb +++ b/testsuite/spawn/spawn_glib_args_test.adb @@ -1,7 +1,7 @@ ------------------------------------------------------------------------------ -- Language Server Protocol -- -- -- --- Copyright (C) 2020, AdaCore -- +-- Copyright (C) 2020-2021, AdaCore -- -- -- -- This is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -44,8 +44,9 @@ procedure Spawn_Glib_Args_Test is (Self : in out Listener); overriding procedure Finished - (Self : in out Listener; - Exit_Code : Integer); + (Self : in out Listener; + Exit_Status : Spawn.Processes.Process_Exit_Status; + Exit_Code : Spawn.Processes.Process_Exit_Code); overriding procedure Error_Occurred (Self : in out Listener; @@ -75,8 +76,9 @@ procedure Spawn_Glib_Args_Test is -------------- overriding procedure Finished - (Self : in out Listener; - Exit_Code : Integer) is + (Self : in out Listener; + Exit_Status : Spawn.Processes.Process_Exit_Status; + Exit_Code : Spawn.Processes.Process_Exit_Code) is begin Ada.Text_IO.Put_Line ("Finished" & (Exit_Code'Img)); Self.App.Release; @@ -107,8 +109,6 @@ procedure Spawn_Glib_Args_Test is overriding procedure Standard_Output_Available (Self : in out Listener) is - use type Ada.Streams.Stream_Element_Offset; - Data : Ada.Streams.Stream_Element_Array (1 .. 256); Last : Ada.Streams.Stream_Element_Count; diff --git a/testsuite/spawn/spawn_glib_test.adb b/testsuite/spawn/spawn_glib_test.adb index ee48416..159e936 100644 --- a/testsuite/spawn/spawn_glib_test.adb +++ b/testsuite/spawn/spawn_glib_test.adb @@ -1,7 +1,7 @@ ------------------------------------------------------------------------------ -- Language Server Protocol -- -- -- --- Copyright (C) 2018, AdaCore -- +-- Copyright (C) 2018-2021, AdaCore -- -- -- -- This is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -51,8 +51,9 @@ procedure Spawn_Glib_Test is overriding procedure Started (Self : in out Listener); overriding procedure Finished - (Self : in out Listener; - Exit_Code : Integer); + (Self : in out Listener; + Exit_Status : Spawn.Processes.Process_Exit_Status; + Exit_Code : Spawn.Processes.Process_Exit_Code); overriding procedure Error_Occurred (Self : in out Listener; @@ -121,8 +122,9 @@ procedure Spawn_Glib_Test is end Started; overriding procedure Finished - (Self : in out Listener; - Exit_Code : Integer) is + (Self : in out Listener; + Exit_Status : Spawn.Processes.Process_Exit_Status; + Exit_Code : Spawn.Processes.Process_Exit_Code) is begin Ada.Text_IO.Put_Line ("Finished" & (Exit_Code'Img)); Self.Stopped := True; diff --git a/testsuite/spawn/spawn_kill.adb b/testsuite/spawn/spawn_kill.adb new file mode 100644 index 0000000..84f7d13 --- /dev/null +++ b/testsuite/spawn/spawn_kill.adb @@ -0,0 +1,179 @@ +with Ada.Command_Line; +with Ada.Directories; +with Ada.Streams; +with Ada.Strings.Unbounded; +with Ada.Text_IO; + +with Spawn.String_Vectors; +with Spawn.Processes; +with Spawn.Processes.Monitor_Loop; + +with Signals; +pragma Unreferenced (Signals); + +procedure Spawn_Kill is + pragma Assertion_Policy (Check); + + package Listeners is + type Listener is limited new Spawn.Processes.Process_Listener with record + Proc : Spawn.Processes.Process; + Stdout : Ada.Strings.Unbounded.Unbounded_String; + Stderr : Ada.Strings.Unbounded.Unbounded_String; + Started : Boolean := False; + Stopped : Boolean := False; + Error : Integer := 0; + end record; + + overriding procedure Standard_Output_Available + (Self : in out Listener); + + overriding procedure Standard_Error_Available + (Self : in out Listener); + + overriding procedure Started (Self : in out Listener); + + overriding procedure Finished + (Self : in out Listener; + Exit_Status : Spawn.Processes.Process_Exit_Status; + Exit_Code : Spawn.Processes.Process_Exit_Code); + + overriding procedure Error_Occurred + (Self : in out Listener; + Process_Error : Integer); + + end Listeners; + + package body Listeners is + + overriding procedure Standard_Output_Available + (Self : in out Listener) + is + use type Ada.Streams.Stream_Element_Count; + begin + loop + declare + Data : Ada.Streams.Stream_Element_Array (1 .. 5); + Last : Ada.Streams.Stream_Element_Count; + begin + Self.Proc.Read_Standard_Output (Data, Last); + + exit when Last < Data'First; + + for Char of Data (1 .. Last) loop + if Char not in 16#0D# | 16#0A# then + Ada.Strings.Unbounded.Append + (Self.Stdout, Character'Val (Char)); + end if; + end loop; + end; + end loop; + end Standard_Output_Available; + + overriding procedure Standard_Error_Available + (Self : in out Listener) + is + use type Ada.Streams.Stream_Element_Count; + begin + loop + declare + Data : Ada.Streams.Stream_Element_Array (1 .. 5); + Last : Ada.Streams.Stream_Element_Count; + begin + Self.Proc.Read_Standard_Error (Data, Last); + + exit when Last < Data'First; + + for Char of Data (1 .. Last) loop + if Char not in 16#0D# | 16#0A# then + Ada.Strings.Unbounded.Append + (Self.Stderr, Character'Val (Char)); + end if; + end loop; + end; + end loop; + + Self.Proc.Close_Standard_Input; + end Standard_Error_Available; + + overriding procedure Started (Self : in out Listener) is + begin + Self.Started := True; + end Started; + + overriding procedure Finished + (Self : in out Listener; + Exit_Status : Spawn.Processes.Process_Exit_Status; + Exit_Code : Spawn.Processes.Process_Exit_Code) + is + use type Spawn.Processes.Process_Exit_Code; + + begin + if Exit_Code /= 9 then + Ada.Text_IO.Put_Line ("Unexpected exit code" & (Exit_Code'Img)); + Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure); + end if; + + Self.Stopped := True; + end Finished; + + overriding procedure Error_Occurred + (Self : in out Listener; + Process_Error : Integer) + is + pragma Unreferenced (Self); + begin + Ada.Text_IO.Put_Line ("Error_Occurred:" & (Process_Error'Img)); + Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure); + + Self.Stopped := True; + Self.Error := Process_Error; + end Error_Occurred; + + end Listeners; + + Command : constant String := Ada.Directories.Full_Name + (Ada.Command_Line.Command_Name); + Args : Spawn.String_Vectors.UTF_8_String_Vector; + L : aliased Listeners.Listener; +begin + if Ada.Command_Line.Argument_Count > 0 then + Ada.Text_IO.Put_Line (Ada.Text_IO.Get_Line); + + return; + end if; + + -- Otherwise launch a driven process. + Args.Append ("Wait for signal"); + + L.Proc.Set_Program (Command); + L.Proc.Set_Arguments (Args); + L.Proc.Set_Working_Directory (Ada.Directories.Current_Directory); + L.Proc.Set_Listener (L'Unchecked_Access); + L.Proc.Start; + + while not L.Started loop + Spawn.Processes.Monitor_Loop (1); + end loop; + + L.Proc.Terminate_Process; + + while Ada.Strings.Unbounded.Length (L.Stdout) = 0 loop + Spawn.Processes.Monitor_Loop (1); + end loop; + + L.Proc.Kill_Process; + + while not L.Stopped loop + Spawn.Processes.Monitor_Loop (1); + end loop; + + declare + Stdout : constant String := Ada.Strings.Unbounded.To_String (L.Stdout); + Stderr : constant String := Ada.Strings.Unbounded.To_String (L.Stderr); + begin + pragma Assert (Stdout = "Got TERM"); + pragma Assert (Stderr = ""); + pragma Assert (L.Started); + pragma Assert (L.Error = 0); + end; +end Spawn_Kill; diff --git a/testsuite/spawn/spawn_test.adb b/testsuite/spawn/spawn_test.adb index dba1d5d..ea0e276 100644 --- a/testsuite/spawn/spawn_test.adb +++ b/testsuite/spawn/spawn_test.adb @@ -173,11 +173,11 @@ procedure Spawn_Test is (Self : in out Listener; Process_Error : Integer) is - pragma Unreferenced (Self); begin Ada.Text_IO.Put_Line ("Error_Occurred:" & (Process_Error'Img)); Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure); + Self.Error := Process_Error; Self.Stopped := True; end Error_Occurred;