1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- G N A T . E X P E C T --
9 -- Copyright (C) 2000-2009, 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 Ada.Calendar; use Ada.Calendar;
38 with GNAT.OS_Lib; use GNAT.OS_Lib;
39 with GNAT.Regpat; use GNAT.Regpat;
41 with Ada.Unchecked_Deallocation;
43 package body GNAT.Expect is
45 type Array_Of_Pd is array (Positive range <>) of Process_Descriptor_Access;
47 procedure Expect_Internal
48 (Descriptors : in out Array_Of_Pd;
49 Result : out Expect_Match;
51 Full_Buffer : Boolean);
52 -- Internal function used to read from the process Descriptor.
54 -- Three outputs are possible:
55 -- Result=Expect_Timeout, if no output was available before the timeout
57 -- Result=Expect_Full_Buffer, if Full_Buffer is True and some characters
58 -- had to be discarded from the internal buffer of Descriptor.
59 -- Result=<integer>, indicates how many characters were added to the
60 -- internal buffer. These characters are from indexes
61 -- Descriptor.Buffer_Index - Result + 1 .. Descriptor.Buffer_Index
62 -- Process_Died is raised if the process is no longer valid.
64 procedure Reinitialize_Buffer
65 (Descriptor : in out Process_Descriptor'Class);
66 -- Reinitialize the internal buffer.
67 -- The buffer is deleted up to the end of the last match.
69 procedure Free is new Ada.Unchecked_Deallocation
70 (Pattern_Matcher, Pattern_Matcher_Access);
72 procedure Free is new Ada.Unchecked_Deallocation
73 (Filter_List_Elem, Filter_List);
75 procedure Call_Filters
76 (Pid : Process_Descriptor'Class;
78 Filter_On : Filter_Type);
79 -- Call all the filters that have the appropriate type.
80 -- This function does nothing if the filters are locked
82 ------------------------------
83 -- Target dependent section --
84 ------------------------------
86 function Dup (Fd : File_Descriptor) return File_Descriptor;
87 pragma Import (C, Dup);
89 procedure Dup2 (Old_Fd, New_Fd : File_Descriptor);
90 pragma Import (C, Dup2);
92 procedure Kill (Pid : Process_Id; Sig_Num : Integer; Close : Integer);
93 pragma Import (C, Kill, "__gnat_kill");
94 -- if Close is set to 1 all OS resources used by the Pid must be freed
96 function Create_Pipe (Pipe : not null access Pipe_Type) return Integer;
97 pragma Import (C, Create_Pipe, "__gnat_pipe");
100 (Fds : System.Address;
103 Is_Set : System.Address) return Integer;
104 pragma Import (C, Poll, "__gnat_expect_poll");
105 -- Check whether there is any data waiting on the file descriptor
106 -- Out_fd, and wait if there is none, at most Timeout milliseconds
107 -- Returns -1 in case of error, 0 if the timeout expired before
108 -- data became available.
110 -- Out_Is_Set is set to 1 if data was available, 0 otherwise.
112 function Waitpid (Pid : Process_Id) return Integer;
113 pragma Import (C, Waitpid, "__gnat_waitpid");
114 -- Wait for a specific process id, and return its exit code
120 function "+" (S : String) return GNAT.OS_Lib.String_Access is
122 return new String'(S);
130 (P : GNAT.Regpat.Pattern_Matcher) return Pattern_Matcher_Access
133 return new GNAT.Regpat.Pattern_Matcher'(P);
141 (Descriptor : in out Process_Descriptor;
142 Filter : Filter_Function;
143 Filter_On : Filter_Type := Output;
144 User_Data : System.Address := System.Null_Address;
145 After : Boolean := False)
147 Current : Filter_List := Descriptor.Filters;
151 while Current /= null and then Current.Next /= null loop
152 Current := Current.Next;
155 if Current = null then
156 Descriptor.Filters :=
157 new Filter_List_Elem'
158 (Filter => Filter, Filter_On => Filter_On,
159 User_Data => User_Data, Next => null);
162 new Filter_List_Elem'
163 (Filter => Filter, Filter_On => Filter_On,
164 User_Data => User_Data, Next => null);
168 Descriptor.Filters :=
169 new Filter_List_Elem'
170 (Filter => Filter, Filter_On => Filter_On,
171 User_Data => User_Data, Next => Descriptor.Filters);
179 procedure Call_Filters
180 (Pid : Process_Descriptor'Class;
182 Filter_On : Filter_Type)
184 Current_Filter : Filter_List;
187 if Pid.Filters_Lock = 0 then
188 Current_Filter := Pid.Filters;
190 while Current_Filter /= null loop
191 if Current_Filter.Filter_On = Filter_On then
192 Current_Filter.Filter
193 (Pid, Str, Current_Filter.User_Data);
196 Current_Filter := Current_Filter.Next;
206 (Descriptor : in out Process_Descriptor;
207 Status : out Integer)
209 Current_Filter : Filter_List;
210 Next_Filter : Filter_List;
213 Close (Descriptor.Input_Fd);
215 if Descriptor.Error_Fd /= Descriptor.Output_Fd then
216 Close (Descriptor.Error_Fd);
219 Close (Descriptor.Output_Fd);
221 -- ??? Should have timeouts for different signals
223 if Descriptor.Pid > 0 then -- see comment in Send_Signal
224 Kill (Descriptor.Pid, Sig_Num => 9, Close => 0);
227 GNAT.OS_Lib.Free (Descriptor.Buffer);
228 Descriptor.Buffer_Size := 0;
230 Current_Filter := Descriptor.Filters;
232 while Current_Filter /= null loop
233 Next_Filter := Current_Filter.Next;
234 Free (Current_Filter);
235 Current_Filter := Next_Filter;
238 Descriptor.Filters := null;
240 -- Check process id (see comment in Send_Signal)
242 if Descriptor.Pid > 0 then
243 Status := Waitpid (Descriptor.Pid);
245 raise Invalid_Process;
249 procedure Close (Descriptor : in out Process_Descriptor) is
251 pragma Unreferenced (Status);
253 Close (Descriptor, Status);
261 (Descriptor : in out Process_Descriptor;
262 Result : out Expect_Match;
264 Timeout : Integer := 10_000;
265 Full_Buffer : Boolean := False)
269 Expect (Descriptor, Result, Never_Match, Timeout, Full_Buffer);
271 Expect (Descriptor, Result, Compile (Regexp), Timeout, Full_Buffer);
276 (Descriptor : in out Process_Descriptor;
277 Result : out Expect_Match;
279 Matched : out GNAT.Regpat.Match_Array;
280 Timeout : Integer := 10_000;
281 Full_Buffer : Boolean := False)
284 pragma Assert (Matched'First = 0);
287 (Descriptor, Result, Never_Match, Matched, Timeout, Full_Buffer);
290 (Descriptor, Result, Compile (Regexp), Matched, Timeout,
296 (Descriptor : in out Process_Descriptor;
297 Result : out Expect_Match;
298 Regexp : GNAT.Regpat.Pattern_Matcher;
299 Timeout : Integer := 10_000;
300 Full_Buffer : Boolean := False)
302 Matched : GNAT.Regpat.Match_Array (0 .. 0);
303 pragma Warnings (Off, Matched);
305 Expect (Descriptor, Result, Regexp, Matched, Timeout, Full_Buffer);
309 (Descriptor : in out Process_Descriptor;
310 Result : out Expect_Match;
311 Regexp : GNAT.Regpat.Pattern_Matcher;
312 Matched : out GNAT.Regpat.Match_Array;
313 Timeout : Integer := 10_000;
314 Full_Buffer : Boolean := False)
317 Descriptors : Array_Of_Pd := (1 => Descriptor'Unrestricted_Access);
318 Try_Until : constant Time := Clock + Duration (Timeout) / 1000.0;
319 Timeout_Tmp : Integer := Timeout;
322 pragma Assert (Matched'First = 0);
323 Reinitialize_Buffer (Descriptor);
326 -- First, test if what is already in the buffer matches (This is
327 -- required if this package is used in multi-task mode, since one of
328 -- the tasks might have added something in the buffer, and we don't
329 -- want other tasks to wait for new input to be available before
330 -- checking the regexps).
333 (Regexp, Descriptor.Buffer (1 .. Descriptor.Buffer_Index), Matched);
335 if Descriptor.Buffer_Index >= 1 and then Matched (0).First /= 0 then
337 Descriptor.Last_Match_Start := Matched (0).First;
338 Descriptor.Last_Match_End := Matched (0).Last;
342 -- Else try to read new input
344 Expect_Internal (Descriptors, N, Timeout_Tmp, Full_Buffer);
346 if N = Expect_Timeout or else N = Expect_Full_Buffer then
351 -- Calculate the timeout for the next turn
353 -- Note that Timeout is, from the caller's perspective, the maximum
354 -- time until a match, not the maximum time until some output is
355 -- read, and thus cannot be reused as is for Expect_Internal.
357 if Timeout /= -1 then
358 Timeout_Tmp := Integer (Try_Until - Clock) * 1000;
360 if Timeout_Tmp < 0 then
361 Result := Expect_Timeout;
367 -- Even if we had the general timeout above, we have to test that the
368 -- last test we read from the external process didn't match.
371 (Regexp, Descriptor.Buffer (1 .. Descriptor.Buffer_Index), Matched);
373 if Matched (0).First /= 0 then
375 Descriptor.Last_Match_Start := Matched (0).First;
376 Descriptor.Last_Match_End := Matched (0).Last;
382 (Descriptor : in out Process_Descriptor;
383 Result : out Expect_Match;
384 Regexps : Regexp_Array;
385 Timeout : Integer := 10_000;
386 Full_Buffer : Boolean := False)
388 Patterns : Compiled_Regexp_Array (Regexps'Range);
390 Matched : GNAT.Regpat.Match_Array (0 .. 0);
391 pragma Warnings (Off, Matched);
394 for J in Regexps'Range loop
395 Patterns (J) := new Pattern_Matcher'(Compile (Regexps (J).all));
398 Expect (Descriptor, Result, Patterns, Matched, Timeout, Full_Buffer);
400 for J in Regexps'Range loop
406 (Descriptor : in out Process_Descriptor;
407 Result : out Expect_Match;
408 Regexps : Compiled_Regexp_Array;
409 Timeout : Integer := 10_000;
410 Full_Buffer : Boolean := False)
412 Matched : GNAT.Regpat.Match_Array (0 .. 0);
413 pragma Warnings (Off, Matched);
415 Expect (Descriptor, Result, Regexps, Matched, Timeout, Full_Buffer);
419 (Result : out Expect_Match;
420 Regexps : Multiprocess_Regexp_Array;
421 Timeout : Integer := 10_000;
422 Full_Buffer : Boolean := False)
424 Matched : GNAT.Regpat.Match_Array (0 .. 0);
425 pragma Warnings (Off, Matched);
427 Expect (Result, Regexps, Matched, Timeout, Full_Buffer);
431 (Descriptor : in out Process_Descriptor;
432 Result : out Expect_Match;
433 Regexps : Regexp_Array;
434 Matched : out GNAT.Regpat.Match_Array;
435 Timeout : Integer := 10_000;
436 Full_Buffer : Boolean := False)
438 Patterns : Compiled_Regexp_Array (Regexps'Range);
441 pragma Assert (Matched'First = 0);
443 for J in Regexps'Range loop
444 Patterns (J) := new Pattern_Matcher'(Compile (Regexps (J).all));
447 Expect (Descriptor, Result, Patterns, Matched, Timeout, Full_Buffer);
449 for J in Regexps'Range loop
455 (Descriptor : in out Process_Descriptor;
456 Result : out Expect_Match;
457 Regexps : Compiled_Regexp_Array;
458 Matched : out GNAT.Regpat.Match_Array;
459 Timeout : Integer := 10_000;
460 Full_Buffer : Boolean := False)
463 Descriptors : Array_Of_Pd := (1 => Descriptor'Unrestricted_Access);
466 pragma Assert (Matched'First = 0);
468 Reinitialize_Buffer (Descriptor);
471 -- First, test if what is already in the buffer matches (This is
472 -- required if this package is used in multi-task mode, since one of
473 -- the tasks might have added something in the buffer, and we don't
474 -- want other tasks to wait for new input to be available before
475 -- checking the regexps).
477 if Descriptor.Buffer /= null then
478 for J in Regexps'Range loop
481 Descriptor.Buffer (1 .. Descriptor.Buffer_Index),
484 if Matched (0) /= No_Match then
485 Result := Expect_Match (J);
486 Descriptor.Last_Match_Start := Matched (0).First;
487 Descriptor.Last_Match_End := Matched (0).Last;
493 Expect_Internal (Descriptors, N, Timeout, Full_Buffer);
495 if N = Expect_Timeout or else N = Expect_Full_Buffer then
503 (Result : out Expect_Match;
504 Regexps : Multiprocess_Regexp_Array;
505 Matched : out GNAT.Regpat.Match_Array;
506 Timeout : Integer := 10_000;
507 Full_Buffer : Boolean := False)
510 Descriptors : Array_Of_Pd (Regexps'Range);
513 pragma Assert (Matched'First = 0);
515 for J in Descriptors'Range loop
516 Descriptors (J) := Regexps (J).Descriptor;
517 Reinitialize_Buffer (Regexps (J).Descriptor.all);
521 -- First, test if what is already in the buffer matches (This is
522 -- required if this package is used in multi-task mode, since one of
523 -- the tasks might have added something in the buffer, and we don't
524 -- want other tasks to wait for new input to be available before
525 -- checking the regexps).
527 for J in Regexps'Range loop
528 Match (Regexps (J).Regexp.all,
529 Regexps (J).Descriptor.Buffer
530 (1 .. Regexps (J).Descriptor.Buffer_Index),
533 if Matched (0) /= No_Match then
534 Result := Expect_Match (J);
535 Regexps (J).Descriptor.Last_Match_Start := Matched (0).First;
536 Regexps (J).Descriptor.Last_Match_End := Matched (0).Last;
541 Expect_Internal (Descriptors, N, Timeout, Full_Buffer);
543 if N = Expect_Timeout or else N = Expect_Full_Buffer then
550 ---------------------
551 -- Expect_Internal --
552 ---------------------
554 procedure Expect_Internal
555 (Descriptors : in out Array_Of_Pd;
556 Result : out Expect_Match;
558 Full_Buffer : Boolean)
560 Num_Descriptors : Integer;
561 Buffer_Size : Integer := 0;
565 type File_Descriptor_Array is
566 array (Descriptors'Range) of File_Descriptor;
567 Fds : aliased File_Descriptor_Array;
569 type Integer_Array is array (Descriptors'Range) of Integer;
570 Is_Set : aliased Integer_Array;
573 for J in Descriptors'Range loop
574 Fds (J) := Descriptors (J).Output_Fd;
576 if Descriptors (J).Buffer_Size = 0 then
577 Buffer_Size := Integer'Max (Buffer_Size, 4096);
580 Integer'Max (Buffer_Size, Descriptors (J).Buffer_Size);
585 Buffer : aliased String (1 .. Buffer_Size);
586 -- Buffer used for input. This is allocated only once, not for
587 -- every iteration of the loop
590 -- Loop until we match or we have a timeout
594 Poll (Fds'Address, Fds'Length, Timeout, Is_Set'Address);
596 case Num_Descriptors is
606 Result := Expect_Timeout;
612 for J in Descriptors'Range loop
613 if Is_Set (J) = 1 then
614 Buffer_Size := Descriptors (J).Buffer_Size;
616 if Buffer_Size = 0 then
620 N := Read (Descriptors (J).Output_Fd, Buffer'Address,
623 -- Error or End of file
626 -- ??? Note that ddd tries again up to three times
627 -- in that case. See LiterateA.C:174
631 -- If there is no limit to the buffer size
633 if Descriptors (J).Buffer_Size = 0 then
636 Tmp : String_Access := Descriptors (J).Buffer;
640 Descriptors (J).Buffer :=
641 new String (1 .. Tmp'Length + N);
642 Descriptors (J).Buffer (1 .. Tmp'Length) :=
644 Descriptors (J).Buffer
645 (Tmp'Length + 1 .. Tmp'Length + N) :=
648 Descriptors (J).Buffer_Index :=
649 Descriptors (J).Buffer'Last;
652 Descriptors (J).Buffer :=
654 Descriptors (J).Buffer.all :=
656 Descriptors (J).Buffer_Index := N;
661 -- Add what we read to the buffer
663 if Descriptors (J).Buffer_Index + N >
664 Descriptors (J).Buffer_Size
666 -- If the user wants to know when we have
667 -- read more than the buffer can contain.
670 Result := Expect_Full_Buffer;
674 -- Keep as much as possible from the buffer,
675 -- and forget old characters.
677 Descriptors (J).Buffer
678 (1 .. Descriptors (J).Buffer_Size - N) :=
679 Descriptors (J).Buffer
680 (N - Descriptors (J).Buffer_Size +
681 Descriptors (J).Buffer_Index + 1 ..
682 Descriptors (J).Buffer_Index);
683 Descriptors (J).Buffer_Index :=
684 Descriptors (J).Buffer_Size - N;
687 -- Keep what we read in the buffer
689 Descriptors (J).Buffer
690 (Descriptors (J).Buffer_Index + 1 ..
691 Descriptors (J).Buffer_Index + N) :=
693 Descriptors (J).Buffer_Index :=
694 Descriptors (J).Buffer_Index + N;
697 -- Call each of the output filter with what we
701 (Descriptors (J).all, Buffer (1 .. N), Output);
703 Result := Expect_Match (N);
717 function Expect_Out (Descriptor : Process_Descriptor) return String is
719 return Descriptor.Buffer (1 .. Descriptor.Last_Match_End);
722 ----------------------
723 -- Expect_Out_Match --
724 ----------------------
726 function Expect_Out_Match (Descriptor : Process_Descriptor) return String is
728 return Descriptor.Buffer
729 (Descriptor.Last_Match_Start .. Descriptor.Last_Match_End);
730 end Expect_Out_Match;
737 (Descriptor : in out Process_Descriptor;
738 Timeout : Integer := 0)
740 Buffer_Size : constant Integer := 8192;
741 Num_Descriptors : Integer;
743 Is_Set : aliased Integer;
744 Buffer : aliased String (1 .. Buffer_Size);
747 -- Empty the current buffer
749 Descriptor.Last_Match_End := Descriptor.Buffer_Index;
750 Reinitialize_Buffer (Descriptor);
752 -- Read everything from the process to flush its output
756 Poll (Descriptor.Output_Fd'Address, 1, Timeout, Is_Set'Address);
758 case Num_Descriptors is
765 -- Timeout => End of flush
774 N := Read (Descriptor.Output_Fd, Buffer'Address,
787 ------------------------
788 -- Get_Command_Output --
789 ------------------------
791 function Get_Command_Output
793 Arguments : GNAT.OS_Lib.Argument_List;
795 Status : not null access Integer;
796 Err_To_Out : Boolean := False) return String
800 Process : Process_Descriptor;
802 Output : String_Access := new String (1 .. 1024);
803 -- Buffer used to accumulate standard output from the launched
804 -- command, expanded as necessary during execution.
807 -- Index of the last used character within Output
811 (Process, Command, Arguments, Err_To_Out => Err_To_Out);
813 if Input'Length > 0 then
814 Send (Process, Input);
817 GNAT.OS_Lib.Close (Get_Input_Fd (Process));
820 Result : Expect_Match;
821 pragma Unreferenced (Result);
824 -- This loop runs until the call to Expect raises Process_Died
827 Expect (Process, Result, ".+");
830 NOutput : String_Access;
831 S : constant String := Expect_Out (Process);
832 pragma Assert (S'Length > 0);
835 -- Expand buffer if we need more space. Note here that we add
836 -- S'Length to ensure that S will fit in the new buffer size.
838 if Last + S'Length > Output'Last then
839 NOutput := new String (1 .. 2 * Output'Last + S'Length);
840 NOutput (Output'Range) := Output.all;
843 -- Here if current buffer size is OK
849 NOutput (Last + 1 .. Last + S'Length) := S;
850 Last := Last + S'Length;
857 Close (Process, Status.all);
865 S : constant String := Output (1 .. Last);
870 end Get_Command_Output;
876 function Get_Error_Fd
877 (Descriptor : Process_Descriptor) return GNAT.OS_Lib.File_Descriptor
880 return Descriptor.Error_Fd;
887 function Get_Input_Fd
888 (Descriptor : Process_Descriptor) return GNAT.OS_Lib.File_Descriptor
891 return Descriptor.Input_Fd;
898 function Get_Output_Fd
899 (Descriptor : Process_Descriptor) return GNAT.OS_Lib.File_Descriptor
902 return Descriptor.Output_Fd;
910 (Descriptor : Process_Descriptor) return Process_Id
913 return Descriptor.Pid;
920 procedure Interrupt (Descriptor : in out Process_Descriptor) is
921 SIGINT : constant := 2;
923 Send_Signal (Descriptor, SIGINT);
930 procedure Lock_Filters (Descriptor : in out Process_Descriptor) is
932 Descriptor.Filters_Lock := Descriptor.Filters_Lock + 1;
935 ------------------------
936 -- Non_Blocking_Spawn --
937 ------------------------
939 procedure Non_Blocking_Spawn
940 (Descriptor : out Process_Descriptor'Class;
942 Args : GNAT.OS_Lib.Argument_List;
943 Buffer_Size : Natural := 4096;
944 Err_To_Out : Boolean := False)
946 function Fork return Process_Id;
947 pragma Import (C, Fork, "__gnat_expect_fork");
948 -- Starts a new process if possible. See the Unix command fork for more
949 -- information. On systems that do not support this capability (such as
950 -- Windows...), this command does nothing, and Fork will return
953 Pipe1, Pipe2, Pipe3 : aliased Pipe_Type;
956 Arg_List : String_List (1 .. Args'Length + 2);
957 C_Arg_List : aliased array (1 .. Args'Length + 2) of System.Address;
959 Command_With_Path : String_Access;
962 -- Create the rest of the pipes
964 Set_Up_Communications
965 (Descriptor, Err_To_Out, Pipe1'Access, Pipe2'Access, Pipe3'Access);
967 Command_With_Path := Locate_Exec_On_Path (Command);
969 if Command_With_Path = null then
970 raise Invalid_Process;
973 -- Fork a new process
975 Descriptor.Pid := Fork;
977 -- Are we now in the child (or, for Windows, still in the common
980 if Descriptor.Pid = Null_Pid then
981 -- Prepare an array of arguments to pass to C
983 Arg := new String (1 .. Command_With_Path'Length + 1);
984 Arg (1 .. Command_With_Path'Length) := Command_With_Path.all;
985 Arg (Arg'Last) := ASCII.NUL;
988 for J in Args'Range loop
989 Arg := new String (1 .. Args (J)'Length + 1);
990 Arg (1 .. Args (J)'Length) := Args (J).all;
991 Arg (Arg'Last) := ASCII.NUL;
992 Arg_List (J + 2 - Args'First) := Arg.all'Access;
995 Arg_List (Arg_List'Last) := null;
997 -- Make sure all arguments are compatible with OS conventions
999 Normalize_Arguments (Arg_List);
1001 -- Prepare low-level argument list from the normalized arguments
1003 for K in Arg_List'Range loop
1004 if Arg_List (K) /= null then
1005 C_Arg_List (K) := Arg_List (K).all'Address;
1007 C_Arg_List (K) := System.Null_Address;
1011 -- This does not return on Unix systems
1013 Set_Up_Child_Communications
1014 (Descriptor, Pipe1, Pipe2, Pipe3, Command_With_Path.all,
1015 C_Arg_List'Address);
1018 Free (Command_With_Path);
1020 -- Did we have an error when spawning the child ?
1022 if Descriptor.Pid < Null_Pid then
1023 raise Invalid_Process;
1025 -- We are now in the parent process
1027 Set_Up_Parent_Communications (Descriptor, Pipe1, Pipe2, Pipe3);
1030 -- Create the buffer
1032 Descriptor.Buffer_Size := Buffer_Size;
1034 if Buffer_Size /= 0 then
1035 Descriptor.Buffer := new String (1 .. Positive (Buffer_Size));
1038 -- Initialize the filters
1040 Descriptor.Filters := null;
1041 end Non_Blocking_Spawn;
1043 -------------------------
1044 -- Reinitialize_Buffer --
1045 -------------------------
1047 procedure Reinitialize_Buffer
1048 (Descriptor : in out Process_Descriptor'Class)
1051 if Descriptor.Buffer_Size = 0 then
1053 Tmp : String_Access := Descriptor.Buffer;
1056 Descriptor.Buffer :=
1058 (1 .. Descriptor.Buffer_Index - Descriptor.Last_Match_End);
1061 Descriptor.Buffer.all := Tmp
1062 (Descriptor.Last_Match_End + 1 .. Descriptor.Buffer_Index);
1067 Descriptor.Buffer_Index := Descriptor.Buffer'Last;
1071 (1 .. Descriptor.Buffer_Index - Descriptor.Last_Match_End) :=
1073 (Descriptor.Last_Match_End + 1 .. Descriptor.Buffer_Index);
1075 if Descriptor.Buffer_Index > Descriptor.Last_Match_End then
1076 Descriptor.Buffer_Index :=
1077 Descriptor.Buffer_Index - Descriptor.Last_Match_End;
1079 Descriptor.Buffer_Index := 0;
1083 Descriptor.Last_Match_Start := 0;
1084 Descriptor.Last_Match_End := 0;
1085 end Reinitialize_Buffer;
1091 procedure Remove_Filter
1092 (Descriptor : in out Process_Descriptor;
1093 Filter : Filter_Function)
1095 Previous : Filter_List := null;
1096 Current : Filter_List := Descriptor.Filters;
1099 while Current /= null loop
1100 if Current.Filter = Filter then
1101 if Previous = null then
1102 Descriptor.Filters := Current.Next;
1104 Previous.Next := Current.Next;
1108 Previous := Current;
1109 Current := Current.Next;
1118 (Descriptor : in out Process_Descriptor;
1120 Add_LF : Boolean := True;
1121 Empty_Buffer : Boolean := False)
1123 Line_Feed : aliased constant String := (1 .. 1 => ASCII.LF);
1124 Descriptors : Array_Of_Pd := (1 => Descriptor'Unrestricted_Access);
1126 Result : Expect_Match;
1128 pragma Warnings (Off, Result);
1129 pragma Warnings (Off, Discard);
1132 if Empty_Buffer then
1134 -- Force a read on the process if there is anything waiting
1137 (Descriptors, Result, Timeout => 0, Full_Buffer => False);
1138 Descriptor.Last_Match_End := Descriptor.Buffer_Index;
1142 Reinitialize_Buffer (Descriptor);
1145 Call_Filters (Descriptor, Str, Input);
1147 Write (Descriptor.Input_Fd, Str'Address, Str'Last - Str'First + 1);
1150 Call_Filters (Descriptor, Line_Feed, Input);
1152 Write (Descriptor.Input_Fd, Line_Feed'Address, 1);
1160 procedure Send_Signal
1161 (Descriptor : Process_Descriptor;
1165 -- A nonpositive process id passed to kill has special meanings. For
1166 -- example, -1 means kill all processes in sight, including self, in
1167 -- POSIX and Windows (and something slightly different in Linux). See
1168 -- man pages for details. In any case, we don't want to do that. Note
1169 -- that Descriptor.Pid will be -1 if the process was not successfully
1170 -- started; we don't want to kill ourself in that case.
1172 if Descriptor.Pid > 0 then
1173 Kill (Descriptor.Pid, Signal, Close => 1);
1174 -- ??? Need to check process status here
1176 raise Invalid_Process;
1180 ---------------------------------
1181 -- Set_Up_Child_Communications --
1182 ---------------------------------
1184 procedure Set_Up_Child_Communications
1185 (Pid : in out Process_Descriptor;
1186 Pipe1 : in out Pipe_Type;
1187 Pipe2 : in out Pipe_Type;
1188 Pipe3 : in out Pipe_Type;
1190 Args : System.Address)
1192 pragma Warnings (Off, Pid);
1193 pragma Warnings (Off, Pipe1);
1194 pragma Warnings (Off, Pipe2);
1195 pragma Warnings (Off, Pipe3);
1197 Input : File_Descriptor;
1198 Output : File_Descriptor;
1199 Error : File_Descriptor;
1202 -- Since Windows does not have a separate fork/exec, we need to
1203 -- perform the following actions:
1204 -- - save stdin, stdout, stderr
1205 -- - replace them by our pipes
1206 -- - create the child with process handle inheritance
1207 -- - revert to the previous stdin, stdout and stderr.
1209 Input := Dup (GNAT.OS_Lib.Standin);
1210 Output := Dup (GNAT.OS_Lib.Standout);
1211 Error := Dup (GNAT.OS_Lib.Standerr);
1213 -- Since we are still called from the parent process, there is no way
1214 -- currently we can cleanly close the unneeded ends of the pipes, but
1215 -- this doesn't really matter.
1217 -- We could close Pipe1.Output, Pipe2.Input, Pipe3.Input
1219 Dup2 (Pipe1.Input, GNAT.OS_Lib.Standin);
1220 Dup2 (Pipe2.Output, GNAT.OS_Lib.Standout);
1221 Dup2 (Pipe3.Output, GNAT.OS_Lib.Standerr);
1223 Portable_Execvp (Pid.Pid'Access, Cmd & ASCII.NUL, Args);
1225 -- The following commands are not executed on Unix systems, and are
1226 -- only required for Windows systems. We are now in the parent process.
1228 -- Restore the old descriptors
1230 Dup2 (Input, GNAT.OS_Lib.Standin);
1231 Dup2 (Output, GNAT.OS_Lib.Standout);
1232 Dup2 (Error, GNAT.OS_Lib.Standerr);
1236 end Set_Up_Child_Communications;
1238 ---------------------------
1239 -- Set_Up_Communications --
1240 ---------------------------
1242 procedure Set_Up_Communications
1243 (Pid : in out Process_Descriptor;
1244 Err_To_Out : Boolean;
1245 Pipe1 : not null access Pipe_Type;
1246 Pipe2 : not null access Pipe_Type;
1247 Pipe3 : not null access Pipe_Type)
1250 pragma Unreferenced (Status);
1255 if Create_Pipe (Pipe1) /= 0 then
1259 if Create_Pipe (Pipe2) /= 0 then
1263 -- Record the 'parent' end of the two pipes in Pid:
1264 -- Child stdin is connected to the 'write' end of Pipe1;
1265 -- Child stdout is connected to the 'read' end of Pipe2.
1266 -- We do not want these descriptors to remain open in the child
1267 -- process, so we mark them close-on-exec/non-inheritable.
1269 Pid.Input_Fd := Pipe1.Output;
1270 Set_Close_On_Exec (Pipe1.Output, True, Status);
1271 Pid.Output_Fd := Pipe2.Input;
1272 Set_Close_On_Exec (Pipe2.Input, True, Status);
1276 -- Reuse the standard output pipe for standard error
1278 Pipe3.all := Pipe2.all;
1281 -- Create a separate pipe for standard error
1283 if Create_Pipe (Pipe3) /= 0 then
1288 -- As above, record the proper fd for the child's standard error stream
1290 Pid.Error_Fd := Pipe3.Input;
1291 Set_Close_On_Exec (Pipe3.Input, True, Status);
1292 end Set_Up_Communications;
1294 ----------------------------------
1295 -- Set_Up_Parent_Communications --
1296 ----------------------------------
1298 procedure Set_Up_Parent_Communications
1299 (Pid : in out Process_Descriptor;
1300 Pipe1 : in out Pipe_Type;
1301 Pipe2 : in out Pipe_Type;
1302 Pipe3 : in out Pipe_Type)
1304 pragma Warnings (Off, Pid);
1305 pragma Warnings (Off, Pipe1);
1306 pragma Warnings (Off, Pipe2);
1307 pragma Warnings (Off, Pipe3);
1309 Close (Pipe1.Input);
1310 Close (Pipe2.Output);
1311 Close (Pipe3.Output);
1312 end Set_Up_Parent_Communications;
1318 procedure Trace_Filter
1319 (Descriptor : Process_Descriptor'Class;
1321 User_Data : System.Address := System.Null_Address)
1323 pragma Warnings (Off, Descriptor);
1324 pragma Warnings (Off, User_Data);
1329 --------------------
1330 -- Unlock_Filters --
1331 --------------------
1333 procedure Unlock_Filters (Descriptor : in out Process_Descriptor) is
1335 if Descriptor.Filters_Lock > 0 then
1336 Descriptor.Filters_Lock := Descriptor.Filters_Lock - 1;