aboutsummaryrefslogtreecommitdiffstats
path: root/gcc-4.8.3/gcc/ada/g-expect-vms.adb
diff options
context:
space:
mode:
Diffstat (limited to 'gcc-4.8.3/gcc/ada/g-expect-vms.adb')
-rw-r--r--gcc-4.8.3/gcc/ada/g-expect-vms.adb1304
1 files changed, 1304 insertions, 0 deletions
diff --git a/gcc-4.8.3/gcc/ada/g-expect-vms.adb b/gcc-4.8.3/gcc/ada/g-expect-vms.adb
new file mode 100644
index 000000000..4899682ba
--- /dev/null
+++ b/gcc-4.8.3/gcc/ada/g-expect-vms.adb
@@ -0,0 +1,1304 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- G N A T . E X P E C T --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2002-2010, 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. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the VMS version
+
+with System; use System;
+with Ada.Calendar; use Ada.Calendar;
+
+with 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;
+
+ Save_Input : File_Descriptor;
+ Save_Output : File_Descriptor;
+ Save_Error : File_Descriptor;
+
+ 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 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, "decc$dup");
+
+ procedure Dup2 (Old_Fd, New_Fd : File_Descriptor);
+ pragma Import (C, Dup2, "decc$dup2");
+
+ procedure Kill (Pid : Process_Id; Sig_Num : Integer);
+ pragma Import (C, Kill, "decc$kill");
+
+ 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;
+ Is_Set : System.Address) return Integer;
+ pragma Import (C, Poll, "__gnat_expect_poll");
+ -- Check whether there is any data waiting on the file descriptor
+ -- Out_fd, 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.
+ --
+ -- Out_Is_Set is set to 1 if data was available, 0 otherwise.
+
+ 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
+ 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);
+ end if;
+
+ GNAT.OS_Lib.Free (Descriptor.Buffer);
+ Descriptor.Buffer_Size := 0;
+
+ -- 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;
+ 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);
+
+ 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);
+
+ 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);
+
+ 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);
+
+ 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 : Integer;
+ -- Index in Descriptors
+
+ begin
+ -- Loop until we match or we have a timeout
+
+ loop
+ Num_Descriptors :=
+ Poll (Fds'Address, Fds_Count, Timeout, Is_Set'Address);
+
+ case Num_Descriptors is
+
+ -- Error?
+
+ when -1 =>
+ Result := Expect_Internal_Error;
+ 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
+
+ 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 : 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, 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);
+
+ if Input'Length > 0 then
+ Send (Process, Input);
+ end if;
+
+ GNAT.OS_Lib.Close (Get_Input_Fd (Process));
+
+ declare
+ Result : Expect_Match;
+
+ begin
+ -- This loop runs until the call to Expect raises Process_Died
+
+ loop
+ Expect (Process, Result, ".+");
+
+ declare
+ NOutput : String_Access;
+ S : constant String := Expect_Out (Process);
+ pragma Assert (S'Length > 0);
+
+ begin
+ -- Expand buffer if we need more space
+
+ if Last + S'Length > Output'Last then
+ NOutput := new String (1 .. 2 * Output'Last);
+ 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
+ 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 separate;
+
+ -------------------------
+ -- 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
+ Full_Str : constant String := Str & ASCII.LF;
+ Last : Natural;
+ Result : Expect_Match;
+ Descriptors : Array_Of_Pd := (1 => Descriptor'Unrestricted_Access);
+
+ Discard : Natural;
+ pragma Unreferenced (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;
+
+ Last := (if Add_LF then Full_Str'Last else Full_Str'Last - 1);
+
+ Call_Filters (Descriptor, Full_Str (Full_Str'First .. Last), Input);
+
+ Discard :=
+ Write (Descriptor.Input_Fd,
+ Full_Str'Address,
+ Last - Full_Str'First + 1);
+ -- Shouldn't we at least have a pragma Assert on the result ???
+ 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);
+ -- ??? 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);
+
+ begin
+ -- Since the code between fork and exec on VMS executes
+ -- in the context of the parent process, 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.
+
+ Save_Input := Dup (GNAT.OS_Lib.Standin);
+ Save_Output := Dup (GNAT.OS_Lib.Standout);
+ Save_Error := Dup (GNAT.OS_Lib.Standerr);
+
+ -- 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);
+ 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
+ begin
+ -- Create the pipes
+
+ if Create_Pipe (Pipe1) /= 0 then
+ return;
+ end if;
+
+ if Create_Pipe (Pipe2) /= 0 then
+ return;
+ end if;
+
+ Pid.Input_Fd := Pipe1.Output;
+ Pid.Output_Fd := Pipe2.Input;
+
+ if Err_To_Out then
+ Pipe3.all := Pipe2.all;
+ else
+ if Create_Pipe (Pipe3) /= 0 then
+ return;
+ end if;
+ end if;
+
+ Pid.Error_Fd := Pipe3.Input;
+ 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
+
+ Dup2 (Save_Input, GNAT.OS_Lib.Standin);
+ Dup2 (Save_Output, GNAT.OS_Lib.Standout);
+ Dup2 (Save_Error, GNAT.OS_Lib.Standerr);
+
+ Close (Save_Input);
+ Close (Save_Output);
+ Close (Save_Error);
+
+ Close (Pipe1.Input);
+ Close (Pipe2.Output);
+ Close (Pipe3.Output);
+ 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;