1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- G N A T . E X P E C T --
9 -- Copyright (C) 2000-2010, AdaCore --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 2, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- As a special exception, if other files instantiate generics from this --
23 -- unit, or you link this unit with other files to produce an executable, --
24 -- this unit does not by itself cause the resulting executable to be --
25 -- covered by the GNU General Public License. This exception does not --
26 -- however invalidate any other reasons why the executable file might be --
27 -- covered by the GNU Public License. --
29 -- GNAT was originally developed by the GNAT team at New York University. --
30 -- Extensive contributions were provided by Ada Core Technologies Inc. --
32 ------------------------------------------------------------------------------
34 with System
; use System
;
35 with System
.OS_Constants
; use System
.OS_Constants
;
36 with Ada
.Calendar
; use Ada
.Calendar
;
39 with GNAT
.OS_Lib
; use GNAT
.OS_Lib
;
40 with GNAT
.Regpat
; use GNAT
.Regpat
;
42 with Ada
.Unchecked_Deallocation
;
44 package body GNAT
.Expect
is
46 type Array_Of_Pd
is array (Positive range <>) of Process_Descriptor_Access
;
48 Expect_Process_Died
: constant Expect_Match
:= -100;
49 Expect_Internal_Error
: constant Expect_Match
:= -101;
50 -- Additional possible outputs of Expect_Internal. These are not visible in
51 -- the spec because the user will never see them.
53 procedure Expect_Internal
54 (Descriptors
: in out Array_Of_Pd
;
55 Result
: out Expect_Match
;
57 Full_Buffer
: Boolean);
58 -- Internal function used to read from the process Descriptor.
60 -- Several outputs are possible:
61 -- Result=Expect_Timeout, if no output was available before the timeout
63 -- Result=Expect_Full_Buffer, if Full_Buffer is True and some characters
64 -- had to be discarded from the internal buffer of Descriptor.
65 -- Result=Express_Process_Died if one of the processes was terminated.
66 -- That process's Input_Fd is set to Invalid_FD
67 -- Result=Express_Internal_Error
68 -- Result=<integer>, indicates how many characters were added to the
69 -- internal buffer. These characters are from indexes
70 -- Descriptor.Buffer_Index - Result + 1 .. Descriptor.Buffer_Index
71 -- Process_Died is raised if the process is no longer valid.
73 procedure Reinitialize_Buffer
74 (Descriptor
: in out Process_Descriptor
'Class);
75 -- Reinitialize the internal buffer.
76 -- The buffer is deleted up to the end of the last match.
78 procedure Free
is new Ada
.Unchecked_Deallocation
79 (Pattern_Matcher
, Pattern_Matcher_Access
);
81 procedure Free
is new Ada
.Unchecked_Deallocation
82 (Filter_List_Elem
, Filter_List
);
84 procedure Call_Filters
85 (Pid
: Process_Descriptor
'Class;
87 Filter_On
: Filter_Type
);
88 -- Call all the filters that have the appropriate type.
89 -- This function does nothing if the filters are locked
91 ------------------------------
92 -- Target dependent section --
93 ------------------------------
95 function Dup
(Fd
: File_Descriptor
) return File_Descriptor
;
96 pragma Import
(C
, Dup
);
98 procedure Dup2
(Old_Fd
, New_Fd
: File_Descriptor
);
99 pragma Import
(C
, Dup2
);
101 procedure Kill
(Pid
: Process_Id
; Sig_Num
: Integer; Close
: Integer);
102 pragma Import
(C
, Kill
, "__gnat_kill");
103 -- if Close is set to 1 all OS resources used by the Pid must be freed
105 function Create_Pipe
(Pipe
: not null access Pipe_Type
) return Integer;
106 pragma Import
(C
, Create_Pipe
, "__gnat_pipe");
109 (Fds
: System
.Address
;
112 Is_Set
: System
.Address
) return Integer;
113 pragma Import
(C
, Poll
, "__gnat_expect_poll");
114 -- Check whether there is any data waiting on the file descriptor
115 -- Out_fd, and wait if there is none, at most Timeout milliseconds
116 -- Returns -1 in case of error, 0 if the timeout expired before
117 -- data became available.
119 -- Out_Is_Set is set to 1 if data was available, 0 otherwise.
121 function Waitpid
(Pid
: Process_Id
) return Integer;
122 pragma Import
(C
, Waitpid
, "__gnat_waitpid");
123 -- Wait for a specific process id, and return its exit code
129 function "+" (S
: String) return GNAT
.OS_Lib
.String_Access
is
131 return new String'(S);
139 (P : GNAT.Regpat.Pattern_Matcher) return Pattern_Matcher_Access
142 return new GNAT.Regpat.Pattern_Matcher'(P
);
150 (Descriptor
: in out Process_Descriptor
;
151 Filter
: Filter_Function
;
152 Filter_On
: Filter_Type
:= Output
;
153 User_Data
: System
.Address
:= System
.Null_Address
;
154 After
: Boolean := False)
156 Current
: Filter_List
:= Descriptor
.Filters
;
160 while Current
/= null and then Current
.Next
/= null loop
161 Current
:= Current
.Next
;
164 if Current
= null then
165 Descriptor
.Filters
:=
166 new Filter_List_Elem
'
167 (Filter => Filter, Filter_On => Filter_On,
168 User_Data => User_Data, Next => null);
171 new Filter_List_Elem'
172 (Filter
=> Filter
, Filter_On
=> Filter_On
,
173 User_Data
=> User_Data
, Next
=> null);
177 Descriptor
.Filters
:=
178 new Filter_List_Elem
'
179 (Filter => Filter, Filter_On => Filter_On,
180 User_Data => User_Data, Next => Descriptor.Filters);
188 procedure Call_Filters
189 (Pid : Process_Descriptor'Class;
191 Filter_On : Filter_Type)
193 Current_Filter : Filter_List;
196 if Pid.Filters_Lock = 0 then
197 Current_Filter := Pid.Filters;
199 while Current_Filter /= null loop
200 if Current_Filter.Filter_On = Filter_On then
201 Current_Filter.Filter
202 (Pid, Str, Current_Filter.User_Data);
205 Current_Filter := Current_Filter.Next;
215 (Descriptor : in out Process_Descriptor;
216 Status : out Integer)
218 Current_Filter : Filter_List;
219 Next_Filter : Filter_List;
222 if Descriptor.Input_Fd /= Invalid_FD then
223 Close (Descriptor.Input_Fd);
226 if Descriptor.Error_Fd /= Descriptor.Output_Fd then
227 Close (Descriptor.Error_Fd);
230 Close (Descriptor.Output_Fd);
232 -- ??? Should have timeouts for different signals
234 if Descriptor.Pid > 0 then -- see comment in Send_Signal
235 Kill (Descriptor.Pid, Sig_Num => 9, Close => 0);
238 GNAT.OS_Lib.Free (Descriptor.Buffer);
239 Descriptor.Buffer_Size := 0;
241 Current_Filter := Descriptor.Filters;
243 while Current_Filter /= null loop
244 Next_Filter := Current_Filter.Next;
245 Free (Current_Filter);
246 Current_Filter := Next_Filter;
249 Descriptor.Filters := null;
251 -- Check process id (see comment in Send_Signal)
253 if Descriptor.Pid > 0 then
254 Status := Waitpid (Descriptor.Pid);
256 raise Invalid_Process;
260 procedure Close (Descriptor : in out Process_Descriptor) is
262 pragma Unreferenced (Status);
264 Close (Descriptor, Status);
272 (Descriptor : in out Process_Descriptor;
273 Result : out Expect_Match;
275 Timeout : Integer := 10_000;
276 Full_Buffer : Boolean := False)
280 Expect (Descriptor, Result, Never_Match, Timeout, Full_Buffer);
282 Expect (Descriptor, Result, Compile (Regexp), Timeout, Full_Buffer);
287 (Descriptor : in out Process_Descriptor;
288 Result : out Expect_Match;
290 Matched : out GNAT.Regpat.Match_Array;
291 Timeout : Integer := 10_000;
292 Full_Buffer : Boolean := False)
295 pragma Assert (Matched'First = 0);
298 (Descriptor, Result, Never_Match, Matched, Timeout, Full_Buffer);
301 (Descriptor, Result, Compile (Regexp), Matched, Timeout,
307 (Descriptor : in out Process_Descriptor;
308 Result : out Expect_Match;
309 Regexp : GNAT.Regpat.Pattern_Matcher;
310 Timeout : Integer := 10_000;
311 Full_Buffer : Boolean := False)
313 Matched : GNAT.Regpat.Match_Array (0 .. 0);
314 pragma Warnings (Off, Matched);
316 Expect (Descriptor, Result, Regexp, Matched, Timeout, Full_Buffer);
320 (Descriptor : in out Process_Descriptor;
321 Result : out Expect_Match;
322 Regexp : GNAT.Regpat.Pattern_Matcher;
323 Matched : out GNAT.Regpat.Match_Array;
324 Timeout : Integer := 10_000;
325 Full_Buffer : Boolean := False)
328 Descriptors : Array_Of_Pd := (1 => Descriptor'Unrestricted_Access);
329 Try_Until : constant Time := Clock + Duration (Timeout) / 1000.0;
330 Timeout_Tmp : Integer := Timeout;
333 pragma Assert (Matched'First = 0);
334 Reinitialize_Buffer (Descriptor);
337 -- First, test if what is already in the buffer matches (This is
338 -- required if this package is used in multi-task mode, since one of
339 -- the tasks might have added something in the buffer, and we don't
340 -- want other tasks to wait for new input to be available before
341 -- checking the regexps).
344 (Regexp, Descriptor.Buffer (1 .. Descriptor.Buffer_Index), Matched);
346 if Descriptor.Buffer_Index >= 1 and then Matched (0).First /= 0 then
348 Descriptor.Last_Match_Start := Matched (0).First;
349 Descriptor.Last_Match_End := Matched (0).Last;
353 -- Else try to read new input
355 Expect_Internal (Descriptors, N, Timeout_Tmp, Full_Buffer);
358 when Expect_Internal_Error | Expect_Process_Died =>
361 when Expect_Timeout | Expect_Full_Buffer =>
369 -- Calculate the timeout for the next turn
371 -- Note that Timeout is, from the caller's perspective, the maximum
372 -- time until a match, not the maximum time until some output is
373 -- read, and thus cannot be reused as is for Expect_Internal.
375 if Timeout /= -1 then
376 Timeout_Tmp := Integer (Try_Until - Clock) * 1000;
378 if Timeout_Tmp < 0 then
379 Result := Expect_Timeout;
385 -- Even if we had the general timeout above, we have to test that the
386 -- last test we read from the external process didn't match.
389 (Regexp, Descriptor.Buffer (1 .. Descriptor.Buffer_Index), Matched);
391 if Matched (0).First /= 0 then
393 Descriptor.Last_Match_Start := Matched (0).First;
394 Descriptor.Last_Match_End := Matched (0).Last;
400 (Descriptor : in out Process_Descriptor;
401 Result : out Expect_Match;
402 Regexps : Regexp_Array;
403 Timeout : Integer := 10_000;
404 Full_Buffer : Boolean := False)
406 Patterns : Compiled_Regexp_Array (Regexps'Range);
408 Matched : GNAT.Regpat.Match_Array (0 .. 0);
409 pragma Warnings (Off, Matched);
412 for J in Regexps'Range loop
413 Patterns (J) := new Pattern_Matcher'(Compile
(Regexps
(J
).all));
416 Expect
(Descriptor
, Result
, Patterns
, Matched
, Timeout
, Full_Buffer
);
418 for J
in Regexps
'Range loop
424 (Descriptor
: in out Process_Descriptor
;
425 Result
: out Expect_Match
;
426 Regexps
: Compiled_Regexp_Array
;
427 Timeout
: Integer := 10_000
;
428 Full_Buffer
: Boolean := False)
430 Matched
: GNAT
.Regpat
.Match_Array
(0 .. 0);
431 pragma Warnings
(Off
, Matched
);
433 Expect
(Descriptor
, Result
, Regexps
, Matched
, Timeout
, Full_Buffer
);
437 (Result
: out Expect_Match
;
438 Regexps
: Multiprocess_Regexp_Array
;
439 Timeout
: Integer := 10_000
;
440 Full_Buffer
: Boolean := False)
442 Matched
: GNAT
.Regpat
.Match_Array
(0 .. 0);
443 pragma Warnings
(Off
, Matched
);
445 Expect
(Result
, Regexps
, Matched
, Timeout
, Full_Buffer
);
449 (Descriptor
: in out Process_Descriptor
;
450 Result
: out Expect_Match
;
451 Regexps
: Regexp_Array
;
452 Matched
: out GNAT
.Regpat
.Match_Array
;
453 Timeout
: Integer := 10_000
;
454 Full_Buffer
: Boolean := False)
456 Patterns
: Compiled_Regexp_Array
(Regexps
'Range);
459 pragma Assert
(Matched
'First = 0);
461 for J
in Regexps
'Range loop
462 Patterns
(J
) := new Pattern_Matcher
'(Compile (Regexps (J).all));
465 Expect (Descriptor, Result, Patterns, Matched, Timeout, Full_Buffer);
467 for J in Regexps'Range loop
473 (Descriptor : in out Process_Descriptor;
474 Result : out Expect_Match;
475 Regexps : Compiled_Regexp_Array;
476 Matched : out GNAT.Regpat.Match_Array;
477 Timeout : Integer := 10_000;
478 Full_Buffer : Boolean := False)
481 Descriptors : Array_Of_Pd := (1 => Descriptor'Unrestricted_Access);
484 pragma Assert (Matched'First = 0);
486 Reinitialize_Buffer (Descriptor);
489 -- First, test if what is already in the buffer matches (This is
490 -- required if this package is used in multi-task mode, since one of
491 -- the tasks might have added something in the buffer, and we don't
492 -- want other tasks to wait for new input to be available before
493 -- checking the regexps).
495 if Descriptor.Buffer /= null then
496 for J in Regexps'Range loop
499 Descriptor.Buffer (1 .. Descriptor.Buffer_Index),
502 if Matched (0) /= No_Match then
503 Result := Expect_Match (J);
504 Descriptor.Last_Match_Start := Matched (0).First;
505 Descriptor.Last_Match_End := Matched (0).Last;
511 Expect_Internal (Descriptors, N, Timeout, Full_Buffer);
514 when Expect_Internal_Error | Expect_Process_Died =>
517 when Expect_Timeout | Expect_Full_Buffer =>
528 (Result : out Expect_Match;
529 Regexps : Multiprocess_Regexp_Array;
530 Matched : out GNAT.Regpat.Match_Array;
531 Timeout : Integer := 10_000;
532 Full_Buffer : Boolean := False)
535 Descriptors : Array_Of_Pd (Regexps'Range);
538 pragma Assert (Matched'First = 0);
540 for J in Descriptors'Range loop
541 Descriptors (J) := Regexps (J).Descriptor;
543 if Descriptors (J) /= null then
544 Reinitialize_Buffer (Regexps (J).Descriptor.all);
549 -- First, test if what is already in the buffer matches (This is
550 -- required if this package is used in multi-task mode, since one of
551 -- the tasks might have added something in the buffer, and we don't
552 -- want other tasks to wait for new input to be available before
553 -- checking the regexps).
555 for J in Regexps'Range loop
556 if Regexps (J).Regexp /= null
557 and then Regexps (J).Descriptor /= null
559 Match (Regexps (J).Regexp.all,
560 Regexps (J).Descriptor.Buffer
561 (1 .. Regexps (J).Descriptor.Buffer_Index),
564 if Matched (0) /= No_Match then
565 Result := Expect_Match (J);
566 Regexps (J).Descriptor.Last_Match_Start := Matched (0).First;
567 Regexps (J).Descriptor.Last_Match_End := Matched (0).Last;
573 Expect_Internal (Descriptors, N, Timeout, Full_Buffer);
576 when Expect_Internal_Error | Expect_Process_Died =>
579 when Expect_Timeout | Expect_Full_Buffer =>
589 ---------------------
590 -- Expect_Internal --
591 ---------------------
593 procedure Expect_Internal
594 (Descriptors : in out Array_Of_Pd;
595 Result : out Expect_Match;
597 Full_Buffer : Boolean)
599 Num_Descriptors : Integer;
600 Buffer_Size : Integer := 0;
604 type File_Descriptor_Array is
605 array (0 .. Descriptors'Length - 1) of File_Descriptor;
606 Fds : aliased File_Descriptor_Array;
607 Fds_Count : Natural := 0;
609 Fds_To_Descriptor : array (Fds'Range) of Integer;
610 -- Maps file descriptor entries from Fds to entries in Descriptors.
611 -- They do not have the same index when entries in Descriptors are null.
613 type Integer_Array is array (Fds'Range) of Integer;
614 Is_Set : aliased Integer_Array;
617 for J in Descriptors'Range loop
618 if Descriptors (J) /= null then
619 Fds (Fds'First + Fds_Count) := Descriptors (J).Output_Fd;
620 Fds_To_Descriptor (Fds'First + Fds_Count) := J;
621 Fds_Count := Fds_Count + 1;
623 if Descriptors (J).Buffer_Size = 0 then
624 Buffer_Size := Integer'Max (Buffer_Size, 4096);
627 Integer'Max (Buffer_Size, Descriptors (J).Buffer_Size);
633 Buffer : aliased String (1 .. Buffer_Size);
634 -- Buffer used for input. This is allocated only once, not for
635 -- every iteration of the loop
638 -- Index in Descriptors
641 -- Loop until we match or we have a timeout
645 Poll (Fds'Address, Fds_Count, Timeout, Is_Set'Address);
647 case Num_Descriptors is
652 Result := Expect_Internal_Error;
658 Result := Expect_Timeout;
664 for F in Fds'Range loop
665 if Is_Set (F) = 1 then
666 D := Fds_To_Descriptor (F);
668 Buffer_Size := Descriptors (D).Buffer_Size;
670 if Buffer_Size = 0 then
674 N := Read (Descriptors (D).Output_Fd, Buffer'Address,
677 -- Error or End of file
680 -- ??? Note that ddd tries again up to three times
681 -- in that case. See LiterateA.C:174
683 Descriptors (D).Input_Fd := Invalid_FD;
684 Result := Expect_Process_Died;
688 -- If there is no limit to the buffer size
690 if Descriptors (D).Buffer_Size = 0 then
693 Tmp : String_Access := Descriptors (D).Buffer;
697 Descriptors (D).Buffer :=
698 new String (1 .. Tmp'Length + N);
699 Descriptors (D).Buffer (1 .. Tmp'Length) :=
701 Descriptors (D).Buffer
702 (Tmp'Length + 1 .. Tmp'Length + N) :=
705 Descriptors (D).Buffer_Index :=
706 Descriptors (D).Buffer'Last;
709 Descriptors (D).Buffer :=
711 Descriptors (D).Buffer.all :=
713 Descriptors (D).Buffer_Index := N;
718 -- Add what we read to the buffer
720 if Descriptors (D).Buffer_Index + N >
721 Descriptors (D).Buffer_Size
723 -- If the user wants to know when we have
724 -- read more than the buffer can contain.
727 Result := Expect_Full_Buffer;
731 -- Keep as much as possible from the buffer,
732 -- and forget old characters.
734 Descriptors (D).Buffer
735 (1 .. Descriptors (D).Buffer_Size - N) :=
736 Descriptors (D).Buffer
737 (N - Descriptors (D).Buffer_Size +
738 Descriptors (D).Buffer_Index + 1 ..
739 Descriptors (D).Buffer_Index);
740 Descriptors (D).Buffer_Index :=
741 Descriptors (D).Buffer_Size - N;
744 -- Keep what we read in the buffer
746 Descriptors (D).Buffer
747 (Descriptors (D).Buffer_Index + 1 ..
748 Descriptors (D).Buffer_Index + N) :=
750 Descriptors (D).Buffer_Index :=
751 Descriptors (D).Buffer_Index + N;
754 -- Call each of the output filter with what we
758 (Descriptors (D).all, Buffer (1 .. N), Output);
760 Result := Expect_Match (D);
774 function Expect_Out (Descriptor : Process_Descriptor) return String is
776 return Descriptor.Buffer (1 .. Descriptor.Last_Match_End);
779 ----------------------
780 -- Expect_Out_Match --
781 ----------------------
783 function Expect_Out_Match (Descriptor : Process_Descriptor) return String is
785 return Descriptor.Buffer
786 (Descriptor.Last_Match_Start .. Descriptor.Last_Match_End);
787 end Expect_Out_Match;
789 ------------------------
790 -- First_Dead_Process --
791 ------------------------
793 function First_Dead_Process
794 (Regexp : Multiprocess_Regexp_Array) return Natural is
796 for R in Regexp'Range loop
797 if Regexp (R).Descriptor /= null
798 and then Regexp (R).Descriptor.Input_Fd = GNAT.OS_Lib.Invalid_FD
805 end First_Dead_Process;
812 (Descriptor : in out Process_Descriptor;
813 Timeout : Integer := 0)
815 Buffer_Size : constant Integer := 8192;
816 Num_Descriptors : Integer;
818 Is_Set : aliased Integer;
819 Buffer : aliased String (1 .. Buffer_Size);
822 -- Empty the current buffer
824 Descriptor.Last_Match_End := Descriptor.Buffer_Index;
825 Reinitialize_Buffer (Descriptor);
827 -- Read everything from the process to flush its output
831 Poll (Descriptor.Output_Fd'Address, 1, Timeout, Is_Set'Address);
833 case Num_Descriptors is
840 -- Timeout => End of flush
849 N := Read (Descriptor.Output_Fd, Buffer'Address,
866 procedure Free (Regexp : in out Multiprocess_Regexp) is
867 procedure Unchecked_Free is new Ada.Unchecked_Deallocation
868 (Process_Descriptor'Class, Process_Descriptor_Access);
870 Unchecked_Free (Regexp.Descriptor);
871 Free (Regexp.Regexp);
874 ------------------------
875 -- Get_Command_Output --
876 ------------------------
878 function Get_Command_Output
880 Arguments : GNAT.OS_Lib.Argument_List;
882 Status : not null access Integer;
883 Err_To_Out : Boolean := False) return String
887 Process : Process_Descriptor;
889 Output : String_Access := new String (1 .. 1024);
890 -- Buffer used to accumulate standard output from the launched
891 -- command, expanded as necessary during execution.
894 -- Index of the last used character within Output
898 (Process, Command, Arguments, Err_To_Out => Err_To_Out);
900 if Input'Length > 0 then
901 Send (Process, Input);
904 Close (Process.Input_Fd);
905 Process.Input_Fd := Invalid_FD;
908 Result : Expect_Match;
909 pragma Unreferenced (Result);
912 -- This loop runs until the call to Expect raises Process_Died
915 Expect (Process, Result, ".+");
918 NOutput : String_Access;
919 S : constant String := Expect_Out (Process);
920 pragma Assert (S'Length > 0);
923 -- Expand buffer if we need more space. Note here that we add
924 -- S'Length to ensure that S will fit in the new buffer size.
926 if Last + S'Length > Output'Last then
927 NOutput := new String (1 .. 2 * Output'Last + S'Length);
928 NOutput (Output'Range) := Output.all;
931 -- Here if current buffer size is OK
937 NOutput (Last + 1 .. Last + S'Length) := S;
938 Last := Last + S'Length;
945 Close (Process, Status.all);
953 S : constant String := Output (1 .. Last);
958 end Get_Command_Output;
964 function Get_Error_Fd
965 (Descriptor : Process_Descriptor) return GNAT.OS_Lib.File_Descriptor
968 return Descriptor.Error_Fd;
975 function Get_Input_Fd
976 (Descriptor : Process_Descriptor) return GNAT.OS_Lib.File_Descriptor
979 return Descriptor.Input_Fd;
986 function Get_Output_Fd
987 (Descriptor : Process_Descriptor) return GNAT.OS_Lib.File_Descriptor
990 return Descriptor.Output_Fd;
998 (Descriptor : Process_Descriptor) return Process_Id
1001 return Descriptor.Pid;
1008 function Has_Process (Regexp : Multiprocess_Regexp_Array) return Boolean is
1010 return Regexp /= (Regexp'Range => (null, null));
1017 procedure Interrupt (Descriptor : in out Process_Descriptor) is
1018 SIGINT : constant := 2;
1020 Send_Signal (Descriptor, SIGINT);
1027 procedure Lock_Filters (Descriptor : in out Process_Descriptor) is
1029 Descriptor.Filters_Lock := Descriptor.Filters_Lock + 1;
1032 ------------------------
1033 -- Non_Blocking_Spawn --
1034 ------------------------
1036 procedure Non_Blocking_Spawn
1037 (Descriptor : out Process_Descriptor'Class;
1039 Args : GNAT.OS_Lib.Argument_List;
1040 Buffer_Size : Natural := 4096;
1041 Err_To_Out : Boolean := False)
1043 function Fork return Process_Id;
1044 pragma Import (C, Fork, "__gnat_expect_fork");
1045 -- Starts a new process if possible. See the Unix command fork for more
1046 -- information. On systems that do not support this capability (such as
1047 -- Windows...), this command does nothing, and Fork will return
1050 Pipe1, Pipe2, Pipe3 : aliased Pipe_Type;
1052 Arg : String_Access;
1053 Arg_List : String_List (1 .. Args'Length + 2);
1054 C_Arg_List : aliased array (1 .. Args'Length + 2) of System.Address;
1056 Command_With_Path : String_Access;
1059 -- Create the rest of the pipes
1061 Set_Up_Communications
1062 (Descriptor, Err_To_Out, Pipe1'Access, Pipe2'Access, Pipe3'Access);
1064 Command_With_Path := Locate_Exec_On_Path (Command);
1066 if Command_With_Path = null then
1067 raise Invalid_Process;
1070 -- Fork a new process
1072 Descriptor.Pid := Fork;
1074 -- Are we now in the child (or, for Windows, still in the common
1077 if Descriptor.Pid = Null_Pid then
1078 -- Prepare an array of arguments to pass to C
1080 Arg := new String (1 .. Command_With_Path'Length + 1);
1081 Arg (1 .. Command_With_Path'Length) := Command_With_Path.all;
1082 Arg (Arg'Last) := ASCII.NUL;
1083 Arg_List (1) := Arg;
1085 for J in Args'Range loop
1086 Arg := new String (1 .. Args (J)'Length + 1);
1087 Arg (1 .. Args (J)'Length) := Args (J).all;
1088 Arg (Arg'Last) := ASCII.NUL;
1089 Arg_List (J + 2 - Args'First) := Arg.all'Access;
1092 Arg_List (Arg_List'Last) := null;
1094 -- Make sure all arguments are compatible with OS conventions
1096 Normalize_Arguments (Arg_List);
1098 -- Prepare low-level argument list from the normalized arguments
1100 for K in Arg_List'Range loop
1102 (if Arg_List (K) /= null
1103 then Arg_List (K).all'Address
1104 else System.Null_Address);
1107 -- This does not return on Unix systems
1109 Set_Up_Child_Communications
1110 (Descriptor, Pipe1, Pipe2, Pipe3, Command_With_Path.all,
1111 C_Arg_List'Address);
1114 Free (Command_With_Path);
1116 -- Did we have an error when spawning the child ?
1118 if Descriptor.Pid < Null_Pid then
1119 raise Invalid_Process;
1121 -- We are now in the parent process
1123 Set_Up_Parent_Communications (Descriptor, Pipe1, Pipe2, Pipe3);
1126 -- Create the buffer
1128 Descriptor.Buffer_Size := Buffer_Size;
1130 if Buffer_Size /= 0 then
1131 Descriptor.Buffer := new String (1 .. Positive (Buffer_Size));
1134 -- Initialize the filters
1136 Descriptor.Filters := null;
1137 end Non_Blocking_Spawn;
1139 -------------------------
1140 -- Reinitialize_Buffer --
1141 -------------------------
1143 procedure Reinitialize_Buffer
1144 (Descriptor : in out Process_Descriptor'Class)
1147 if Descriptor.Buffer_Size = 0 then
1149 Tmp : String_Access := Descriptor.Buffer;
1152 Descriptor.Buffer :=
1154 (1 .. Descriptor.Buffer_Index - Descriptor.Last_Match_End);
1157 Descriptor.Buffer.all := Tmp
1158 (Descriptor.Last_Match_End + 1 .. Descriptor.Buffer_Index);
1163 Descriptor.Buffer_Index := Descriptor.Buffer'Last;
1167 (1 .. Descriptor.Buffer_Index - Descriptor.Last_Match_End) :=
1169 (Descriptor.Last_Match_End + 1 .. Descriptor.Buffer_Index);
1171 if Descriptor.Buffer_Index > Descriptor.Last_Match_End then
1172 Descriptor.Buffer_Index :=
1173 Descriptor.Buffer_Index - Descriptor.Last_Match_End;
1175 Descriptor.Buffer_Index := 0;
1179 Descriptor.Last_Match_Start := 0;
1180 Descriptor.Last_Match_End := 0;
1181 end Reinitialize_Buffer;
1187 procedure Remove_Filter
1188 (Descriptor : in out Process_Descriptor;
1189 Filter : Filter_Function)
1191 Previous : Filter_List := null;
1192 Current : Filter_List := Descriptor.Filters;
1195 while Current /= null loop
1196 if Current.Filter = Filter then
1197 if Previous = null then
1198 Descriptor.Filters := Current.Next;
1200 Previous.Next := Current.Next;
1204 Previous := Current;
1205 Current := Current.Next;
1214 (Descriptor : in out Process_Descriptor;
1216 Add_LF : Boolean := True;
1217 Empty_Buffer : Boolean := False)
1219 Line_Feed : aliased constant String := (1 .. 1 => ASCII.LF);
1220 Descriptors : Array_Of_Pd := (1 => Descriptor'Unrestricted_Access);
1222 Result : Expect_Match;
1224 pragma Warnings (Off, Result);
1225 pragma Warnings (Off, Discard);
1228 if Empty_Buffer then
1230 -- Force a read on the process if there is anything waiting
1233 (Descriptors, Result, Timeout => 0, Full_Buffer => False);
1235 if Result = Expect_Internal_Error
1236 or else Result = Expect_Process_Died
1241 Descriptor.Last_Match_End := Descriptor.Buffer_Index;
1245 Reinitialize_Buffer (Descriptor);
1248 Call_Filters (Descriptor, Str, Input);
1250 Write (Descriptor.Input_Fd, Str'Address, Str'Last - Str'First + 1);
1253 Call_Filters (Descriptor, Line_Feed, Input);
1255 Write (Descriptor.Input_Fd, Line_Feed'Address, 1);
1263 procedure Send_Signal
1264 (Descriptor : Process_Descriptor;
1268 -- A nonpositive process id passed to kill has special meanings. For
1269 -- example, -1 means kill all processes in sight, including self, in
1270 -- POSIX and Windows (and something slightly different in Linux). See
1271 -- man pages for details. In any case, we don't want to do that. Note
1272 -- that Descriptor.Pid will be -1 if the process was not successfully
1273 -- started; we don't want to kill ourself in that case.
1275 if Descriptor.Pid > 0 then
1276 Kill (Descriptor.Pid, Signal, Close => 1);
1277 -- ??? Need to check process status here
1279 raise Invalid_Process;
1283 ---------------------------------
1284 -- Set_Up_Child_Communications --
1285 ---------------------------------
1287 procedure Set_Up_Child_Communications
1288 (Pid : in out Process_Descriptor;
1289 Pipe1 : in out Pipe_Type;
1290 Pipe2 : in out Pipe_Type;
1291 Pipe3 : in out Pipe_Type;
1293 Args : System.Address)
1295 pragma Warnings (Off, Pid);
1296 pragma Warnings (Off, Pipe1);
1297 pragma Warnings (Off, Pipe2);
1298 pragma Warnings (Off, Pipe3);
1300 Input : File_Descriptor;
1301 Output : File_Descriptor;
1302 Error : File_Descriptor;
1304 No_Fork_On_Target : constant Boolean := Target_OS = Windows;
1307 if No_Fork_On_Target then
1309 -- Since Windows does not have a separate fork/exec, we need to
1310 -- perform the following actions:
1312 -- - save stdin, stdout, stderr
1313 -- - replace them by our pipes
1314 -- - create the child with process handle inheritance
1315 -- - revert to the previous stdin, stdout and stderr.
1317 Input := Dup (GNAT.OS_Lib.Standin);
1318 Output := Dup (GNAT.OS_Lib.Standout);
1319 Error := Dup (GNAT.OS_Lib.Standerr);
1322 -- Since we are still called from the parent process, there is no way
1323 -- currently we can cleanly close the unneeded ends of the pipes, but
1324 -- this doesn't really matter.
1326 -- We could close Pipe1.Output, Pipe2.Input, Pipe3.Input
1328 Dup2 (Pipe1.Input, GNAT.OS_Lib.Standin);
1329 Dup2 (Pipe2.Output, GNAT.OS_Lib.Standout);
1330 Dup2 (Pipe3.Output, GNAT.OS_Lib.Standerr);
1332 Portable_Execvp (Pid.Pid'Access, Cmd & ASCII.NUL, Args);
1334 -- The following commands are not executed on Unix systems, and are only
1335 -- required for Windows systems. We are now in the parent process.
1337 -- Restore the old descriptors
1339 Dup2 (Input, GNAT.OS_Lib.Standin);
1340 Dup2 (Output, GNAT.OS_Lib.Standout);
1341 Dup2 (Error, GNAT.OS_Lib.Standerr);
1345 end Set_Up_Child_Communications;
1347 ---------------------------
1348 -- Set_Up_Communications --
1349 ---------------------------
1351 procedure Set_Up_Communications
1352 (Pid : in out Process_Descriptor;
1353 Err_To_Out : Boolean;
1354 Pipe1 : not null access Pipe_Type;
1355 Pipe2 : not null access Pipe_Type;
1356 Pipe3 : not null access Pipe_Type)
1359 pragma Unreferenced (Status);
1364 if Create_Pipe (Pipe1) /= 0 then
1368 if Create_Pipe (Pipe2) /= 0 then
1372 -- Record the 'parent
' end of the two pipes in Pid:
1373 -- Child stdin is connected to the 'write
' end of Pipe1;
1374 -- Child stdout is connected to the 'read
' end of Pipe2.
1375 -- We do not want these descriptors to remain open in the child
1376 -- process, so we mark them close-on-exec/non-inheritable.
1378 Pid.Input_Fd := Pipe1.Output;
1379 Set_Close_On_Exec (Pipe1.Output, True, Status);
1380 Pid.Output_Fd := Pipe2.Input;
1381 Set_Close_On_Exec (Pipe2.Input, True, Status);
1385 -- Reuse the standard output pipe for standard error
1387 Pipe3.all := Pipe2.all;
1390 -- Create a separate pipe for standard error
1392 if Create_Pipe (Pipe3) /= 0 then
1397 -- As above, record the proper fd for the child's standard error stream
1399 Pid.Error_Fd := Pipe3.Input;
1400 Set_Close_On_Exec (Pipe3.Input, True, Status);
1401 end Set_Up_Communications;
1403 ----------------------------------
1404 -- Set_Up_Parent_Communications --
1405 ----------------------------------
1407 procedure Set_Up_Parent_Communications
1408 (Pid : in out Process_Descriptor;
1409 Pipe1 : in out Pipe_Type;
1410 Pipe2 : in out Pipe_Type;
1411 Pipe3 : in out Pipe_Type)
1413 pragma Warnings (Off, Pid);
1414 pragma Warnings (Off, Pipe1);
1415 pragma Warnings (Off, Pipe2);
1416 pragma Warnings (Off, Pipe3);
1419 Close (Pipe1.Input);
1420 Close (Pipe2.Output);
1422 if Pipe3.Output /= Pipe2.Output then
1423 Close (Pipe3.Output);
1425 end Set_Up_Parent_Communications;
1431 procedure Trace_Filter
1432 (Descriptor : Process_Descriptor'Class;
1434 User_Data : System.Address := System.Null_Address)
1436 pragma Warnings (Off, Descriptor);
1437 pragma Warnings (Off, User_Data);
1442 --------------------
1443 -- Unlock_Filters --
1444 --------------------
1446 procedure Unlock_Filters (Descriptor : in out Process_Descriptor) is
1448 if Descriptor.Filters_Lock > 0 then
1449 Descriptor.Filters_Lock := Descriptor.Filters_Lock - 1;