| ------------------------------------------------------------------------------ |
| -- -- |
| -- 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 -- |
| -- <http://www.gnu.org/licenses/>. -- |
| -- -- |
| -- 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=<integer>, 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; |
