1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- G N A T . E X P E C T --
9 -- Copyright (C) 2000-2019, 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 3, 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. --
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
19 -- additional permissions described in the GCC Runtime Library Exception, --
20 -- version 3.1, as published by the Free Software Foundation. --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
30 ------------------------------------------------------------------------------
32 with System; use System;
33 with System.OS_Constants; use System.OS_Constants;
34 with Ada.Calendar; use Ada.Calendar;
36 with GNAT.IO; use GNAT.IO;
37 with GNAT.OS_Lib; use GNAT.OS_Lib;
38 with GNAT.Regpat; use GNAT.Regpat;
40 with Ada.Unchecked_Deallocation;
42 package body GNAT.Expect is
44 type Array_Of_Pd is array (Positive range <>) of Process_Descriptor_Access;
46 Expect_Process_Died : constant Expect_Match := -100;
47 Expect_Internal_Error : constant Expect_Match := -101;
48 -- Additional possible outputs of Expect_Internal. These are not visible in
49 -- the spec because the user will never see them.
51 procedure Expect_Internal
52 (Descriptors : in out Array_Of_Pd;
53 Result : out Expect_Match;
55 Full_Buffer : Boolean);
56 -- Internal function used to read from the process Descriptor.
58 -- Several outputs are possible:
59 -- Result=Expect_Timeout, if no output was available before the timeout
61 -- Result=Expect_Full_Buffer, if Full_Buffer is True and some characters
62 -- had to be discarded from the internal buffer of Descriptor.
63 -- Result=Express_Process_Died if one of the processes was terminated.
64 -- That process's Input_Fd is set to Invalid_FD
65 -- Result=Express_Internal_Error
66 -- Result=<integer>, indicates how many characters were added to the
67 -- internal buffer. These characters are from indexes
68 -- Descriptor.Buffer_Index - Result + 1 .. Descriptor.Buffer_Index
69 -- Process_Died is raised if the process is no longer valid.
71 procedure Reinitialize_Buffer
72 (Descriptor : in out Process_Descriptor'Class);
73 -- Reinitialize the internal buffer.
74 -- The buffer is deleted up to the end of the last match.
76 procedure Free is new Ada.Unchecked_Deallocation
77 (Pattern_Matcher, Pattern_Matcher_Access);
79 procedure Free is new Ada.Unchecked_Deallocation
80 (Filter_List_Elem, Filter_List);
82 procedure Call_Filters
83 (Pid : Process_Descriptor'Class;
85 Filter_On : Filter_Type);
86 -- Call all the filters that have the appropriate type.
87 -- This function does nothing if the filters are locked
89 ------------------------------
90 -- Target dependent section --
91 ------------------------------
93 function Dup (Fd : File_Descriptor) return File_Descriptor;
94 pragma Import (C, Dup);
96 procedure Dup2 (Old_Fd, New_Fd : File_Descriptor);
97 pragma Import (C, Dup2);
99 procedure Kill (Pid : Process_Id; Sig_Num : Integer; Close : Integer);
100 pragma Import (C, Kill, "__gnat_kill");
101 -- if Close is set to 1 all OS resources used by the Pid must be freed
103 function Create_Pipe (Pipe : not null access Pipe_Type) return Integer;
104 pragma Import (C, Create_Pipe, "__gnat_pipe");
107 (Fds : System.Address;
110 Dead_Process : access Integer;
111 Is_Set : System.Address) return Integer;
112 pragma Import (C, Poll, "__gnat_expect_poll");
113 -- Check whether there is any data waiting on the file descriptors
114 -- Fds, and wait if there is none, at most Timeout milliseconds
115 -- Returns -1 in case of error, 0 if the timeout expired before
116 -- data became available.
118 -- Is_Set is an array of the same size as FDs and elements are set to 1 if
119 -- data is available for the corresponding File Descriptor, 0 otherwise.
121 -- If a process dies, then Dead_Process is set to the index of the
122 -- corresponding file descriptor.
124 function Waitpid (Pid : Process_Id) return Integer;
125 pragma Import (C, Waitpid, "__gnat_waitpid");
126 -- Wait for a specific process id, and return its exit code
132 function "+" (S : String) return GNAT.OS_Lib.String_Access is
134 return new String'(S);
142 (P : GNAT.Regpat.Pattern_Matcher) return Pattern_Matcher_Access
145 return new GNAT.Regpat.Pattern_Matcher'(P);
153 (Descriptor : in out Process_Descriptor;
154 Filter : Filter_Function;
155 Filter_On : Filter_Type := Output;
156 User_Data : System.Address := System.Null_Address;
157 After : Boolean := False)
159 Current : Filter_List := Descriptor.Filters;
163 while Current /= null and then Current.Next /= null loop
164 Current := Current.Next;
167 if Current = null then
168 Descriptor.Filters :=
169 new Filter_List_Elem'
170 (Filter => Filter, Filter_On => Filter_On,
171 User_Data => User_Data, Next => null);
174 new Filter_List_Elem'
175 (Filter => Filter, Filter_On => Filter_On,
176 User_Data => User_Data, Next => null);
180 Descriptor.Filters :=
181 new Filter_List_Elem'
182 (Filter => Filter, Filter_On => Filter_On,
183 User_Data => User_Data, Next => Descriptor.Filters);
191 procedure Call_Filters
192 (Pid : Process_Descriptor'Class;
194 Filter_On : Filter_Type)
196 Current_Filter : Filter_List;
199 if Pid.Filters_Lock = 0 then
200 Current_Filter := Pid.Filters;
202 while Current_Filter /= null loop
203 if Current_Filter.Filter_On = Filter_On then
204 Current_Filter.Filter
205 (Pid, Str, Current_Filter.User_Data);
208 Current_Filter := Current_Filter.Next;
218 (Descriptor : in out Process_Descriptor;
219 Status : out Integer)
221 Current_Filter : Filter_List;
222 Next_Filter : Filter_List;
225 Close_Input (Descriptor);
227 if Descriptor.Error_Fd /= Descriptor.Output_Fd
228 and then Descriptor.Error_Fd /= Invalid_FD
230 Close (Descriptor.Error_Fd);
233 if Descriptor.Output_Fd /= Invalid_FD then
234 Close (Descriptor.Output_Fd);
237 -- ??? Should have timeouts for different signals
239 if Descriptor.Pid > 0 then -- see comment in Send_Signal
240 Kill (Descriptor.Pid, Sig_Num => 9, Close => 0);
243 GNAT.OS_Lib.Free (Descriptor.Buffer);
244 Descriptor.Buffer_Size := 0;
246 Current_Filter := Descriptor.Filters;
248 while Current_Filter /= null loop
249 Next_Filter := Current_Filter.Next;
250 Free (Current_Filter);
251 Current_Filter := Next_Filter;
254 Descriptor.Filters := null;
256 -- Check process id (see comment in Send_Signal)
258 if Descriptor.Pid > 0 then
259 Status := Waitpid (Descriptor.Pid);
261 raise Invalid_Process;
265 procedure Close (Descriptor : in out Process_Descriptor) is
267 pragma Unreferenced (Status);
269 Close (Descriptor, Status);
276 procedure Close_Input (Pid : in out Process_Descriptor) is
278 if Pid.Input_Fd /= Invalid_FD then
279 Close (Pid.Input_Fd);
282 if Pid.Output_Fd = Pid.Input_Fd then
283 Pid.Output_Fd := Invalid_FD;
286 if Pid.Error_Fd = Pid.Input_Fd then
287 Pid.Error_Fd := Invalid_FD;
290 Pid.Input_Fd := Invalid_FD;
298 (Descriptor : in out Process_Descriptor;
299 Result : out Expect_Match;
301 Timeout : Integer := 10_000;
302 Full_Buffer : Boolean := False)
306 Expect (Descriptor, Result, Never_Match, Timeout, Full_Buffer);
308 Expect (Descriptor, Result, Compile (Regexp), Timeout, Full_Buffer);
313 (Descriptor : in out Process_Descriptor;
314 Result : out Expect_Match;
316 Matched : out GNAT.Regpat.Match_Array;
317 Timeout : Integer := 10_000;
318 Full_Buffer : Boolean := False)
321 pragma Assert (Matched'First = 0);
324 (Descriptor, Result, Never_Match, Matched, Timeout, Full_Buffer);
327 (Descriptor, Result, Compile (Regexp), Matched, Timeout,
333 (Descriptor : in out Process_Descriptor;
334 Result : out Expect_Match;
335 Regexp : GNAT.Regpat.Pattern_Matcher;
336 Timeout : Integer := 10_000;
337 Full_Buffer : Boolean := False)
339 Matched : GNAT.Regpat.Match_Array (0 .. 0);
340 pragma Warnings (Off, Matched);
342 Expect (Descriptor, Result, Regexp, Matched, Timeout, Full_Buffer);
346 (Descriptor : in out Process_Descriptor;
347 Result : out Expect_Match;
348 Regexp : GNAT.Regpat.Pattern_Matcher;
349 Matched : out GNAT.Regpat.Match_Array;
350 Timeout : Integer := 10_000;
351 Full_Buffer : Boolean := False)
354 Descriptors : Array_Of_Pd := (1 => Descriptor'Unrestricted_Access);
355 Try_Until : constant Time := Clock + Duration (Timeout) / 1000.0;
356 Timeout_Tmp : Integer := Timeout;
359 pragma Assert (Matched'First = 0);
360 Reinitialize_Buffer (Descriptor);
363 -- First, test if what is already in the buffer matches (This is
364 -- required if this package is used in multi-task mode, since one of
365 -- the tasks might have added something in the buffer, and we don't
366 -- want other tasks to wait for new input to be available before
367 -- checking the regexps).
370 (Regexp, Descriptor.Buffer (1 .. Descriptor.Buffer_Index), Matched);
372 if Descriptor.Buffer_Index >= 1 and then Matched (0).First /= 0 then
374 Descriptor.Last_Match_Start := Matched (0).First;
375 Descriptor.Last_Match_End := Matched (0).Last;
379 -- Else try to read new input
381 Expect_Internal (Descriptors, N, Timeout_Tmp, Full_Buffer);
384 when Expect_Internal_Error
385 | Expect_Process_Died
389 when Expect_Full_Buffer
399 -- Calculate the timeout for the next turn
401 -- Note that Timeout is, from the caller's perspective, the maximum
402 -- time until a match, not the maximum time until some output is
403 -- read, and thus cannot be reused as is for Expect_Internal.
405 if Timeout /= -1 then
406 Timeout_Tmp := Integer (Try_Until - Clock) * 1000;
408 if Timeout_Tmp < 0 then
409 Result := Expect_Timeout;
415 -- Even if we had the general timeout above, we have to test that the
416 -- last test we read from the external process didn't match.
419 (Regexp, Descriptor.Buffer (1 .. Descriptor.Buffer_Index), Matched);
421 if Matched (0).First /= 0 then
423 Descriptor.Last_Match_Start := Matched (0).First;
424 Descriptor.Last_Match_End := Matched (0).Last;
430 (Descriptor : in out Process_Descriptor;
431 Result : out Expect_Match;
432 Regexps : Regexp_Array;
433 Timeout : Integer := 10_000;
434 Full_Buffer : Boolean := False)
436 Patterns : Compiled_Regexp_Array (Regexps'Range);
438 Matched : GNAT.Regpat.Match_Array (0 .. 0);
439 pragma Warnings (Off, Matched);
442 for J in Regexps'Range loop
443 Patterns (J) := new Pattern_Matcher'(Compile (Regexps (J).all));
446 Expect (Descriptor, Result, Patterns, Matched, Timeout, Full_Buffer);
448 for J in Regexps'Range loop
454 (Descriptor : in out Process_Descriptor;
455 Result : out Expect_Match;
456 Regexps : Compiled_Regexp_Array;
457 Timeout : Integer := 10_000;
458 Full_Buffer : Boolean := False)
460 Matched : GNAT.Regpat.Match_Array (0 .. 0);
461 pragma Warnings (Off, Matched);
463 Expect (Descriptor, Result, Regexps, Matched, Timeout, Full_Buffer);
467 (Result : out Expect_Match;
468 Regexps : Multiprocess_Regexp_Array;
469 Timeout : Integer := 10_000;
470 Full_Buffer : Boolean := False)
472 Matched : GNAT.Regpat.Match_Array (0 .. 0);
473 pragma Warnings (Off, Matched);
475 Expect (Result, Regexps, Matched, Timeout, Full_Buffer);
479 (Descriptor : in out Process_Descriptor;
480 Result : out Expect_Match;
481 Regexps : Regexp_Array;
482 Matched : out GNAT.Regpat.Match_Array;
483 Timeout : Integer := 10_000;
484 Full_Buffer : Boolean := False)
486 Patterns : Compiled_Regexp_Array (Regexps'Range);
489 pragma Assert (Matched'First = 0);
491 for J in Regexps'Range loop
492 Patterns (J) := new Pattern_Matcher'(Compile (Regexps (J).all));
495 Expect (Descriptor, Result, Patterns, Matched, Timeout, Full_Buffer);
497 for J in Regexps'Range loop
503 (Descriptor : in out Process_Descriptor;
504 Result : out Expect_Match;
505 Regexps : Compiled_Regexp_Array;
506 Matched : out GNAT.Regpat.Match_Array;
507 Timeout : Integer := 10_000;
508 Full_Buffer : Boolean := False)
511 Descriptors : Array_Of_Pd := (1 => Descriptor'Unrestricted_Access);
514 pragma Assert (Matched'First = 0);
516 Reinitialize_Buffer (Descriptor);
519 -- First, test if what is already in the buffer matches (This is
520 -- required if this package is used in multi-task mode, since one of
521 -- the tasks might have added something in the buffer, and we don't
522 -- want other tasks to wait for new input to be available before
523 -- checking the regexps).
525 if Descriptor.Buffer /= null then
526 for J in Regexps'Range loop
529 Descriptor.Buffer (1 .. Descriptor.Buffer_Index),
532 if Matched (0) /= No_Match then
533 Result := Expect_Match (J);
534 Descriptor.Last_Match_Start := Matched (0).First;
535 Descriptor.Last_Match_End := Matched (0).Last;
541 Expect_Internal (Descriptors, N, Timeout, Full_Buffer);
544 when Expect_Internal_Error
545 | Expect_Process_Died
549 when Expect_Full_Buffer
562 (Result : out Expect_Match;
563 Regexps : Multiprocess_Regexp_Array;
564 Matched : out GNAT.Regpat.Match_Array;
565 Timeout : Integer := 10_000;
566 Full_Buffer : Boolean := False)
569 Descriptors : Array_Of_Pd (Regexps'Range);
572 pragma Assert (Matched'First = 0);
574 for J in Descriptors'Range loop
575 Descriptors (J) := Regexps (J).Descriptor;
577 if Descriptors (J) /= null then
578 Reinitialize_Buffer (Regexps (J).Descriptor.all);
583 -- First, test if what is already in the buffer matches (This is
584 -- required if this package is used in multi-task mode, since one of
585 -- the tasks might have added something in the buffer, and we don't
586 -- want other tasks to wait for new input to be available before
587 -- checking the regexps).
589 for J in Regexps'Range loop
590 if Regexps (J).Regexp /= null
591 and then Regexps (J).Descriptor /= null
593 Match (Regexps (J).Regexp.all,
594 Regexps (J).Descriptor.Buffer
595 (1 .. Regexps (J).Descriptor.Buffer_Index),
598 if Matched (0) /= No_Match then
599 Result := Expect_Match (J);
600 Regexps (J).Descriptor.Last_Match_Start := Matched (0).First;
601 Regexps (J).Descriptor.Last_Match_End := Matched (0).Last;
607 Expect_Internal (Descriptors, N, Timeout, Full_Buffer);
610 when Expect_Internal_Error
611 | Expect_Process_Died
615 when Expect_Full_Buffer
627 ---------------------
628 -- Expect_Internal --
629 ---------------------
631 procedure Expect_Internal
632 (Descriptors : in out Array_Of_Pd;
633 Result : out Expect_Match;
635 Full_Buffer : Boolean)
637 Num_Descriptors : Integer;
638 Buffer_Size : Integer := 0;
642 type File_Descriptor_Array is
643 array (0 .. Descriptors'Length - 1) of File_Descriptor;
644 Fds : aliased File_Descriptor_Array;
645 Fds_Count : Natural := 0;
647 Fds_To_Descriptor : array (Fds'Range) of Integer;
648 -- Maps file descriptor entries from Fds to entries in Descriptors.
649 -- They do not have the same index when entries in Descriptors are null.
651 type Integer_Array is array (Fds'Range) of Integer;
652 Is_Set : aliased Integer_Array;
655 for J in Descriptors'Range loop
656 if Descriptors (J) /= null
657 and then Descriptors (J).Output_Fd /= Invalid_FD
659 Fds (Fds'First + Fds_Count) := Descriptors (J).Output_Fd;
660 Fds_To_Descriptor (Fds'First + Fds_Count) := J;
661 Fds_Count := Fds_Count + 1;
663 if Descriptors (J).Buffer_Size = 0 then
664 Buffer_Size := Integer'Max (Buffer_Size, 4096);
667 Integer'Max (Buffer_Size, Descriptors (J).Buffer_Size);
672 if Fds_Count = 0 then
673 -- There are no descriptors to monitor, it means that process died.
675 Result := Expect_Process_Died;
681 Buffer : aliased String (1 .. Buffer_Size);
682 -- Buffer used for input. This is allocated only once, not for
683 -- every iteration of the loop
686 -- Index in Descriptors
689 -- Loop until we match or we have a timeout
692 -- Poll may be interrupted on Linux by a signal and need to be
693 -- repeated. We don't want to check for errno = EINTER, so just
694 -- attempt to call Poll a few times.
699 (Fds'Address, Fds_Count, Timeout, D'Access, Is_Set'Address);
701 exit when Num_Descriptors /= -1;
704 case Num_Descriptors is
709 Result := Expect_Internal_Error;
712 Close_Input (Descriptors (D).all);
720 Result := Expect_Timeout;
726 for F in Fds'Range loop
727 if Is_Set (F) = 1 then
728 D := Fds_To_Descriptor (F);
730 Buffer_Size := Descriptors (D).Buffer_Size;
732 if Buffer_Size = 0 then
736 -- Read may be interrupted on Linux by a signal and
737 -- need to be repeated. We don't want to check for
738 -- errno = EINTER, so just attempt to read a few
742 N := Read (Descriptors (D).Output_Fd,
743 Buffer'Address, Buffer_Size);
748 -- Error or End of file
751 Close_Input (Descriptors (D).all);
752 Result := Expect_Process_Died;
757 -- If there is no limit to the buffer size
759 if Descriptors (D).Buffer_Size = 0 then
761 Tmp : String_Access := Descriptors (D).Buffer;
765 Descriptors (D).Buffer :=
766 new String (1 .. Tmp'Length + N);
767 Descriptors (D).Buffer (1 .. Tmp'Length) :=
769 Descriptors (D).Buffer
770 (Tmp'Length + 1 .. Tmp'Length + N) :=
773 Descriptors (D).Buffer_Index :=
774 Descriptors (D).Buffer'Last;
777 Descriptors (D).Buffer :=
779 Descriptors (D).Buffer.all :=
781 Descriptors (D).Buffer_Index := N;
786 -- Add what we read to the buffer
788 if Descriptors (D).Buffer_Index + N >
789 Descriptors (D).Buffer_Size
791 -- If the user wants to know when we have
792 -- read more than the buffer can contain.
795 Result := Expect_Full_Buffer;
799 -- Keep as much as possible from the buffer,
800 -- and forget old characters.
802 Descriptors (D).Buffer
803 (1 .. Descriptors (D).Buffer_Size - N) :=
804 Descriptors (D).Buffer
805 (N - Descriptors (D).Buffer_Size +
806 Descriptors (D).Buffer_Index + 1 ..
807 Descriptors (D).Buffer_Index);
808 Descriptors (D).Buffer_Index :=
809 Descriptors (D).Buffer_Size - N;
812 -- Keep what we read in the buffer
814 Descriptors (D).Buffer
815 (Descriptors (D).Buffer_Index + 1 ..
816 Descriptors (D).Buffer_Index + N) :=
818 Descriptors (D).Buffer_Index :=
819 Descriptors (D).Buffer_Index + N;
822 -- Call each of the output filter with what we
826 (Descriptors (D).all, Buffer (1 .. N), Output);
828 Result := Expect_Match (D);
842 function Expect_Out (Descriptor : Process_Descriptor) return String is
844 return Descriptor.Buffer (1 .. Descriptor.Last_Match_End);
847 ----------------------
848 -- Expect_Out_Match --
849 ----------------------
851 function Expect_Out_Match (Descriptor : Process_Descriptor) return String is
853 return Descriptor.Buffer
854 (Descriptor.Last_Match_Start .. Descriptor.Last_Match_End);
855 end Expect_Out_Match;
857 ------------------------
858 -- First_Dead_Process --
859 ------------------------
861 function First_Dead_Process
862 (Regexp : Multiprocess_Regexp_Array) return Natural is
864 for R in Regexp'Range loop
865 if Regexp (R).Descriptor /= null
866 and then Regexp (R).Descriptor.Input_Fd = GNAT.OS_Lib.Invalid_FD
873 end First_Dead_Process;
880 (Descriptor : in out Process_Descriptor;
881 Timeout : Integer := 0)
883 Buffer_Size : constant Integer := 8192;
884 Num_Descriptors : Integer;
886 Is_Set : aliased Integer;
887 Buffer : aliased String (1 .. Buffer_Size);
890 -- Empty the current buffer
892 Descriptor.Last_Match_End := Descriptor.Buffer_Index;
893 Reinitialize_Buffer (Descriptor);
895 -- Read everything from the process to flush its output
899 Poll (Descriptor.Output_Fd'Address,
905 case Num_Descriptors is
912 -- Timeout => End of flush
921 N := Read (Descriptor.Output_Fd, Buffer'Address,
938 procedure Free (Regexp : in out Multiprocess_Regexp) is
939 procedure Unchecked_Free is new Ada.Unchecked_Deallocation
940 (Process_Descriptor'Class, Process_Descriptor_Access);
942 Unchecked_Free (Regexp.Descriptor);
943 Free (Regexp.Regexp);
946 ------------------------
947 -- Get_Command_Output --
948 ------------------------
950 function Get_Command_Output
952 Arguments : GNAT.OS_Lib.Argument_List;
954 Status : not null access Integer;
955 Err_To_Out : Boolean := False) return String
957 Process : Process_Descriptor;
959 Output : String_Access := new String (1 .. 1024);
960 -- Buffer used to accumulate standard output from the launched
961 -- command, expanded as necessary during execution.
964 -- Index of the last used character within Output
968 (Process, Command, Arguments, Err_To_Out => Err_To_Out,
971 if Input'Length > 0 then
972 Send (Process, Input);
975 Close_Input (Process);
978 Result : Expect_Match;
979 pragma Unreferenced (Result);
982 -- This loop runs until the call to Expect raises Process_Died
985 Expect (Process, Result, ".+", Timeout => -1);
988 NOutput : String_Access;
989 S : constant String := Expect_Out (Process);
990 pragma Assert (S'Length > 0);
993 -- Expand buffer if we need more space. Note here that we add
994 -- S'Length to ensure that S will fit in the new buffer size.
996 if Last + S'Length > Output'Last then
997 NOutput := new String (1 .. 2 * Output'Last + S'Length);
998 NOutput (Output'Range) := Output.all;
1001 -- Here if current buffer size is OK
1007 NOutput (Last + 1 .. Last + S'Length) := S;
1008 Last := Last + S'Length;
1014 when Process_Died =>
1015 Close (Process, Status.all);
1024 S : constant String := Output (1 .. Last);
1029 end Get_Command_Output;
1035 function Get_Error_Fd
1036 (Descriptor : Process_Descriptor) return GNAT.OS_Lib.File_Descriptor
1039 return Descriptor.Error_Fd;
1046 function Get_Input_Fd
1047 (Descriptor : Process_Descriptor) return GNAT.OS_Lib.File_Descriptor
1050 return Descriptor.Input_Fd;
1057 function Get_Output_Fd
1058 (Descriptor : Process_Descriptor) return GNAT.OS_Lib.File_Descriptor
1061 return Descriptor.Output_Fd;
1069 (Descriptor : Process_Descriptor) return Process_Id
1072 return Descriptor.Pid;
1079 function Has_Process (Regexp : Multiprocess_Regexp_Array) return Boolean is
1081 return Regexp /= (Regexp'Range => (null, null));
1088 procedure Interrupt (Descriptor : in out Process_Descriptor) is
1089 SIGINT : constant := 2;
1091 Send_Signal (Descriptor, SIGINT);
1098 procedure Lock_Filters (Descriptor : in out Process_Descriptor) is
1100 Descriptor.Filters_Lock := Descriptor.Filters_Lock + 1;
1103 ------------------------
1104 -- Non_Blocking_Spawn --
1105 ------------------------
1107 procedure Non_Blocking_Spawn
1108 (Descriptor : out Process_Descriptor'Class;
1110 Args : GNAT.OS_Lib.Argument_List;
1111 Buffer_Size : Natural := 4096;
1112 Err_To_Out : Boolean := False)
1114 function Fork return Process_Id;
1115 pragma Import (C, Fork, "__gnat_expect_fork");
1116 -- Starts a new process if possible. See the Unix command fork for more
1117 -- information. On systems that do not support this capability (such as
1118 -- Windows...), this command does nothing, and Fork will return
1121 Pipe1, Pipe2, Pipe3 : aliased Pipe_Type;
1123 Arg : String_Access;
1124 Arg_List : String_List (1 .. Args'Length + 2);
1125 C_Arg_List : aliased array (1 .. Args'Length + 2) of System.Address;
1127 Command_With_Path : String_Access;
1130 Command_With_Path := Locate_Exec_On_Path (Command);
1132 if Command_With_Path = null then
1133 raise Invalid_Process;
1136 -- Create the rest of the pipes once we know we will be able to
1137 -- execute the process.
1139 Set_Up_Communications
1140 (Descriptor, Err_To_Out, Pipe1'Access, Pipe2'Access, Pipe3'Access);
1142 -- Fork a new process
1144 Descriptor.Pid := Fork;
1146 -- Are we now in the child (or, for Windows, still in the common
1149 if Descriptor.Pid = Null_Pid then
1150 -- Prepare an array of arguments to pass to C
1152 Arg := new String (1 .. Command_With_Path'Length + 1);
1153 Arg (1 .. Command_With_Path'Length) := Command_With_Path.all;
1154 Arg (Arg'Last) := ASCII.NUL;
1155 Arg_List (1) := Arg;
1157 for J in Args'Range loop
1158 Arg := new String (1 .. Args (J)'Length + 1);
1159 Arg (1 .. Args (J)'Length) := Args (J).all;
1160 Arg (Arg'Last) := ASCII.NUL;
1161 Arg_List (J + 2 - Args'First) := Arg.all'Access;
1164 Arg_List (Arg_List'Last) := null;
1166 -- Make sure all arguments are compatible with OS conventions
1168 Normalize_Arguments (Arg_List);
1170 -- Prepare low-level argument list from the normalized arguments
1172 for K in Arg_List'Range loop
1174 (if Arg_List (K) /= null
1175 then Arg_List (K).all'Address
1176 else System.Null_Address);
1179 -- This does not return on Unix systems
1181 Set_Up_Child_Communications
1182 (Descriptor, Pipe1, Pipe2, Pipe3, Command_With_Path.all,
1183 C_Arg_List'Address);
1186 Free (Command_With_Path);
1188 -- Did we have an error when spawning the child ?
1190 if Descriptor.Pid < Null_Pid then
1191 raise Invalid_Process;
1193 -- We are now in the parent process
1195 Set_Up_Parent_Communications (Descriptor, Pipe1, Pipe2, Pipe3);
1198 -- Create the buffer
1200 Descriptor.Buffer_Size := Buffer_Size;
1202 if Buffer_Size /= 0 then
1203 Descriptor.Buffer := new String (1 .. Positive (Buffer_Size));
1206 -- Initialize the filters
1208 Descriptor.Filters := null;
1209 end Non_Blocking_Spawn;
1211 -------------------------
1212 -- Reinitialize_Buffer --
1213 -------------------------
1215 procedure Reinitialize_Buffer
1216 (Descriptor : in out Process_Descriptor'Class)
1219 if Descriptor.Buffer_Size = 0 then
1221 Tmp : String_Access := Descriptor.Buffer;
1224 Descriptor.Buffer :=
1226 (1 .. Descriptor.Buffer_Index - Descriptor.Last_Match_End);
1229 Descriptor.Buffer.all := Tmp
1230 (Descriptor.Last_Match_End + 1 .. Descriptor.Buffer_Index);
1235 Descriptor.Buffer_Index := Descriptor.Buffer'Last;
1239 (1 .. Descriptor.Buffer_Index - Descriptor.Last_Match_End) :=
1241 (Descriptor.Last_Match_End + 1 .. Descriptor.Buffer_Index);
1243 if Descriptor.Buffer_Index > Descriptor.Last_Match_End then
1244 Descriptor.Buffer_Index :=
1245 Descriptor.Buffer_Index - Descriptor.Last_Match_End;
1247 Descriptor.Buffer_Index := 0;
1251 Descriptor.Last_Match_Start := 0;
1252 Descriptor.Last_Match_End := 0;
1253 end Reinitialize_Buffer;
1259 procedure Remove_Filter
1260 (Descriptor : in out Process_Descriptor;
1261 Filter : Filter_Function)
1263 Previous : Filter_List := null;
1264 Current : Filter_List := Descriptor.Filters;
1267 while Current /= null loop
1268 if Current.Filter = Filter then
1269 if Previous = null then
1270 Descriptor.Filters := Current.Next;
1272 Previous.Next := Current.Next;
1276 Previous := Current;
1277 Current := Current.Next;
1286 (Descriptor : in out Process_Descriptor;
1288 Add_LF : Boolean := True;
1289 Empty_Buffer : Boolean := False)
1291 Line_Feed : aliased constant String := (1 .. 1 => ASCII.LF);
1292 Descriptors : Array_Of_Pd := (1 => Descriptor'Unrestricted_Access);
1294 Result : Expect_Match;
1296 pragma Warnings (Off, Result);
1297 pragma Warnings (Off, Discard);
1300 if Empty_Buffer then
1302 -- Force a read on the process if there is anything waiting
1305 (Descriptors, Result, Timeout => 0, Full_Buffer => False);
1307 if Result = Expect_Internal_Error
1308 or else Result = Expect_Process_Died
1313 Descriptor.Last_Match_End := Descriptor.Buffer_Index;
1317 Reinitialize_Buffer (Descriptor);
1320 Call_Filters (Descriptor, Str, Input);
1322 Write (Descriptor.Input_Fd, Str'Address, Str'Last - Str'First + 1);
1325 Call_Filters (Descriptor, Line_Feed, Input);
1327 Write (Descriptor.Input_Fd, Line_Feed'Address, 1);
1335 procedure Send_Signal
1336 (Descriptor : Process_Descriptor;
1340 -- A nonpositive process id passed to kill has special meanings. For
1341 -- example, -1 means kill all processes in sight, including self, in
1342 -- POSIX and Windows (and something slightly different in Linux). See
1343 -- man pages for details. In any case, we don't want to do that. Note
1344 -- that Descriptor.Pid will be -1 if the process was not successfully
1345 -- started; we don't want to kill ourself in that case.
1347 if Descriptor.Pid > 0 then
1348 Kill (Descriptor.Pid, Signal, Close => 1);
1349 -- ??? Need to check process status here
1351 raise Invalid_Process;
1355 ---------------------------------
1356 -- Set_Up_Child_Communications --
1357 ---------------------------------
1359 procedure Set_Up_Child_Communications
1360 (Pid : in out Process_Descriptor;
1361 Pipe1 : in out Pipe_Type;
1362 Pipe2 : in out Pipe_Type;
1363 Pipe3 : in out Pipe_Type;
1365 Args : System.Address)
1367 pragma Warnings (Off, Pid);
1368 pragma Warnings (Off, Pipe1);
1369 pragma Warnings (Off, Pipe2);
1370 pragma Warnings (Off, Pipe3);
1372 Input : File_Descriptor;
1373 Output : File_Descriptor;
1374 Error : File_Descriptor;
1376 No_Fork_On_Target : constant Boolean := Target_OS = Windows;
1379 if No_Fork_On_Target then
1381 -- Since Windows does not have a separate fork/exec, we need to
1382 -- perform the following actions:
1384 -- - save stdin, stdout, stderr
1385 -- - replace them by our pipes
1386 -- - create the child with process handle inheritance
1387 -- - revert to the previous stdin, stdout and stderr.
1389 Input := Dup (GNAT.OS_Lib.Standin);
1390 Output := Dup (GNAT.OS_Lib.Standout);
1391 Error := Dup (GNAT.OS_Lib.Standerr);
1394 -- Since we are still called from the parent process, there is no way
1395 -- currently we can cleanly close the unneeded ends of the pipes, but
1396 -- this doesn't really matter.
1398 -- We could close Pipe1.Output, Pipe2.Input, Pipe3.Input
1400 Dup2 (Pipe1.Input, GNAT.OS_Lib.Standin);
1401 Dup2 (Pipe2.Output, GNAT.OS_Lib.Standout);
1402 Dup2 (Pipe3.Output, GNAT.OS_Lib.Standerr);
1404 Portable_Execvp (Pid.Pid'Access, Cmd & ASCII.NUL, Args);
1406 -- The following lines are only required for Windows systems and will
1407 -- not be executed on Unix systems, but we use the same condition as
1408 -- above to avoid warnings on uninitialized variables on Unix systems.
1409 -- We are now in the parent process.
1411 if No_Fork_On_Target then
1413 -- Restore the old descriptors
1415 Dup2 (Input, GNAT.OS_Lib.Standin);
1416 Dup2 (Output, GNAT.OS_Lib.Standout);
1417 Dup2 (Error, GNAT.OS_Lib.Standerr);
1422 end Set_Up_Child_Communications;
1424 ---------------------------
1425 -- Set_Up_Communications --
1426 ---------------------------
1428 procedure Set_Up_Communications
1429 (Pid : in out Process_Descriptor;
1430 Err_To_Out : Boolean;
1431 Pipe1 : not null access Pipe_Type;
1432 Pipe2 : not null access Pipe_Type;
1433 Pipe3 : not null access Pipe_Type)
1436 pragma Unreferenced (Status);
1441 if Create_Pipe (Pipe1) /= 0 then
1445 if Create_Pipe (Pipe2) /= 0 then
1446 Close (Pipe1.Input);
1447 Close (Pipe1.Output);
1451 -- Record the 'parent' end of the two pipes in Pid:
1452 -- Child stdin is connected to the 'write' end of Pipe1;
1453 -- Child stdout is connected to the 'read' end of Pipe2.
1454 -- We do not want these descriptors to remain open in the child
1455 -- process, so we mark them close-on-exec/non-inheritable.
1457 Pid.Input_Fd := Pipe1.Output;
1458 Set_Close_On_Exec (Pipe1.Output, True, Status);
1459 Pid.Output_Fd := Pipe2.Input;
1460 Set_Close_On_Exec (Pipe2.Input, True, Status);
1464 -- Reuse the standard output pipe for standard error
1466 Pipe3.all := Pipe2.all;
1469 -- Create a separate pipe for standard error
1471 if Create_Pipe (Pipe3) /= 0 then
1472 Pipe3.all := Pipe2.all;
1476 -- As above, record the proper fd for the child's standard error stream
1478 Pid.Error_Fd := Pipe3.Input;
1479 Set_Close_On_Exec (Pipe3.Input, True, Status);
1480 end Set_Up_Communications;
1482 ----------------------------------
1483 -- Set_Up_Parent_Communications --
1484 ----------------------------------
1486 procedure Set_Up_Parent_Communications
1487 (Pid : in out Process_Descriptor;
1488 Pipe1 : in out Pipe_Type;
1489 Pipe2 : in out Pipe_Type;
1490 Pipe3 : in out Pipe_Type)
1492 pragma Warnings (Off, Pid);
1493 pragma Warnings (Off, Pipe1);
1494 pragma Warnings (Off, Pipe2);
1495 pragma Warnings (Off, Pipe3);
1498 Close (Pipe1.Input);
1499 Close (Pipe2.Output);
1501 if Pipe3.Output /= Pipe2.Output then
1502 Close (Pipe3.Output);
1504 end Set_Up_Parent_Communications;
1510 procedure Trace_Filter
1511 (Descriptor : Process_Descriptor'Class;
1513 User_Data : System.Address := System.Null_Address)
1515 pragma Warnings (Off, Descriptor);
1516 pragma Warnings (Off, User_Data);
1521 --------------------
1522 -- Unlock_Filters --
1523 --------------------
1525 procedure Unlock_Filters (Descriptor : in out Process_Descriptor) is
1527 if Descriptor.Filters_Lock > 0 then
1528 Descriptor.Filters_Lock := Descriptor.Filters_Lock - 1;