------------------------------------------------------------------------------ -- -- -- GNAT LIBRARY COMPONENTS -- -- -- -- G N A T . E X P E C T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2000-2015, AdaCore -- -- -- -- GNAT 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- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ with System; use System; with System.OS_Constants; use System.OS_Constants; with Ada.Calendar; use Ada.Calendar; with GNAT.IO; use GNAT.IO; with GNAT.OS_Lib; use GNAT.OS_Lib; with GNAT.Regpat; use GNAT.Regpat; with Ada.Unchecked_Deallocation; package body GNAT.Expect is type Array_Of_Pd is array (Positive range <>) of Process_Descriptor_Access; Expect_Process_Died : constant Expect_Match := -100; Expect_Internal_Error : constant Expect_Match := -101; -- Additional possible outputs of Expect_Internal. These are not visible in -- the spec because the user will never see them. procedure Expect_Internal (Descriptors : in out Array_Of_Pd; Result : out Expect_Match; Timeout : Integer; Full_Buffer : Boolean); -- Internal function used to read from the process Descriptor. -- -- Several outputs are possible: -- Result=Expect_Timeout, if no output was available before the timeout -- expired. -- Result=Expect_Full_Buffer, if Full_Buffer is True and some characters -- had to be discarded from the internal buffer of Descriptor. -- Result=Express_Process_Died if one of the processes was terminated. -- That process's Input_Fd is set to Invalid_FD -- Result=Express_Internal_Error -- Result=, indicates how many characters were added to the -- internal buffer. These characters are from indexes -- Descriptor.Buffer_Index - Result + 1 .. Descriptor.Buffer_Index -- Process_Died is raised if the process is no longer valid. procedure Reinitialize_Buffer (Descriptor : in out Process_Descriptor'Class); -- Reinitialize the internal buffer. -- The buffer is deleted up to the end of the last match. procedure Free is new Ada.Unchecked_Deallocation (Pattern_Matcher, Pattern_Matcher_Access); procedure Free is new Ada.Unchecked_Deallocation (Filter_List_Elem, Filter_List); procedure Call_Filters (Pid : Process_Descriptor'Class; Str : String; Filter_On : Filter_Type); -- Call all the filters that have the appropriate type. -- This function does nothing if the filters are locked ------------------------------ -- Target dependent section -- ------------------------------ function Dup (Fd : File_Descriptor) return File_Descriptor; pragma Import (C, Dup); procedure Dup2 (Old_Fd, New_Fd : File_Descriptor); pragma Import (C, Dup2); procedure Kill (Pid : Process_Id; Sig_Num : Integer; Close : Integer); pragma Import (C, Kill, "__gnat_kill"); -- if Close is set to 1 all OS resources used by the Pid must be freed function Create_Pipe (Pipe : not null access Pipe_Type) return Integer; pragma Import (C, Create_Pipe, "__gnat_pipe"); function Poll (Fds : System.Address; Num_Fds : Integer; Timeout : Integer; Dead_Process : access Integer; Is_Set : System.Address) return Integer; pragma Import (C, Poll, "__gnat_expect_poll"); -- Check whether there is any data waiting on the file descriptors -- Fds, and wait if there is none, at most Timeout milliseconds -- Returns -1 in case of error, 0 if the timeout expired before -- data became available. -- -- Is_Set is an array of the same size as FDs and elements are set to 1 if -- data is available for the corresponding File Descriptor, 0 otherwise. -- -- If a process dies, then Dead_Process is set to the index of the -- corresponding file descriptor. function Waitpid (Pid : Process_Id) return Integer; pragma Import (C, Waitpid, "__gnat_waitpid"); -- Wait for a specific process id, and return its exit code --------- -- "+" -- --------- function "+" (S : String) return GNAT.OS_Lib.String_Access is begin return new String'(S); end "+"; --------- -- "+" -- --------- function "+" (P : GNAT.Regpat.Pattern_Matcher) return Pattern_Matcher_Access is begin return new GNAT.Regpat.Pattern_Matcher'(P); end "+"; ---------------- -- Add_Filter -- ---------------- procedure Add_Filter (Descriptor : in out Process_Descriptor; Filter : Filter_Function; Filter_On : Filter_Type := Output; User_Data : System.Address := System.Null_Address; After : Boolean := False) is Current : Filter_List := Descriptor.Filters; begin if After then while Current /= null and then Current.Next /= null loop Current := Current.Next; end loop; if Current = null then Descriptor.Filters := new Filter_List_Elem' (Filter => Filter, Filter_On => Filter_On, User_Data => User_Data, Next => null); else Current.Next := new Filter_List_Elem' (Filter => Filter, Filter_On => Filter_On, User_Data => User_Data, Next => null); end if; else Descriptor.Filters := new Filter_List_Elem' (Filter => Filter, Filter_On => Filter_On, User_Data => User_Data, Next => Descriptor.Filters); end if; end Add_Filter; ------------------ -- Call_Filters -- ------------------ procedure Call_Filters (Pid : Process_Descriptor'Class; Str : String; Filter_On : Filter_Type) is Current_Filter : Filter_List; begin if Pid.Filters_Lock = 0 then Current_Filter := Pid.Filters; while Current_Filter /= null loop if Current_Filter.Filter_On = Filter_On then Current_Filter.Filter (Pid, Str, Current_Filter.User_Data); end if; Current_Filter := Current_Filter.Next; end loop; end if; end Call_Filters; ----------- -- Close -- ----------- procedure Close (Descriptor : in out Process_Descriptor; Status : out Integer) is Current_Filter : Filter_List; Next_Filter : Filter_List; begin if Descriptor.Input_Fd /= Invalid_FD then Close (Descriptor.Input_Fd); end if; if Descriptor.Error_Fd /= Descriptor.Output_Fd then Close (Descriptor.Error_Fd); end if; Close (Descriptor.Output_Fd); -- ??? Should have timeouts for different signals if Descriptor.Pid > 0 then -- see comment in Send_Signal Kill (Descriptor.Pid, Sig_Num => 9, Close => 0); end if; GNAT.OS_Lib.Free (Descriptor.Buffer); Descriptor.Buffer_Size := 0; Current_Filter := Descriptor.Filters; while Current_Filter /= null loop Next_Filter := Current_Filter.Next; Free (Current_Filter); Current_Filter := Next_Filter; end loop; Descriptor.Filters := null; -- Check process id (see comment in Send_Signal) if Descriptor.Pid > 0 then Status := Waitpid (Descriptor.Pid); else raise Invalid_Process; end if; end Close; procedure Close (Descriptor : in out Process_Descriptor) is Status : Integer; pragma Unreferenced (Status); begin Close (Descriptor, Status); end Close; ------------ -- Expect -- ------------ procedure Expect (Descriptor : in out Process_Descriptor; Result : out Expect_Match; Regexp : String; Timeout : Integer := 10_000; Full_Buffer : Boolean := False) is begin if Regexp = "" then Expect (Descriptor, Result, Never_Match, Timeout, Full_Buffer); else Expect (Descriptor, Result, Compile (Regexp), Timeout, Full_Buffer); end if; end Expect; procedure Expect (Descriptor : in out Process_Descriptor; Result : out Expect_Match; Regexp : String; Matched : out GNAT.Regpat.Match_Array; Timeout : Integer := 10_000; Full_Buffer : Boolean := False) is begin pragma Assert (Matched'First = 0); if Regexp = "" then Expect (Descriptor, Result, Never_Match, Matched, Timeout, Full_Buffer); else Expect (Descriptor, Result, Compile (Regexp), Matched, Timeout, Full_Buffer); end if; end Expect; procedure Expect (Descriptor : in out Process_Descriptor; Result : out Expect_Match; Regexp : GNAT.Regpat.Pattern_Matcher; Timeout : Integer := 10_000; Full_Buffer : Boolean := False) is Matched : GNAT.Regpat.Match_Array (0 .. 0); pragma Warnings (Off, Matched); begin Expect (Descriptor, Result, Regexp, Matched, Timeout, Full_Buffer); end Expect; procedure Expect (Descriptor : in out Process_Descriptor; Result : out Expect_Match; Regexp : GNAT.Regpat.Pattern_Matcher; Matched : out GNAT.Regpat.Match_Array; Timeout : Integer := 10_000; Full_Buffer : Boolean := False) is N : Expect_Match; Descriptors : Array_Of_Pd := (1 => Descriptor'Unrestricted_Access); Try_Until : constant Time := Clock + Duration (Timeout) / 1000.0; Timeout_Tmp : Integer := Timeout; begin pragma Assert (Matched'First = 0); Reinitialize_Buffer (Descriptor); loop -- First, test if what is already in the buffer matches (This is -- required if this package is used in multi-task mode, since one of -- the tasks might have added something in the buffer, and we don't -- want other tasks to wait for new input to be available before -- checking the regexps). Match (Regexp, Descriptor.Buffer (1 .. Descriptor.Buffer_Index), Matched); if Descriptor.Buffer_Index >= 1 and then Matched (0).First /= 0 then Result := 1; Descriptor.Last_Match_Start := Matched (0).First; Descriptor.Last_Match_End := Matched (0).Last; return; end if; -- Else try to read new input Expect_Internal (Descriptors, N, Timeout_Tmp, Full_Buffer); case N is when Expect_Internal_Error | Expect_Process_Died => raise Process_Died; when Expect_Timeout | Expect_Full_Buffer => Result := N; return; when others => null; -- See below end case; -- Calculate the timeout for the next turn -- Note that Timeout is, from the caller's perspective, the maximum -- time until a match, not the maximum time until some output is -- read, and thus cannot be reused as is for Expect_Internal. if Timeout /= -1 then Timeout_Tmp := Integer (Try_Until - Clock) * 1000; if Timeout_Tmp < 0 then Result := Expect_Timeout; exit; end if; end if; end loop; -- Even if we had the general timeout above, we have to test that the -- last test we read from the external process didn't match. Match (Regexp, Descriptor.Buffer (1 .. Descriptor.Buffer_Index), Matched); if Matched (0).First /= 0 then Result := 1; Descriptor.Last_Match_Start := Matched (0).First; Descriptor.Last_Match_End := Matched (0).Last; return; end if; end Expect; procedure Expect (Descriptor : in out Process_Descriptor; Result : out Expect_Match; Regexps : Regexp_Array; Timeout : Integer := 10_000; Full_Buffer : Boolean := False) is Patterns : Compiled_Regexp_Array (Regexps'Range); Matched : GNAT.Regpat.Match_Array (0 .. 0); pragma Warnings (Off, Matched); begin for J in Regexps'Range loop Patterns (J) := new Pattern_Matcher'(Compile (Regexps (J).all)); end loop; Expect (Descriptor, Result, Patterns, Matched, Timeout, Full_Buffer); for J in Regexps'Range loop Free (Patterns (J)); end loop; end Expect; procedure Expect (Descriptor : in out Process_Descriptor; Result : out Expect_Match; Regexps : Compiled_Regexp_Array; Timeout : Integer := 10_000; Full_Buffer : Boolean := False) is Matched : GNAT.Regpat.Match_Array (0 .. 0); pragma Warnings (Off, Matched); begin Expect (Descriptor, Result, Regexps, Matched, Timeout, Full_Buffer); end Expect; procedure Expect (Result : out Expect_Match; Regexps : Multiprocess_Regexp_Array; Timeout : Integer := 10_000; Full_Buffer : Boolean := False) is Matched : GNAT.Regpat.Match_Array (0 .. 0); pragma Warnings (Off, Matched); begin Expect (Result, Regexps, Matched, Timeout, Full_Buffer); end Expect; procedure Expect (Descriptor : in out Process_Descriptor; Result : out Expect_Match; Regexps : Regexp_Array; Matched : out GNAT.Regpat.Match_Array; Timeout : Integer := 10_000; Full_Buffer : Boolean := False) is Patterns : Compiled_Regexp_Array (Regexps'Range); begin pragma Assert (Matched'First = 0); for J in Regexps'Range loop Patterns (J) := new Pattern_Matcher'(Compile (Regexps (J).all)); end loop; Expect (Descriptor, Result, Patterns, Matched, Timeout, Full_Buffer); for J in Regexps'Range loop Free (Patterns (J)); end loop; end Expect; procedure Expect (Descriptor : in out Process_Descriptor; Result : out Expect_Match; Regexps : Compiled_Regexp_Array; Matched : out GNAT.Regpat.Match_Array; Timeout : Integer := 10_000; Full_Buffer : Boolean := False) is N : Expect_Match; Descriptors : Array_Of_Pd := (1 => Descriptor'Unrestricted_Access); begin pragma Assert (Matched'First = 0); Reinitialize_Buffer (Descriptor); loop -- First, test if what is already in the buffer matches (This is -- required if this package is used in multi-task mode, since one of -- the tasks might have added something in the buffer, and we don't -- want other tasks to wait for new input to be available before -- checking the regexps). if Descriptor.Buffer /= null then for J in Regexps'Range loop Match (Regexps (J).all, Descriptor.Buffer (1 .. Descriptor.Buffer_Index), Matched); if Matched (0) /= No_Match then Result := Expect_Match (J); Descriptor.Last_Match_Start := Matched (0).First; Descriptor.Last_Match_End := Matched (0).Last; return; end if; end loop; end if; Expect_Internal (Descriptors, N, Timeout, Full_Buffer); case N is when Expect_Internal_Error | Expect_Process_Died => raise Process_Died; when Expect_Timeout | Expect_Full_Buffer => Result := N; return; when others => null; -- Continue end case; end loop; end Expect; procedure Expect (Result : out Expect_Match; Regexps : Multiprocess_Regexp_Array; Matched : out GNAT.Regpat.Match_Array; Timeout : Integer := 10_000; Full_Buffer : Boolean := False) is N : Expect_Match; Descriptors : Array_Of_Pd (Regexps'Range); begin pragma Assert (Matched'First = 0); for J in Descriptors'Range loop Descriptors (J) := Regexps (J).Descriptor; if Descriptors (J) /= null then Reinitialize_Buffer (Regexps (J).Descriptor.all); end if; end loop; loop -- First, test if what is already in the buffer matches (This is -- required if this package is used in multi-task mode, since one of -- the tasks might have added something in the buffer, and we don't -- want other tasks to wait for new input to be available before -- checking the regexps). for J in Regexps'Range loop if Regexps (J).Regexp /= null and then Regexps (J).Descriptor /= null then Match (Regexps (J).Regexp.all, Regexps (J).Descriptor.Buffer (1 .. Regexps (J).Descriptor.Buffer_Index), Matched); if Matched (0) /= No_Match then Result := Expect_Match (J); Regexps (J).Descriptor.Last_Match_Start := Matched (0).First; Regexps (J).Descriptor.Last_Match_End := Matched (0).Last; return; end if; end if; end loop; Expect_Internal (Descriptors, N, Timeout, Full_Buffer); case N is when Expect_Internal_Error | Expect_Process_Died => raise Process_Died; when Expect_Timeout | Expect_Full_Buffer => Result := N; return; when others => null; -- Continue end case; end loop; end Expect; --------------------- -- Expect_Internal -- --------------------- procedure Expect_Internal (Descriptors : in out Array_Of_Pd; Result : out Expect_Match; Timeout : Integer; Full_Buffer : Boolean) is Num_Descriptors : Integer; Buffer_Size : Integer := 0; N : Integer; type File_Descriptor_Array is array (0 .. Descriptors'Length - 1) of File_Descriptor; Fds : aliased File_Descriptor_Array; Fds_Count : Natural := 0; Fds_To_Descriptor : array (Fds'Range) of Integer; -- Maps file descriptor entries from Fds to entries in Descriptors. -- They do not have the same index when entries in Descriptors are null. type Integer_Array is array (Fds'Range) of Integer; Is_Set : aliased Integer_Array; begin for J in Descriptors'Range loop if Descriptors (J) /= null then Fds (Fds'First + Fds_Count) := Descriptors (J).Output_Fd; Fds_To_Descriptor (Fds'First + Fds_Count) := J; Fds_Count := Fds_Count + 1; if Descriptors (J).Buffer_Size = 0 then Buffer_Size := Integer'Max (Buffer_Size, 4096); else Buffer_Size := Integer'Max (Buffer_Size, Descriptors (J).Buffer_Size); end if; end if; end loop; declare Buffer : aliased String (1 .. Buffer_Size); -- Buffer used for input. This is allocated only once, not for -- every iteration of the loop D : aliased Integer; -- Index in Descriptors begin -- Loop until we match or we have a timeout loop Num_Descriptors := Poll (Fds'Address, Fds_Count, Timeout, D'Access, Is_Set'Address); case Num_Descriptors is -- Error? when -1 => Result := Expect_Internal_Error; if D /= 0 then Close (Descriptors (D).Input_Fd); Descriptors (D).Input_Fd := Invalid_FD; end if; return; -- Timeout? when 0 => Result := Expect_Timeout; return; -- Some input when others => for F in Fds'Range loop if Is_Set (F) = 1 then D := Fds_To_Descriptor (F); Buffer_Size := Descriptors (D).Buffer_Size; if Buffer_Size = 0 then Buffer_Size := 4096; end if; N := Read (Descriptors (D).Output_Fd, Buffer'Address, Buffer_Size); -- Error or End of file if N <= 0 then -- ??? Note that ddd tries again up to three times -- in that case. See LiterateA.C:174 Close (Descriptors (D).Input_Fd); Descriptors (D).Input_Fd := Invalid_FD; Result := Expect_Process_Died; return; else -- If there is no limit to the buffer size if Descriptors (D).Buffer_Size = 0 then declare Tmp : String_Access := Descriptors (D).Buffer; begin if Tmp /= null then Descriptors (D).Buffer := new String (1 .. Tmp'Length + N); Descriptors (D).Buffer (1 .. Tmp'Length) := Tmp.all; Descriptors (D).Buffer (Tmp'Length + 1 .. Tmp'Length + N) := Buffer (1 .. N); Free (Tmp); Descriptors (D).Buffer_Index := Descriptors (D).Buffer'Last; else Descriptors (D).Buffer := new String (1 .. N); Descriptors (D).Buffer.all := Buffer (1 .. N); Descriptors (D).Buffer_Index := N; end if; end; else -- Add what we read to the buffer if Descriptors (D).Buffer_Index + N > Descriptors (D).Buffer_Size then -- If the user wants to know when we have -- read more than the buffer can contain. if Full_Buffer then Result := Expect_Full_Buffer; return; end if; -- Keep as much as possible from the buffer, -- and forget old characters. Descriptors (D).Buffer (1 .. Descriptors (D).Buffer_Size - N) := Descriptors (D).Buffer (N - Descriptors (D).Buffer_Size + Descriptors (D).Buffer_Index + 1 .. Descriptors (D).Buffer_Index); Descriptors (D).Buffer_Index := Descriptors (D).Buffer_Size - N; end if; -- Keep what we read in the buffer Descriptors (D).Buffer (Descriptors (D).Buffer_Index + 1 .. Descriptors (D).Buffer_Index + N) := Buffer (1 .. N); Descriptors (D).Buffer_Index := Descriptors (D).Buffer_Index + N; end if; -- Call each of the output filter with what we -- read. Call_Filters (Descriptors (D).all, Buffer (1 .. N), Output); Result := Expect_Match (D); return; end if; end if; end loop; end case; end loop; end; end Expect_Internal; ---------------- -- Expect_Out -- ---------------- function Expect_Out (Descriptor : Process_Descriptor) return String is begin return Descriptor.Buffer (1 .. Descriptor.Last_Match_End); end Expect_Out; ---------------------- -- Expect_Out_Match -- ---------------------- function Expect_Out_Match (Descriptor : Process_Descriptor) return String is begin return Descriptor.Buffer (Descriptor.Last_Match_Start .. Descriptor.Last_Match_End); end Expect_Out_Match; ------------------------ -- First_Dead_Process -- ------------------------ function First_Dead_Process (Regexp : Multiprocess_Regexp_Array) return Natural is begin for R in Regexp'Range loop if Regexp (R).Descriptor /= null and then Regexp (R).Descriptor.Input_Fd = GNAT.OS_Lib.Invalid_FD then return R; end if; end loop; return 0; end First_Dead_Process; ----------- -- Flush -- ----------- procedure Flush (Descriptor : in out Process_Descriptor; Timeout : Integer := 0) is Buffer_Size : constant Integer := 8192; Num_Descriptors : Integer; N : aliased Integer; Is_Set : aliased Integer; Buffer : aliased String (1 .. Buffer_Size); begin -- Empty the current buffer Descriptor.Last_Match_End := Descriptor.Buffer_Index; Reinitialize_Buffer (Descriptor); -- Read everything from the process to flush its output loop Num_Descriptors := Poll (Descriptor.Output_Fd'Address, 1, Timeout, N'Access, Is_Set'Address); case Num_Descriptors is -- Error ? when -1 => raise Process_Died; -- Timeout => End of flush when 0 => return; -- Some input when others => if Is_Set = 1 then N := Read (Descriptor.Output_Fd, Buffer'Address, Buffer_Size); if N = -1 then raise Process_Died; elsif N = 0 then return; end if; end if; end case; end loop; end Flush; ---------- -- Free -- ---------- procedure Free (Regexp : in out Multiprocess_Regexp) is procedure Unchecked_Free is new Ada.Unchecked_Deallocation (Process_Descriptor'Class, Process_Descriptor_Access); begin Unchecked_Free (Regexp.Descriptor); Free (Regexp.Regexp); end Free; ------------------------ -- Get_Command_Output -- ------------------------ function Get_Command_Output (Command : String; Arguments : GNAT.OS_Lib.Argument_List; Input : String; Status : not null access Integer; Err_To_Out : Boolean := False) return String is use GNAT.Expect; Process : Process_Descriptor; Output : String_Access := new String (1 .. 1024); -- Buffer used to accumulate standard output from the launched -- command, expanded as necessary during execution. Last : Integer := 0; -- Index of the last used character within Output begin Non_Blocking_Spawn (Process, Command, Arguments, Err_To_Out => Err_To_Out, Buffer_Size => 0); if Input'Length > 0 then Send (Process, Input); end if; Close (Process.Input_Fd); Process.Input_Fd := Invalid_FD; declare Result : Expect_Match; pragma Unreferenced (Result); begin -- This loop runs until the call to Expect raises Process_Died loop Expect (Process, Result, ".+", Timeout => -1); declare NOutput : String_Access; S : constant String := Expect_Out (Process); pragma Assert (S'Length > 0); begin -- Expand buffer if we need more space. Note here that we add -- S'Length to ensure that S will fit in the new buffer size. if Last + S'Length > Output'Last then NOutput := new String (1 .. 2 * Output'Last + S'Length); NOutput (Output'Range) := Output.all; Free (Output); -- Here if current buffer size is OK else NOutput := Output; end if; NOutput (Last + 1 .. Last + S'Length) := S; Last := Last + S'Length; Output := NOutput; end; end loop; exception when Process_Died => Close (Process, Status.all); end; if Last = 0 then Free (Output); return ""; end if; declare S : constant String := Output (1 .. Last); begin Free (Output); return S; end; end Get_Command_Output; ------------------ -- Get_Error_Fd -- ------------------ function Get_Error_Fd (Descriptor : Process_Descriptor) return GNAT.OS_Lib.File_Descriptor is begin return Descriptor.Error_Fd; end Get_Error_Fd; ------------------ -- Get_Input_Fd -- ------------------ function Get_Input_Fd (Descriptor : Process_Descriptor) return GNAT.OS_Lib.File_Descriptor is begin return Descriptor.Input_Fd; end Get_Input_Fd; ------------------- -- Get_Output_Fd -- ------------------- function Get_Output_Fd (Descriptor : Process_Descriptor) return GNAT.OS_Lib.File_Descriptor is begin return Descriptor.Output_Fd; end Get_Output_Fd; ------------- -- Get_Pid -- ------------- function Get_Pid (Descriptor : Process_Descriptor) return Process_Id is begin return Descriptor.Pid; end Get_Pid; ----------------- -- Has_Process -- ----------------- function Has_Process (Regexp : Multiprocess_Regexp_Array) return Boolean is begin return Regexp /= (Regexp'Range => (null, null)); end Has_Process; --------------- -- Interrupt -- --------------- procedure Interrupt (Descriptor : in out Process_Descriptor) is SIGINT : constant := 2; begin Send_Signal (Descriptor, SIGINT); end Interrupt; ------------------ -- Lock_Filters -- ------------------ procedure Lock_Filters (Descriptor : in out Process_Descriptor) is begin Descriptor.Filters_Lock := Descriptor.Filters_Lock + 1; end Lock_Filters; ------------------------ -- Non_Blocking_Spawn -- ------------------------ procedure Non_Blocking_Spawn (Descriptor : out Process_Descriptor'Class; Command : String; Args : GNAT.OS_Lib.Argument_List; Buffer_Size : Natural := 4096; Err_To_Out : Boolean := False) is function Fork return Process_Id; pragma Import (C, Fork, "__gnat_expect_fork"); -- Starts a new process if possible. See the Unix command fork for more -- information. On systems that do not support this capability (such as -- Windows...), this command does nothing, and Fork will return -- Null_Pid. Pipe1, Pipe2, Pipe3 : aliased Pipe_Type; Arg : String_Access; Arg_List : String_List (1 .. Args'Length + 2); C_Arg_List : aliased array (1 .. Args'Length + 2) of System.Address; Command_With_Path : String_Access; begin Command_With_Path := Locate_Exec_On_Path (Command); if Command_With_Path = null then raise Invalid_Process; end if; -- Create the rest of the pipes once we know we will be able to -- execute the process. Set_Up_Communications (Descriptor, Err_To_Out, Pipe1'Access, Pipe2'Access, Pipe3'Access); -- Fork a new process Descriptor.Pid := Fork; -- Are we now in the child (or, for Windows, still in the common -- process). if Descriptor.Pid = Null_Pid then -- Prepare an array of arguments to pass to C Arg := new String (1 .. Command_With_Path'Length + 1); Arg (1 .. Command_With_Path'Length) := Command_With_Path.all; Arg (Arg'Last) := ASCII.NUL; Arg_List (1) := Arg; for J in Args'Range loop Arg := new String (1 .. Args (J)'Length + 1); Arg (1 .. Args (J)'Length) := Args (J).all; Arg (Arg'Last) := ASCII.NUL; Arg_List (J + 2 - Args'First) := Arg.all'Access; end loop; Arg_List (Arg_List'Last) := null; -- Make sure all arguments are compatible with OS conventions Normalize_Arguments (Arg_List); -- Prepare low-level argument list from the normalized arguments for K in Arg_List'Range loop C_Arg_List (K) := (if Arg_List (K) /= null then Arg_List (K).all'Address else System.Null_Address); end loop; -- This does not return on Unix systems Set_Up_Child_Communications (Descriptor, Pipe1, Pipe2, Pipe3, Command_With_Path.all, C_Arg_List'Address); end if; Free (Command_With_Path); -- Did we have an error when spawning the child ? if Descriptor.Pid < Null_Pid then raise Invalid_Process; else -- We are now in the parent process Set_Up_Parent_Communications (Descriptor, Pipe1, Pipe2, Pipe3); end if; -- Create the buffer Descriptor.Buffer_Size := Buffer_Size; if Buffer_Size /= 0 then Descriptor.Buffer := new String (1 .. Positive (Buffer_Size)); end if; -- Initialize the filters Descriptor.Filters := null; end Non_Blocking_Spawn; ------------------------- -- Reinitialize_Buffer -- ------------------------- procedure Reinitialize_Buffer (Descriptor : in out Process_Descriptor'Class) is begin if Descriptor.Buffer_Size = 0 then declare Tmp : String_Access := Descriptor.Buffer; begin Descriptor.Buffer := new String (1 .. Descriptor.Buffer_Index - Descriptor.Last_Match_End); if Tmp /= null then Descriptor.Buffer.all := Tmp (Descriptor.Last_Match_End + 1 .. Descriptor.Buffer_Index); Free (Tmp); end if; end; Descriptor.Buffer_Index := Descriptor.Buffer'Last; else Descriptor.Buffer (1 .. Descriptor.Buffer_Index - Descriptor.Last_Match_End) := Descriptor.Buffer (Descriptor.Last_Match_End + 1 .. Descriptor.Buffer_Index); if Descriptor.Buffer_Index > Descriptor.Last_Match_End then Descriptor.Buffer_Index := Descriptor.Buffer_Index - Descriptor.Last_Match_End; else Descriptor.Buffer_Index := 0; end if; end if; Descriptor.Last_Match_Start := 0; Descriptor.Last_Match_End := 0; end Reinitialize_Buffer; ------------------- -- Remove_Filter -- ------------------- procedure Remove_Filter (Descriptor : in out Process_Descriptor; Filter : Filter_Function) is Previous : Filter_List := null; Current : Filter_List := Descriptor.Filters; begin while Current /= null loop if Current.Filter = Filter then if Previous = null then Descriptor.Filters := Current.Next; else Previous.Next := Current.Next; end if; end if; Previous := Current; Current := Current.Next; end loop; end Remove_Filter; ---------- -- Send -- ---------- procedure Send (Descriptor : in out Process_Descriptor; Str : String; Add_LF : Boolean := True; Empty_Buffer : Boolean := False) is Line_Feed : aliased constant String := (1 .. 1 => ASCII.LF); Descriptors : Array_Of_Pd := (1 => Descriptor'Unrestricted_Access); Result : Expect_Match; Discard : Natural; pragma Warnings (Off, Result); pragma Warnings (Off, Discard); begin if Empty_Buffer then -- Force a read on the process if there is anything waiting Expect_Internal (Descriptors, Result, Timeout => 0, Full_Buffer => False); if Result = Expect_Internal_Error or else Result = Expect_Process_Died then raise Process_Died; end if; Descriptor.Last_Match_End := Descriptor.Buffer_Index; -- Empty the buffer Reinitialize_Buffer (Descriptor); end if; Call_Filters (Descriptor, Str, Input); Discard := Write (Descriptor.Input_Fd, Str'Address, Str'Last - Str'First + 1); if Add_LF then Call_Filters (Descriptor, Line_Feed, Input); Discard := Write (Descriptor.Input_Fd, Line_Feed'Address, 1); end if; end Send; ----------------- -- Send_Signal -- ----------------- procedure Send_Signal (Descriptor : Process_Descriptor; Signal : Integer) is begin -- A nonpositive process id passed to kill has special meanings. For -- example, -1 means kill all processes in sight, including self, in -- POSIX and Windows (and something slightly different in Linux). See -- man pages for details. In any case, we don't want to do that. Note -- that Descriptor.Pid will be -1 if the process was not successfully -- started; we don't want to kill ourself in that case. if Descriptor.Pid > 0 then Kill (Descriptor.Pid, Signal, Close => 1); -- ??? Need to check process status here else raise Invalid_Process; end if; end Send_Signal; --------------------------------- -- Set_Up_Child_Communications -- --------------------------------- procedure Set_Up_Child_Communications (Pid : in out Process_Descriptor; Pipe1 : in out Pipe_Type; Pipe2 : in out Pipe_Type; Pipe3 : in out Pipe_Type; Cmd : String; Args : System.Address) is pragma Warnings (Off, Pid); pragma Warnings (Off, Pipe1); pragma Warnings (Off, Pipe2); pragma Warnings (Off, Pipe3); Input : File_Descriptor; Output : File_Descriptor; Error : File_Descriptor; No_Fork_On_Target : constant Boolean := Target_OS = Windows; begin if No_Fork_On_Target then -- Since Windows does not have a separate fork/exec, we need to -- perform the following actions: -- - save stdin, stdout, stderr -- - replace them by our pipes -- - create the child with process handle inheritance -- - revert to the previous stdin, stdout and stderr. Input := Dup (GNAT.OS_Lib.Standin); Output := Dup (GNAT.OS_Lib.Standout); Error := Dup (GNAT.OS_Lib.Standerr); end if; -- Since we are still called from the parent process, there is no way -- currently we can cleanly close the unneeded ends of the pipes, but -- this doesn't really matter. -- We could close Pipe1.Output, Pipe2.Input, Pipe3.Input Dup2 (Pipe1.Input, GNAT.OS_Lib.Standin); Dup2 (Pipe2.Output, GNAT.OS_Lib.Standout); Dup2 (Pipe3.Output, GNAT.OS_Lib.Standerr); Portable_Execvp (Pid.Pid'Access, Cmd & ASCII.NUL, Args); -- The following commands are not executed on Unix systems, and are only -- required for Windows systems. We are now in the parent process. -- Restore the old descriptors Dup2 (Input, GNAT.OS_Lib.Standin); Dup2 (Output, GNAT.OS_Lib.Standout); Dup2 (Error, GNAT.OS_Lib.Standerr); Close (Input); Close (Output); Close (Error); end Set_Up_Child_Communications; --------------------------- -- Set_Up_Communications -- --------------------------- procedure Set_Up_Communications (Pid : in out Process_Descriptor; Err_To_Out : Boolean; Pipe1 : not null access Pipe_Type; Pipe2 : not null access Pipe_Type; Pipe3 : not null access Pipe_Type) is Status : Boolean; pragma Unreferenced (Status); begin -- Create the pipes if Create_Pipe (Pipe1) /= 0 then return; end if; if Create_Pipe (Pipe2) /= 0 then Close (Pipe1.Input); Close (Pipe1.Output); return; end if; -- Record the 'parent' end of the two pipes in Pid: -- Child stdin is connected to the 'write' end of Pipe1; -- Child stdout is connected to the 'read' end of Pipe2. -- We do not want these descriptors to remain open in the child -- process, so we mark them close-on-exec/non-inheritable. Pid.Input_Fd := Pipe1.Output; Set_Close_On_Exec (Pipe1.Output, True, Status); Pid.Output_Fd := Pipe2.Input; Set_Close_On_Exec (Pipe2.Input, True, Status); if Err_To_Out then -- Reuse the standard output pipe for standard error Pipe3.all := Pipe2.all; else -- Create a separate pipe for standard error if Create_Pipe (Pipe3) /= 0 then Pipe3.all := Pipe2.all; end if; end if; -- As above, record the proper fd for the child's standard error stream Pid.Error_Fd := Pipe3.Input; Set_Close_On_Exec (Pipe3.Input, True, Status); end Set_Up_Communications; ---------------------------------- -- Set_Up_Parent_Communications -- ---------------------------------- procedure Set_Up_Parent_Communications (Pid : in out Process_Descriptor; Pipe1 : in out Pipe_Type; Pipe2 : in out Pipe_Type; Pipe3 : in out Pipe_Type) is pragma Warnings (Off, Pid); pragma Warnings (Off, Pipe1); pragma Warnings (Off, Pipe2); pragma Warnings (Off, Pipe3); begin Close (Pipe1.Input); Close (Pipe2.Output); if Pipe3.Output /= Pipe2.Output then Close (Pipe3.Output); end if; end Set_Up_Parent_Communications; ------------------ -- Trace_Filter -- ------------------ procedure Trace_Filter (Descriptor : Process_Descriptor'Class; Str : String; User_Data : System.Address := System.Null_Address) is pragma Warnings (Off, Descriptor); pragma Warnings (Off, User_Data); begin GNAT.IO.Put (Str); end Trace_Filter; -------------------- -- Unlock_Filters -- -------------------- procedure Unlock_Filters (Descriptor : in out Process_Descriptor) is begin if Descriptor.Filters_Lock > 0 then Descriptor.Filters_Lock := Descriptor.Filters_Lock - 1; end if; end Unlock_Filters; end GNAT.Expect;