PR target/16201
[official-gcc.git] / gcc / ada / g-expect.adb
blob144b157feeea84023d1c67b3df460517278ae0f1
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT LIBRARY COMPONENTS --
4 -- --
5 -- G N A T . E X P E C T --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2000-2003 Ada Core Technologies, Inc. --
10 -- --
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, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, USA. --
21 -- --
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. --
28 -- --
29 -- GNAT was originally developed by the GNAT team at New York University. --
30 -- Extensive contributions were provided by Ada Core Technologies Inc. --
31 -- --
32 ------------------------------------------------------------------------------
34 with System; use System;
35 with Ada.Calendar; use Ada.Calendar;
37 with GNAT.IO;
38 with GNAT.OS_Lib; use GNAT.OS_Lib;
39 with GNAT.Regpat; use GNAT.Regpat;
41 with 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;
50 Timeout : Integer;
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
56 -- expired.
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 Unchecked_Deallocation
70 (Pattern_Matcher, Pattern_Matcher_Access);
72 procedure Call_Filters
73 (Pid : Process_Descriptor'Class;
74 Str : String;
75 Filter_On : Filter_Type);
76 -- Call all the filters that have the appropriate type.
77 -- This function does nothing if the filters are locked
79 ------------------------------
80 -- Target dependent section --
81 ------------------------------
83 function Dup (Fd : File_Descriptor) return File_Descriptor;
84 pragma Import (C, Dup);
86 procedure Dup2 (Old_Fd, New_Fd : File_Descriptor);
87 pragma Import (C, Dup2);
89 procedure Kill (Pid : Process_Id; Sig_Num : Integer);
90 pragma Import (C, Kill, "__gnat_kill");
92 function Create_Pipe (Pipe : access Pipe_Type) return Integer;
93 pragma Import (C, Create_Pipe, "__gnat_pipe");
95 function Poll
96 (Fds : System.Address;
97 Num_Fds : Integer;
98 Timeout : Integer;
99 Is_Set : System.Address)
100 return Integer;
101 pragma Import (C, Poll, "__gnat_expect_poll");
102 -- Check whether there is any data waiting on the file descriptor
103 -- Out_fd, and wait if there is none, at most Timeout milliseconds
104 -- Returns -1 in case of error, 0 if the timeout expired before
105 -- data became available.
107 -- Out_Is_Set is set to 1 if data was available, 0 otherwise.
109 function Waitpid (Pid : Process_Id) return Integer;
110 pragma Import (C, Waitpid, "__gnat_waitpid");
111 -- Wait for a specific process id, and return its exit code.
113 ---------
114 -- "+" --
115 ---------
117 function "+" (S : String) return GNAT.OS_Lib.String_Access is
118 begin
119 return new String'(S);
120 end "+";
122 ---------
123 -- "+" --
124 ---------
126 function "+"
127 (P : GNAT.Regpat.Pattern_Matcher)
128 return Pattern_Matcher_Access
130 begin
131 return new GNAT.Regpat.Pattern_Matcher'(P);
132 end "+";
134 ----------------
135 -- Add_Filter --
136 ----------------
138 procedure Add_Filter
139 (Descriptor : in out Process_Descriptor;
140 Filter : Filter_Function;
141 Filter_On : Filter_Type := Output;
142 User_Data : System.Address := System.Null_Address;
143 After : Boolean := False)
145 Current : Filter_List := Descriptor.Filters;
147 begin
148 if After then
149 while Current /= null and then Current.Next /= null loop
150 Current := Current.Next;
151 end loop;
153 if Current = null then
154 Descriptor.Filters :=
155 new Filter_List_Elem'
156 (Filter => Filter, Filter_On => Filter_On,
157 User_Data => User_Data, Next => null);
158 else
159 Current.Next :=
160 new Filter_List_Elem'
161 (Filter => Filter, Filter_On => Filter_On,
162 User_Data => User_Data, Next => null);
163 end if;
165 else
166 Descriptor.Filters :=
167 new Filter_List_Elem'
168 (Filter => Filter, Filter_On => Filter_On,
169 User_Data => User_Data, Next => Descriptor.Filters);
170 end if;
171 end Add_Filter;
173 ------------------
174 -- Call_Filters --
175 ------------------
177 procedure Call_Filters
178 (Pid : Process_Descriptor'Class;
179 Str : String;
180 Filter_On : Filter_Type)
182 Current_Filter : Filter_List;
184 begin
185 if Pid.Filters_Lock = 0 then
186 Current_Filter := Pid.Filters;
188 while Current_Filter /= null loop
189 if Current_Filter.Filter_On = Filter_On then
190 Current_Filter.Filter
191 (Pid, Str, Current_Filter.User_Data);
192 end if;
194 Current_Filter := Current_Filter.Next;
195 end loop;
196 end if;
197 end Call_Filters;
199 -----------
200 -- Close --
201 -----------
203 procedure Close
204 (Descriptor : in out Process_Descriptor;
205 Status : out Integer)
207 begin
208 Close (Descriptor.Input_Fd);
210 if Descriptor.Error_Fd /= Descriptor.Output_Fd then
211 Close (Descriptor.Error_Fd);
212 end if;
214 Close (Descriptor.Output_Fd);
216 -- ??? Should have timeouts for different signals
217 Kill (Descriptor.Pid, 9);
219 GNAT.OS_Lib.Free (Descriptor.Buffer);
220 Descriptor.Buffer_Size := 0;
222 Status := Waitpid (Descriptor.Pid);
223 end Close;
225 procedure Close (Descriptor : in out Process_Descriptor) is
226 Status : Integer;
227 begin
228 Close (Descriptor, Status);
229 end Close;
231 ------------
232 -- Expect --
233 ------------
235 procedure Expect
236 (Descriptor : in out Process_Descriptor;
237 Result : out Expect_Match;
238 Regexp : String;
239 Timeout : Integer := 10000;
240 Full_Buffer : Boolean := False)
242 begin
243 if Regexp = "" then
244 Expect (Descriptor, Result, Never_Match, Timeout, Full_Buffer);
245 else
246 Expect (Descriptor, Result, Compile (Regexp), Timeout, Full_Buffer);
247 end if;
248 end Expect;
250 procedure Expect
251 (Descriptor : in out Process_Descriptor;
252 Result : out Expect_Match;
253 Regexp : String;
254 Matched : out GNAT.Regpat.Match_Array;
255 Timeout : Integer := 10000;
256 Full_Buffer : Boolean := False)
258 begin
259 pragma Assert (Matched'First = 0);
260 if Regexp = "" then
261 Expect
262 (Descriptor, Result, Never_Match, Matched, Timeout, Full_Buffer);
263 else
264 Expect
265 (Descriptor, Result, Compile (Regexp), Matched, Timeout,
266 Full_Buffer);
267 end if;
268 end Expect;
270 procedure Expect
271 (Descriptor : in out Process_Descriptor;
272 Result : out Expect_Match;
273 Regexp : GNAT.Regpat.Pattern_Matcher;
274 Timeout : Integer := 10000;
275 Full_Buffer : Boolean := False)
277 Matched : GNAT.Regpat.Match_Array (0 .. 0);
279 begin
280 Expect (Descriptor, Result, Regexp, Matched, Timeout, Full_Buffer);
281 end Expect;
283 procedure Expect
284 (Descriptor : in out Process_Descriptor;
285 Result : out Expect_Match;
286 Regexp : GNAT.Regpat.Pattern_Matcher;
287 Matched : out GNAT.Regpat.Match_Array;
288 Timeout : Integer := 10000;
289 Full_Buffer : Boolean := False)
291 N : Expect_Match;
292 Descriptors : Array_Of_Pd := (1 => Descriptor'Unrestricted_Access);
293 Try_Until : constant Time := Clock + Duration (Timeout) / 1000.0;
294 Timeout_Tmp : Integer := Timeout;
296 begin
297 pragma Assert (Matched'First = 0);
298 Reinitialize_Buffer (Descriptor);
300 loop
301 -- First, test if what is already in the buffer matches (This is
302 -- required if this package is used in multi-task mode, since one of
303 -- the tasks might have added something in the buffer, and we don't
304 -- want other tasks to wait for new input to be available before
305 -- checking the regexps).
307 Match
308 (Regexp, Descriptor.Buffer (1 .. Descriptor.Buffer_Index), Matched);
310 if Descriptor.Buffer_Index >= 1 and then Matched (0).First /= 0 then
311 Result := 1;
312 Descriptor.Last_Match_Start := Matched (0).First;
313 Descriptor.Last_Match_End := Matched (0).Last;
314 return;
315 end if;
317 -- Else try to read new input
319 Expect_Internal (Descriptors, N, Timeout_Tmp, Full_Buffer);
321 if N = Expect_Timeout or else N = Expect_Full_Buffer then
322 Result := N;
323 return;
324 end if;
326 -- Calculate the timeout for the next turn.
327 -- Note that Timeout is, from the caller's perspective, the maximum
328 -- time until a match, not the maximum time until some output is
329 -- read, and thus can not be reused as is for Expect_Internal.
331 if Timeout /= -1 then
332 Timeout_Tmp := Integer (Try_Until - Clock) * 1000;
334 if Timeout_Tmp < 0 then
335 Result := Expect_Timeout;
336 exit;
337 end if;
338 end if;
339 end loop;
341 -- Even if we had the general timeout above, we have to test that the
342 -- last test we read from the external process didn't match.
344 Match
345 (Regexp, Descriptor.Buffer (1 .. Descriptor.Buffer_Index), Matched);
347 if Matched (0).First /= 0 then
348 Result := 1;
349 Descriptor.Last_Match_Start := Matched (0).First;
350 Descriptor.Last_Match_End := Matched (0).Last;
351 return;
352 end if;
353 end Expect;
355 procedure Expect
356 (Descriptor : in out Process_Descriptor;
357 Result : out Expect_Match;
358 Regexps : Regexp_Array;
359 Timeout : Integer := 10000;
360 Full_Buffer : Boolean := False)
362 Patterns : Compiled_Regexp_Array (Regexps'Range);
363 Matched : GNAT.Regpat.Match_Array (0 .. 0);
365 begin
366 for J in Regexps'Range loop
367 Patterns (J) := new Pattern_Matcher'(Compile (Regexps (J).all));
368 end loop;
370 Expect (Descriptor, Result, Patterns, Matched, Timeout, Full_Buffer);
372 for J in Regexps'Range loop
373 Free (Patterns (J));
374 end loop;
375 end Expect;
377 procedure Expect
378 (Descriptor : in out Process_Descriptor;
379 Result : out Expect_Match;
380 Regexps : Compiled_Regexp_Array;
381 Timeout : Integer := 10000;
382 Full_Buffer : Boolean := False)
384 Matched : GNAT.Regpat.Match_Array (0 .. 0);
386 begin
387 Expect (Descriptor, Result, Regexps, Matched, Timeout, Full_Buffer);
388 end Expect;
390 procedure Expect
391 (Result : out Expect_Match;
392 Regexps : Multiprocess_Regexp_Array;
393 Timeout : Integer := 10000;
394 Full_Buffer : Boolean := False)
396 Matched : GNAT.Regpat.Match_Array (0 .. 0);
398 begin
399 Expect (Result, Regexps, Matched, Timeout, Full_Buffer);
400 end Expect;
402 procedure Expect
403 (Descriptor : in out Process_Descriptor;
404 Result : out Expect_Match;
405 Regexps : Regexp_Array;
406 Matched : out GNAT.Regpat.Match_Array;
407 Timeout : Integer := 10000;
408 Full_Buffer : Boolean := False)
410 Patterns : Compiled_Regexp_Array (Regexps'Range);
412 begin
413 pragma Assert (Matched'First = 0);
415 for J in Regexps'Range loop
416 Patterns (J) := new Pattern_Matcher'(Compile (Regexps (J).all));
417 end loop;
419 Expect (Descriptor, Result, Patterns, Matched, Timeout, Full_Buffer);
421 for J in Regexps'Range loop
422 Free (Patterns (J));
423 end loop;
424 end Expect;
426 procedure Expect
427 (Descriptor : in out Process_Descriptor;
428 Result : out Expect_Match;
429 Regexps : Compiled_Regexp_Array;
430 Matched : out GNAT.Regpat.Match_Array;
431 Timeout : Integer := 10000;
432 Full_Buffer : Boolean := False)
434 N : Expect_Match;
435 Descriptors : Array_Of_Pd := (1 => Descriptor'Unrestricted_Access);
437 begin
438 pragma Assert (Matched'First = 0);
440 Reinitialize_Buffer (Descriptor);
442 loop
443 -- First, test if what is already in the buffer matches (This is
444 -- required if this package is used in multi-task mode, since one of
445 -- the tasks might have added something in the buffer, and we don't
446 -- want other tasks to wait for new input to be available before
447 -- checking the regexps).
449 if Descriptor.Buffer /= null then
450 for J in Regexps'Range loop
451 Match
452 (Regexps (J).all,
453 Descriptor.Buffer (1 .. Descriptor.Buffer_Index),
454 Matched);
456 if Matched (0) /= No_Match then
457 Result := Expect_Match (J);
458 Descriptor.Last_Match_Start := Matched (0).First;
459 Descriptor.Last_Match_End := Matched (0).Last;
460 return;
461 end if;
462 end loop;
463 end if;
465 Expect_Internal (Descriptors, N, Timeout, Full_Buffer);
467 if N = Expect_Timeout or else N = Expect_Full_Buffer then
468 Result := N;
469 return;
470 end if;
471 end loop;
472 end Expect;
474 procedure Expect
475 (Result : out Expect_Match;
476 Regexps : Multiprocess_Regexp_Array;
477 Matched : out GNAT.Regpat.Match_Array;
478 Timeout : Integer := 10000;
479 Full_Buffer : Boolean := False)
481 N : Expect_Match;
482 Descriptors : Array_Of_Pd (Regexps'Range);
484 begin
485 pragma Assert (Matched'First = 0);
487 for J in Descriptors'Range loop
488 Descriptors (J) := Regexps (J).Descriptor;
489 Reinitialize_Buffer (Regexps (J).Descriptor.all);
490 end loop;
492 loop
493 -- First, test if what is already in the buffer matches (This is
494 -- required if this package is used in multi-task mode, since one of
495 -- the tasks might have added something in the buffer, and we don't
496 -- want other tasks to wait for new input to be available before
497 -- checking the regexps).
499 for J in Regexps'Range loop
500 Match (Regexps (J).Regexp.all,
501 Regexps (J).Descriptor.Buffer
502 (1 .. Regexps (J).Descriptor.Buffer_Index),
503 Matched);
505 if Matched (0) /= No_Match then
506 Result := Expect_Match (J);
507 Regexps (J).Descriptor.Last_Match_Start := Matched (0).First;
508 Regexps (J).Descriptor.Last_Match_End := Matched (0).Last;
509 return;
510 end if;
511 end loop;
513 Expect_Internal (Descriptors, N, Timeout, Full_Buffer);
515 if N = Expect_Timeout or else N = Expect_Full_Buffer then
516 Result := N;
517 return;
518 end if;
519 end loop;
520 end Expect;
522 ---------------------
523 -- Expect_Internal --
524 ---------------------
526 procedure Expect_Internal
527 (Descriptors : in out Array_Of_Pd;
528 Result : out Expect_Match;
529 Timeout : Integer;
530 Full_Buffer : Boolean)
532 Num_Descriptors : Integer;
533 Buffer_Size : Integer := 0;
535 N : Integer;
537 type File_Descriptor_Array is
538 array (Descriptors'Range) of File_Descriptor;
539 Fds : aliased File_Descriptor_Array;
541 type Integer_Array is array (Descriptors'Range) of Integer;
542 Is_Set : aliased Integer_Array;
544 begin
545 for J in Descriptors'Range loop
546 Fds (J) := Descriptors (J).Output_Fd;
548 if Descriptors (J).Buffer_Size = 0 then
549 Buffer_Size := Integer'Max (Buffer_Size, 4096);
550 else
551 Buffer_Size :=
552 Integer'Max (Buffer_Size, Descriptors (J).Buffer_Size);
553 end if;
554 end loop;
556 declare
557 Buffer : aliased String (1 .. Buffer_Size);
558 -- Buffer used for input. This is allocated only once, not for
559 -- every iteration of the loop
561 begin
562 -- Loop until we match or we have a timeout
564 loop
565 Num_Descriptors :=
566 Poll (Fds'Address, Fds'Length, Timeout, Is_Set'Address);
568 case Num_Descriptors is
570 -- Error?
572 when -1 =>
573 raise Process_Died;
575 -- Timeout?
577 when 0 =>
578 Result := Expect_Timeout;
579 return;
581 -- Some input
583 when others =>
584 for J in Descriptors'Range loop
585 if Is_Set (J) = 1 then
586 Buffer_Size := Descriptors (J).Buffer_Size;
588 if Buffer_Size = 0 then
589 Buffer_Size := 4096;
590 end if;
592 N := Read (Descriptors (J).Output_Fd, Buffer'Address,
593 Buffer_Size);
595 -- Error or End of file
597 if N <= 0 then
598 -- ??? Note that ddd tries again up to three times
599 -- in that case. See LiterateA.C:174
600 raise Process_Died;
602 else
603 -- If there is no limit to the buffer size
605 if Descriptors (J).Buffer_Size = 0 then
607 declare
608 Tmp : String_Access := Descriptors (J).Buffer;
610 begin
611 if Tmp /= null then
612 Descriptors (J).Buffer :=
613 new String (1 .. Tmp'Length + N);
614 Descriptors (J).Buffer (1 .. Tmp'Length) :=
615 Tmp.all;
616 Descriptors (J).Buffer
617 (Tmp'Length + 1 .. Tmp'Length + N) :=
618 Buffer (1 .. N);
619 Free (Tmp);
620 Descriptors (J).Buffer_Index :=
621 Descriptors (J).Buffer'Last;
623 else
624 Descriptors (J).Buffer :=
625 new String (1 .. N);
626 Descriptors (J).Buffer.all :=
627 Buffer (1 .. N);
628 Descriptors (J).Buffer_Index := N;
629 end if;
630 end;
632 else
633 -- Add what we read to the buffer
635 if Descriptors (J).Buffer_Index + N - 1 >
636 Descriptors (J).Buffer_Size
637 then
638 -- If the user wants to know when we have
639 -- read more than the buffer can contain.
641 if Full_Buffer then
642 Result := Expect_Full_Buffer;
643 return;
644 end if;
646 -- Keep as much as possible from the buffer,
647 -- and forget old characters.
649 Descriptors (J).Buffer
650 (1 .. Descriptors (J).Buffer_Size - N) :=
651 Descriptors (J).Buffer
652 (N - Descriptors (J).Buffer_Size +
653 Descriptors (J).Buffer_Index + 1 ..
654 Descriptors (J).Buffer_Index);
655 Descriptors (J).Buffer_Index :=
656 Descriptors (J).Buffer_Size - N;
657 end if;
659 -- Keep what we read in the buffer.
661 Descriptors (J).Buffer
662 (Descriptors (J).Buffer_Index + 1 ..
663 Descriptors (J).Buffer_Index + N) :=
664 Buffer (1 .. N);
665 Descriptors (J).Buffer_Index :=
666 Descriptors (J).Buffer_Index + N;
667 end if;
669 -- Call each of the output filter with what we
670 -- read.
672 Call_Filters
673 (Descriptors (J).all, Buffer (1 .. N), Output);
675 Result := Expect_Match (N);
676 return;
677 end if;
678 end if;
679 end loop;
680 end case;
681 end loop;
682 end;
683 end Expect_Internal;
685 ----------------
686 -- Expect_Out --
687 ----------------
689 function Expect_Out (Descriptor : Process_Descriptor) return String is
690 begin
691 return Descriptor.Buffer (1 .. Descriptor.Last_Match_End);
692 end Expect_Out;
694 ----------------------
695 -- Expect_Out_Match --
696 ----------------------
698 function Expect_Out_Match (Descriptor : Process_Descriptor) return String is
699 begin
700 return Descriptor.Buffer
701 (Descriptor.Last_Match_Start .. Descriptor.Last_Match_End);
702 end Expect_Out_Match;
704 -----------
705 -- Flush --
706 -----------
708 procedure Flush
709 (Descriptor : in out Process_Descriptor;
710 Timeout : Integer := 0)
712 Buffer_Size : constant Integer := 8192;
713 Num_Descriptors : Integer;
714 N : Integer;
715 Is_Set : aliased Integer;
716 Buffer : aliased String (1 .. Buffer_Size);
718 begin
719 -- Empty the current buffer
721 Descriptor.Last_Match_End := Descriptor.Buffer_Index;
722 Reinitialize_Buffer (Descriptor);
724 -- Read everything from the process to flush its output
726 loop
727 Num_Descriptors :=
728 Poll (Descriptor.Output_Fd'Address, 1, Timeout, Is_Set'Address);
730 case Num_Descriptors is
732 -- Error ?
734 when -1 =>
735 raise Process_Died;
737 -- Timeout => End of flush
739 when 0 =>
740 return;
742 -- Some input
744 when others =>
745 if Is_Set = 1 then
746 N := Read (Descriptor.Output_Fd, Buffer'Address,
747 Buffer_Size);
749 if N = -1 then
750 raise Process_Died;
751 elsif N = 0 then
752 return;
753 end if;
754 end if;
755 end case;
756 end loop;
758 end Flush;
760 ------------------
761 -- Get_Error_Fd --
762 ------------------
764 function Get_Error_Fd
765 (Descriptor : Process_Descriptor)
766 return GNAT.OS_Lib.File_Descriptor
768 begin
769 return Descriptor.Error_Fd;
770 end Get_Error_Fd;
772 ------------------
773 -- Get_Input_Fd --
774 ------------------
776 function Get_Input_Fd
777 (Descriptor : Process_Descriptor)
778 return GNAT.OS_Lib.File_Descriptor
780 begin
781 return Descriptor.Input_Fd;
782 end Get_Input_Fd;
784 -------------------
785 -- Get_Output_Fd --
786 -------------------
788 function Get_Output_Fd
789 (Descriptor : Process_Descriptor)
790 return GNAT.OS_Lib.File_Descriptor
792 begin
793 return Descriptor.Output_Fd;
794 end Get_Output_Fd;
796 -------------
797 -- Get_Pid --
798 -------------
800 function Get_Pid
801 (Descriptor : Process_Descriptor)
802 return Process_Id
804 begin
805 return Descriptor.Pid;
806 end Get_Pid;
808 ---------------
809 -- Interrupt --
810 ---------------
812 procedure Interrupt (Descriptor : in out Process_Descriptor) is
813 SIGINT : constant := 2;
815 begin
816 Send_Signal (Descriptor, SIGINT);
817 end Interrupt;
819 ------------------
820 -- Lock_Filters --
821 ------------------
823 procedure Lock_Filters (Descriptor : in out Process_Descriptor) is
824 begin
825 Descriptor.Filters_Lock := Descriptor.Filters_Lock + 1;
826 end Lock_Filters;
828 ------------------------
829 -- Non_Blocking_Spawn --
830 ------------------------
832 procedure Non_Blocking_Spawn
833 (Descriptor : out Process_Descriptor'Class;
834 Command : String;
835 Args : GNAT.OS_Lib.Argument_List;
836 Buffer_Size : Natural := 4096;
837 Err_To_Out : Boolean := False)
839 function Fork return Process_Id;
840 pragma Import (C, Fork, "__gnat_expect_fork");
841 -- Starts a new process if possible. See the Unix command fork for more
842 -- information. On systems that do not support this capability (such as
843 -- Windows...), this command does nothing, and Fork will return
844 -- Null_Pid.
846 Pipe1, Pipe2, Pipe3 : aliased Pipe_Type;
848 Arg : String_Access;
849 Arg_List : String_List (1 .. Args'Length + 2);
850 C_Arg_List : aliased array (1 .. Args'Length + 2) of System.Address;
852 Command_With_Path : String_Access;
854 begin
855 -- Create the rest of the pipes
857 Set_Up_Communications
858 (Descriptor, Err_To_Out, Pipe1'Access, Pipe2'Access, Pipe3'Access);
860 Command_With_Path := Locate_Exec_On_Path (Command);
862 if Command_With_Path = null then
863 raise Invalid_Process;
864 end if;
866 -- Fork a new process
868 Descriptor.Pid := Fork;
870 -- Are we now in the child (or, for Windows, still in the common
871 -- process).
873 if Descriptor.Pid = Null_Pid then
874 -- Prepare an array of arguments to pass to C
876 Arg := new String (1 .. Command_With_Path'Length + 1);
877 Arg (1 .. Command_With_Path'Length) := Command_With_Path.all;
878 Arg (Arg'Last) := ASCII.NUL;
879 Arg_List (1) := Arg;
881 for J in Args'Range loop
882 Arg := new String (1 .. Args (J)'Length + 1);
883 Arg (1 .. Args (J)'Length) := Args (J).all;
884 Arg (Arg'Last) := ASCII.NUL;
885 Arg_List (J + 2 - Args'First) := Arg.all'Access;
886 end loop;
888 Arg_List (Arg_List'Last) := null;
890 -- Make sure all arguments are compatible with OS conventions
892 Normalize_Arguments (Arg_List);
894 -- Prepare low-level argument list from the normalized arguments
896 for K in Arg_List'Range loop
897 if Arg_List (K) /= null then
898 C_Arg_List (K) := Arg_List (K).all'Address;
899 else
900 C_Arg_List (K) := System.Null_Address;
901 end if;
902 end loop;
904 -- This does not return on Unix systems
906 Set_Up_Child_Communications
907 (Descriptor, Pipe1, Pipe2, Pipe3, Command_With_Path.all,
908 C_Arg_List'Address);
909 end if;
911 Free (Command_With_Path);
913 -- Did we have an error when spawning the child ?
915 if Descriptor.Pid < Null_Pid then
916 raise Invalid_Process;
917 else
918 -- We are now in the parent process
920 Set_Up_Parent_Communications (Descriptor, Pipe1, Pipe2, Pipe3);
921 end if;
923 -- Create the buffer
925 Descriptor.Buffer_Size := Buffer_Size;
927 if Buffer_Size /= 0 then
928 Descriptor.Buffer := new String (1 .. Positive (Buffer_Size));
929 end if;
930 end Non_Blocking_Spawn;
932 -------------------------
933 -- Reinitialize_Buffer --
934 -------------------------
936 procedure Reinitialize_Buffer
937 (Descriptor : in out Process_Descriptor'Class)
939 begin
940 if Descriptor.Buffer_Size = 0 then
941 declare
942 Tmp : String_Access := Descriptor.Buffer;
944 begin
945 Descriptor.Buffer :=
946 new String
947 (1 .. Descriptor.Buffer_Index - Descriptor.Last_Match_End);
949 if Tmp /= null then
950 Descriptor.Buffer.all := Tmp
951 (Descriptor.Last_Match_End + 1 .. Descriptor.Buffer_Index);
952 Free (Tmp);
953 end if;
954 end;
956 Descriptor.Buffer_Index := Descriptor.Buffer'Last;
958 else
959 Descriptor.Buffer
960 (1 .. Descriptor.Buffer_Index - Descriptor.Last_Match_End) :=
961 Descriptor.Buffer
962 (Descriptor.Last_Match_End + 1 .. Descriptor.Buffer_Index);
964 if Descriptor.Buffer_Index > Descriptor.Last_Match_End then
965 Descriptor.Buffer_Index :=
966 Descriptor.Buffer_Index - Descriptor.Last_Match_End;
967 else
968 Descriptor.Buffer_Index := 0;
969 end if;
970 end if;
972 Descriptor.Last_Match_Start := 0;
973 Descriptor.Last_Match_End := 0;
974 end Reinitialize_Buffer;
976 -------------------
977 -- Remove_Filter --
978 -------------------
980 procedure Remove_Filter
981 (Descriptor : in out Process_Descriptor;
982 Filter : Filter_Function)
984 Previous : Filter_List := null;
985 Current : Filter_List := Descriptor.Filters;
987 begin
988 while Current /= null loop
989 if Current.Filter = Filter then
990 if Previous = null then
991 Descriptor.Filters := Current.Next;
992 else
993 Previous.Next := Current.Next;
994 end if;
995 end if;
997 Previous := Current;
998 Current := Current.Next;
999 end loop;
1000 end Remove_Filter;
1002 ----------
1003 -- Send --
1004 ----------
1006 procedure Send
1007 (Descriptor : in out Process_Descriptor;
1008 Str : String;
1009 Add_LF : Boolean := True;
1010 Empty_Buffer : Boolean := False)
1012 Full_Str : constant String := Str & ASCII.LF;
1013 Last : Natural;
1014 Result : Expect_Match;
1015 Descriptors : Array_Of_Pd := (1 => Descriptor'Unrestricted_Access);
1017 Dummy : Natural;
1018 pragma Unreferenced (Dummy);
1020 begin
1021 if Empty_Buffer then
1023 -- Force a read on the process if there is anything waiting.
1025 Expect_Internal (Descriptors, Result,
1026 Timeout => 0, Full_Buffer => False);
1027 Descriptor.Last_Match_End := Descriptor.Buffer_Index;
1029 -- Empty the buffer
1031 Reinitialize_Buffer (Descriptor);
1032 end if;
1034 if Add_LF then
1035 Last := Full_Str'Last;
1036 else
1037 Last := Full_Str'Last - 1;
1038 end if;
1040 Call_Filters (Descriptor, Full_Str (Full_Str'First .. Last), Input);
1042 Dummy :=
1043 Write (Descriptor.Input_Fd,
1044 Full_Str'Address,
1045 Last - Full_Str'First + 1);
1046 end Send;
1048 -----------------
1049 -- Send_Signal --
1050 -----------------
1052 procedure Send_Signal
1053 (Descriptor : Process_Descriptor;
1054 Signal : Integer)
1056 begin
1057 Kill (Descriptor.Pid, Signal);
1058 -- ??? Need to check process status here.
1059 end Send_Signal;
1061 ---------------------------------
1062 -- Set_Up_Child_Communications --
1063 ---------------------------------
1065 procedure Set_Up_Child_Communications
1066 (Pid : in out Process_Descriptor;
1067 Pipe1 : in out Pipe_Type;
1068 Pipe2 : in out Pipe_Type;
1069 Pipe3 : in out Pipe_Type;
1070 Cmd : in String;
1071 Args : in System.Address)
1073 pragma Warnings (Off, Pid);
1075 Input : File_Descriptor;
1076 Output : File_Descriptor;
1077 Error : File_Descriptor;
1079 begin
1080 -- Since Windows does not have a separate fork/exec, we need to
1081 -- perform the following actions:
1082 -- - save stdin, stdout, stderr
1083 -- - replace them by our pipes
1084 -- - create the child with process handle inheritance
1085 -- - revert to the previous stdin, stdout and stderr.
1087 Input := Dup (GNAT.OS_Lib.Standin);
1088 Output := Dup (GNAT.OS_Lib.Standout);
1089 Error := Dup (GNAT.OS_Lib.Standerr);
1091 -- Since we are still called from the parent process, there is no way
1092 -- currently we can cleanly close the unneeded ends of the pipes, but
1093 -- this doesn't really matter.
1094 -- We could close Pipe1.Output, Pipe2.Input, Pipe3.Input.
1096 Dup2 (Pipe1.Input, GNAT.OS_Lib.Standin);
1097 Dup2 (Pipe2.Output, GNAT.OS_Lib.Standout);
1098 Dup2 (Pipe3.Output, GNAT.OS_Lib.Standerr);
1100 Portable_Execvp (Pid.Pid'Access, Cmd & ASCII.Nul, Args);
1102 -- The following commands are not executed on Unix systems, and are
1103 -- only required for Windows systems. We are now in the parent process.
1105 -- Restore the old descriptors
1107 Dup2 (Input, GNAT.OS_Lib.Standin);
1108 Dup2 (Output, GNAT.OS_Lib.Standout);
1109 Dup2 (Error, GNAT.OS_Lib.Standerr);
1110 Close (Input);
1111 Close (Output);
1112 Close (Error);
1113 end Set_Up_Child_Communications;
1115 ---------------------------
1116 -- Set_Up_Communications --
1117 ---------------------------
1119 procedure Set_Up_Communications
1120 (Pid : in out Process_Descriptor;
1121 Err_To_Out : Boolean;
1122 Pipe1 : access Pipe_Type;
1123 Pipe2 : access Pipe_Type;
1124 Pipe3 : access Pipe_Type)
1126 begin
1127 -- Create the pipes
1129 if Create_Pipe (Pipe1) /= 0 then
1130 return;
1131 end if;
1133 if Create_Pipe (Pipe2) /= 0 then
1134 return;
1135 end if;
1137 Pid.Input_Fd := Pipe1.Output;
1138 Pid.Output_Fd := Pipe2.Input;
1140 if Err_To_Out then
1141 Pipe3.all := Pipe2.all;
1142 else
1143 if Create_Pipe (Pipe3) /= 0 then
1144 return;
1145 end if;
1146 end if;
1148 Pid.Error_Fd := Pipe3.Input;
1149 end Set_Up_Communications;
1151 ----------------------------------
1152 -- Set_Up_Parent_Communications --
1153 ----------------------------------
1155 procedure Set_Up_Parent_Communications
1156 (Pid : in out Process_Descriptor;
1157 Pipe1 : in out Pipe_Type;
1158 Pipe2 : in out Pipe_Type;
1159 Pipe3 : in out Pipe_Type)
1161 pragma Warnings (Off, Pid);
1163 begin
1164 Close (Pipe1.Input);
1165 Close (Pipe2.Output);
1166 Close (Pipe3.Output);
1167 end Set_Up_Parent_Communications;
1169 ------------------
1170 -- Trace_Filter --
1171 ------------------
1173 procedure Trace_Filter
1174 (Descriptor : Process_Descriptor'Class;
1175 Str : String;
1176 User_Data : System.Address := System.Null_Address)
1178 pragma Warnings (Off, Descriptor);
1179 pragma Warnings (Off, User_Data);
1181 begin
1182 GNAT.IO.Put (Str);
1183 end Trace_Filter;
1185 --------------------
1186 -- Unlock_Filters --
1187 --------------------
1189 procedure Unlock_Filters (Descriptor : in out Process_Descriptor) is
1190 begin
1191 if Descriptor.Filters_Lock > 0 then
1192 Descriptor.Filters_Lock := Descriptor.Filters_Lock - 1;
1193 end if;
1194 end Unlock_Filters;
1196 end GNAT.Expect;