blob: 1f18885c813f08b3ccccde871ec36d3fdba24cf2 [file] [log] [blame]
------------------------------------------------------------------------------
-- --
-- GNAT LIBRARY COMPONENTS --
-- --
-- G N A T . E X P E C T --
-- --
-- B o d y --
-- --
-- Copyright (C) 2002-2003 Ada Core Technologies, Inc. --
-- --
-- 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 2, 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. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- 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 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;
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.
--
-- Three 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=<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 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);
procedure Dup2 (Old_Fd, New_Fd : File_Descriptor);
pragma Import (C, Dup2);
procedure Kill (Pid : Process_Id; Sig_Num : Integer);
pragma Import (C, Kill);
function Create_Pipe (Pipe : 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
Close (Descriptor.Input_Fd);
if Descriptor.Error_Fd /= Descriptor.Output_Fd then
Close (Descriptor.Error_Fd);
end if;
Close (Descriptor.Output_Fd);
-- ??? Should have timeouts for different signals
Kill (Descriptor.Pid, 9);
GNAT.OS_Lib.Free (Descriptor.Buffer);
Descriptor.Buffer_Size := 0;
Status := Waitpid (Descriptor.Pid);
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 := 10000;
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 := 10000;
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 := 10000;
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 := 10000;
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);
if N = Expect_Timeout or else N = Expect_Full_Buffer then
Result := N;
return;
end if;
-- 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 can not 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 := 10000;
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 := 10000;
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 := 10000;
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 := 10000;
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 := 10000;
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);
if N = Expect_Timeout or else N = Expect_Full_Buffer then
Result := N;
return;
end if;
end loop;
end Expect;
procedure Expect
(Result : out Expect_Match;
Regexps : Multiprocess_Regexp_Array;
Matched : out GNAT.Regpat.Match_Array;
Timeout : Integer := 10000;
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;
Reinitialize_Buffer (Regexps (J).Descriptor.all);
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
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 loop;
Expect_Internal (Descriptors, N, Timeout, Full_Buffer);
if N = Expect_Timeout or else N = Expect_Full_Buffer then
Result := N;
return;
end if;
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 (Descriptors'Range) of File_Descriptor;
Fds : aliased File_Descriptor_Array;
type Integer_Array is array (Descriptors'Range) of Integer;
Is_Set : aliased Integer_Array;
begin
for J in Descriptors'Range loop
Fds (J) := Descriptors (J).Output_Fd;
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 loop;
declare
Buffer : aliased String (1 .. Buffer_Size);
-- Buffer used for input. This is allocated only once, not for
-- every iteration of the loop
begin
-- Loop until we match or we have a timeout
loop
Num_Descriptors :=
Poll (Fds'Address, Fds'Length, Timeout, Is_Set'Address);
case Num_Descriptors is
-- Error?
when -1 =>
raise Process_Died;
-- Timeout?
when 0 =>
Result := Expect_Timeout;
return;
-- Some input
when others =>
for J in Descriptors'Range loop
if Is_Set (J) = 1 then
Buffer_Size := Descriptors (J).Buffer_Size;
if Buffer_Size = 0 then
Buffer_Size := 4096;
end if;
N := Read (Descriptors (J).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
raise Process_Died;
else
-- If there is no limit to the buffer size
if Descriptors (J).Buffer_Size = 0 then
declare
Tmp : String_Access := Descriptors (J).Buffer;
begin
if Tmp /= null then
Descriptors (J).Buffer :=
new String (1 .. Tmp'Length + N);
Descriptors (J).Buffer (1 .. Tmp'Length) :=
Tmp.all;
Descriptors (J).Buffer
(Tmp'Length + 1 .. Tmp'Length + N) :=
Buffer (1 .. N);
Free (Tmp);
Descriptors (J).Buffer_Index :=
Descriptors (J).Buffer'Last;
else
Descriptors (J).Buffer :=
new String (1 .. N);
Descriptors (J).Buffer.all :=
Buffer (1 .. N);
Descriptors (J).Buffer_Index := N;
end if;
end;
else
-- Add what we read to the buffer
if Descriptors (J).Buffer_Index + N - 1 >
Descriptors (J).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 (J).Buffer
(1 .. Descriptors (J).Buffer_Size - N) :=
Descriptors (J).Buffer
(N - Descriptors (J).Buffer_Size +
Descriptors (J).Buffer_Index + 1 ..
Descriptors (J).Buffer_Index);
Descriptors (J).Buffer_Index :=
Descriptors (J).Buffer_Size - N;
end if;
-- Keep what we read in the buffer.
Descriptors (J).Buffer
(Descriptors (J).Buffer_Index + 1 ..
Descriptors (J).Buffer_Index + N) :=
Buffer (1 .. N);
Descriptors (J).Buffer_Index :=
Descriptors (J).Buffer_Index + N;
end if;
-- Call each of the output filter with what we
-- read.
Call_Filters
(Descriptors (J).all, Buffer (1 .. N), Output);
Result := Expect_Match (N);
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;
-----------
-- 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;
------------------
-- 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;
---------------
-- 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 Alloc_Vfork_Blocks return Integer;
pragma Import (C, Alloc_Vfork_Blocks, "decc$$alloc_vfork_blocks");
function Get_Vfork_Jmpbuf return System.Address;
pragma Import (C, Get_Vfork_Jmpbuf, "decc$$get_vfork_jmpbuf");
function Get_Current_Invo_Context
(Addr : System.Address) return Process_Id;
pragma Import (C, Get_Current_Invo_Context,
"LIB$GET_CURRENT_INVO_CONTEXT");
Pipe1, Pipe2, Pipe3 : aliased Pipe_Type;
Arg : String_Access;
Arg_List : aliased array (1 .. Args'Length + 2) of System.Address;
Command_With_Path : String_Access;
begin
-- Create the rest of the pipes
Set_Up_Communications
(Descriptor, Err_To_Out, Pipe1'Access, Pipe2'Access, Pipe3'Access);
Command_With_Path := Locate_Exec_On_Path (Command);
if Command_With_Path = null then
raise Invalid_Process;
end if;
-- Fork a new process. It's not possible to do this in a subprogram.
if Alloc_Vfork_Blocks >= 0 then
Descriptor.Pid := Get_Current_Invo_Context (Get_Vfork_Jmpbuf);
else
Descriptor.Pid := -1;
end if;
-- 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.all'Address;
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'Address;
end loop;
Arg_List (Arg_List'Last) := System.Null_Address;
-- This does not return on Unix systems
Set_Up_Child_Communications
(Descriptor, Pipe1, Pipe2, Pipe3, Command_With_Path.all,
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;
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
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);
Descriptor.Last_Match_End := Descriptor.Buffer_Index;
-- Empty the buffer
Reinitialize_Buffer (Descriptor);
end if;
if Add_LF then
Last := Full_Str'Last;
else
Last := Full_Str'Last - 1;
end if;
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
Kill (Descriptor.Pid, Signal);
-- ??? Need to check process status here.
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 : in String;
Args : in System.Address)
is
pragma Warnings (Off, Pid);
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 : access Pipe_Type;
Pipe2 : access Pipe_Type;
Pipe3 : 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);
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;