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-2019, AdaCore                     --
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 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.                                     --
17--                                                                          --
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.               --
21--                                                                          --
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/>.                                          --
26--                                                                          --
27-- GNAT was originally developed  by the GNAT team at  New York University. --
28-- Extensive contributions were provided by Ada Core Technologies Inc.      --
29--                                                                          --
30------------------------------------------------------------------------------
31
32with System;              use System;
33with System.OS_Constants; use System.OS_Constants;
34with Ada.Calendar;        use Ada.Calendar;
35
36with GNAT.IO;      use GNAT.IO;
37with GNAT.OS_Lib;  use GNAT.OS_Lib;
38with GNAT.Regpat;  use GNAT.Regpat;
39
40with Ada.Unchecked_Deallocation;
41
42package body GNAT.Expect is
43
44   type Array_Of_Pd is array (Positive range <>) of Process_Descriptor_Access;
45
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.
50
51   procedure Expect_Internal
52     (Descriptors : in out Array_Of_Pd;
53      Result      : out Expect_Match;
54      Timeout     : Integer;
55      Full_Buffer : Boolean);
56   --  Internal function used to read from the process Descriptor.
57   --
58   --  Several outputs are possible:
59   --     Result=Expect_Timeout, if no output was available before the timeout
60   --        expired.
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.
70
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.
75
76   procedure Free is new Ada.Unchecked_Deallocation
77     (Pattern_Matcher, Pattern_Matcher_Access);
78
79   procedure Free is new Ada.Unchecked_Deallocation
80     (Filter_List_Elem, Filter_List);
81
82   procedure Call_Filters
83     (Pid       : Process_Descriptor'Class;
84      Str       : String;
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
88
89   ------------------------------
90   -- Target dependent section --
91   ------------------------------
92
93   function Dup (Fd : File_Descriptor) return File_Descriptor;
94   pragma Import (C, Dup);
95
96   procedure Dup2 (Old_Fd, New_Fd : File_Descriptor);
97   pragma Import (C, Dup2);
98
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
102
103   function Create_Pipe (Pipe : not null access Pipe_Type) return Integer;
104   pragma Import (C, Create_Pipe, "__gnat_pipe");
105
106   function Poll
107     (Fds          : System.Address;
108      Num_Fds      : Integer;
109      Timeout      : Integer;
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.
117   --
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.
120   --
121   --  If a process dies, then Dead_Process is set to the index of the
122   --  corresponding file descriptor.
123
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
127
128   ---------
129   -- "+" --
130   ---------
131
132   function "+" (S : String) return GNAT.OS_Lib.String_Access is
133   begin
134      return new String'(S);
135   end "+";
136
137   ---------
138   -- "+" --
139   ---------
140
141   function "+"
142     (P : GNAT.Regpat.Pattern_Matcher) return Pattern_Matcher_Access
143   is
144   begin
145      return new GNAT.Regpat.Pattern_Matcher'(P);
146   end "+";
147
148   ----------------
149   -- Add_Filter --
150   ----------------
151
152   procedure Add_Filter
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)
158   is
159      Current : Filter_List := Descriptor.Filters;
160
161   begin
162      if After then
163         while Current /= null and then Current.Next /= null loop
164            Current := Current.Next;
165         end loop;
166
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);
172         else
173            Current.Next :=
174              new Filter_List_Elem'
175              (Filter => Filter, Filter_On => Filter_On,
176               User_Data => User_Data, Next => null);
177         end if;
178
179      else
180         Descriptor.Filters :=
181           new Filter_List_Elem'
182             (Filter => Filter, Filter_On => Filter_On,
183              User_Data => User_Data, Next => Descriptor.Filters);
184      end if;
185   end Add_Filter;
186
187   ------------------
188   -- Call_Filters --
189   ------------------
190
191   procedure Call_Filters
192     (Pid       : Process_Descriptor'Class;
193      Str       : String;
194      Filter_On : Filter_Type)
195   is
196      Current_Filter  : Filter_List;
197
198   begin
199      if Pid.Filters_Lock = 0 then
200         Current_Filter := Pid.Filters;
201
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);
206            end if;
207
208            Current_Filter := Current_Filter.Next;
209         end loop;
210      end if;
211   end Call_Filters;
212
213   -----------
214   -- Close --
215   -----------
216
217   procedure Close
218     (Descriptor : in out Process_Descriptor;
219      Status     : out Integer)
220   is
221      Current_Filter : Filter_List;
222      Next_Filter    : Filter_List;
223
224   begin
225      if Descriptor.Input_Fd /= Invalid_FD then
226         Close (Descriptor.Input_Fd);
227      end if;
228
229      if Descriptor.Error_Fd /= Descriptor.Output_Fd then
230         Close (Descriptor.Error_Fd);
231      end if;
232
233      Close (Descriptor.Output_Fd);
234
235      --  ??? Should have timeouts for different signals
236
237      if Descriptor.Pid > 0 then  --  see comment in Send_Signal
238         Kill (Descriptor.Pid, Sig_Num => 9, Close => 0);
239      end if;
240
241      GNAT.OS_Lib.Free (Descriptor.Buffer);
242      Descriptor.Buffer_Size := 0;
243
244      Current_Filter := Descriptor.Filters;
245
246      while Current_Filter /= null loop
247         Next_Filter := Current_Filter.Next;
248         Free (Current_Filter);
249         Current_Filter := Next_Filter;
250      end loop;
251
252      Descriptor.Filters := null;
253
254      --  Check process id (see comment in Send_Signal)
255
256      if Descriptor.Pid > 0 then
257         Status := Waitpid (Descriptor.Pid);
258      else
259         raise Invalid_Process;
260      end if;
261   end Close;
262
263   procedure Close (Descriptor : in out Process_Descriptor) is
264      Status : Integer;
265      pragma Unreferenced (Status);
266   begin
267      Close (Descriptor, Status);
268   end Close;
269
270   ------------
271   -- Expect --
272   ------------
273
274   procedure Expect
275     (Descriptor  : in out Process_Descriptor;
276      Result      : out Expect_Match;
277      Regexp      : String;
278      Timeout     : Integer := 10_000;
279      Full_Buffer : Boolean := False)
280   is
281   begin
282      if Regexp = "" then
283         Expect (Descriptor, Result, Never_Match, Timeout, Full_Buffer);
284      else
285         Expect (Descriptor, Result, Compile (Regexp), Timeout, Full_Buffer);
286      end if;
287   end Expect;
288
289   procedure Expect
290     (Descriptor  : in out Process_Descriptor;
291      Result      : out Expect_Match;
292      Regexp      : String;
293      Matched     : out GNAT.Regpat.Match_Array;
294      Timeout     : Integer := 10_000;
295      Full_Buffer : Boolean := False)
296   is
297   begin
298      pragma Assert (Matched'First = 0);
299      if Regexp = "" then
300         Expect
301           (Descriptor, Result, Never_Match, Matched, Timeout, Full_Buffer);
302      else
303         Expect
304           (Descriptor, Result, Compile (Regexp), Matched, Timeout,
305            Full_Buffer);
306      end if;
307   end Expect;
308
309   procedure Expect
310     (Descriptor  : in out Process_Descriptor;
311      Result      : out Expect_Match;
312      Regexp      : GNAT.Regpat.Pattern_Matcher;
313      Timeout     : Integer := 10_000;
314      Full_Buffer : Boolean := False)
315   is
316      Matched : GNAT.Regpat.Match_Array (0 .. 0);
317      pragma Warnings (Off, Matched);
318   begin
319      Expect (Descriptor, Result, Regexp, Matched, Timeout, Full_Buffer);
320   end Expect;
321
322   procedure Expect
323     (Descriptor  : in out Process_Descriptor;
324      Result      : out Expect_Match;
325      Regexp      : GNAT.Regpat.Pattern_Matcher;
326      Matched     : out GNAT.Regpat.Match_Array;
327      Timeout     : Integer := 10_000;
328      Full_Buffer : Boolean := False)
329   is
330      N           : Expect_Match;
331      Descriptors : Array_Of_Pd := (1 => Descriptor'Unrestricted_Access);
332      Try_Until   : constant Time := Clock + Duration (Timeout) / 1000.0;
333      Timeout_Tmp : Integer := Timeout;
334
335   begin
336      pragma Assert (Matched'First = 0);
337      Reinitialize_Buffer (Descriptor);
338
339      loop
340         --  First, test if what is already in the buffer matches (This is
341         --  required if this package is used in multi-task mode, since one of
342         --  the tasks might have added something in the buffer, and we don't
343         --  want other tasks to wait for new input to be available before
344         --  checking the regexps).
345
346         Match
347           (Regexp, Descriptor.Buffer (1 .. Descriptor.Buffer_Index), Matched);
348
349         if Descriptor.Buffer_Index >= 1 and then Matched (0).First /= 0 then
350            Result := 1;
351            Descriptor.Last_Match_Start := Matched (0).First;
352            Descriptor.Last_Match_End := Matched (0).Last;
353            return;
354         end if;
355
356         --  Else try to read new input
357
358         Expect_Internal (Descriptors, N, Timeout_Tmp, Full_Buffer);
359
360         case N is
361            when Expect_Internal_Error
362               | Expect_Process_Died
363            =>
364               raise Process_Died;
365
366            when Expect_Full_Buffer
367               | Expect_Timeout
368            =>
369               Result := N;
370               return;
371
372            when others =>
373               null;  --  See below
374         end case;
375
376         --  Calculate the timeout for the next turn
377
378         --  Note that Timeout is, from the caller's perspective, the maximum
379         --  time until a match, not the maximum time until some output is
380         --  read, and thus cannot be reused as is for Expect_Internal.
381
382         if Timeout /= -1 then
383            Timeout_Tmp := Integer (Try_Until - Clock) * 1000;
384
385            if Timeout_Tmp < 0 then
386               Result := Expect_Timeout;
387               exit;
388            end if;
389         end if;
390      end loop;
391
392      --  Even if we had the general timeout above, we have to test that the
393      --  last test we read from the external process didn't match.
394
395      Match
396        (Regexp, Descriptor.Buffer (1 .. Descriptor.Buffer_Index), Matched);
397
398      if Matched (0).First /= 0 then
399         Result := 1;
400         Descriptor.Last_Match_Start := Matched (0).First;
401         Descriptor.Last_Match_End := Matched (0).Last;
402         return;
403      end if;
404   end Expect;
405
406   procedure Expect
407     (Descriptor  : in out Process_Descriptor;
408      Result      : out Expect_Match;
409      Regexps     : Regexp_Array;
410      Timeout     : Integer := 10_000;
411      Full_Buffer : Boolean := False)
412   is
413      Patterns : Compiled_Regexp_Array (Regexps'Range);
414
415      Matched : GNAT.Regpat.Match_Array (0 .. 0);
416      pragma Warnings (Off, Matched);
417
418   begin
419      for J in Regexps'Range loop
420         Patterns (J) := new Pattern_Matcher'(Compile (Regexps (J).all));
421      end loop;
422
423      Expect (Descriptor, Result, Patterns, Matched, Timeout, Full_Buffer);
424
425      for J in Regexps'Range loop
426         Free (Patterns (J));
427      end loop;
428   end Expect;
429
430   procedure Expect
431     (Descriptor  : in out Process_Descriptor;
432      Result      : out Expect_Match;
433      Regexps     : Compiled_Regexp_Array;
434      Timeout     : Integer := 10_000;
435      Full_Buffer : Boolean := False)
436   is
437      Matched : GNAT.Regpat.Match_Array (0 .. 0);
438      pragma Warnings (Off, Matched);
439   begin
440      Expect (Descriptor, Result, Regexps, Matched, Timeout, Full_Buffer);
441   end Expect;
442
443   procedure Expect
444     (Result      : out Expect_Match;
445      Regexps     : Multiprocess_Regexp_Array;
446      Timeout     : Integer := 10_000;
447      Full_Buffer : Boolean := False)
448   is
449      Matched : GNAT.Regpat.Match_Array (0 .. 0);
450      pragma Warnings (Off, Matched);
451   begin
452      Expect (Result, Regexps, Matched, Timeout, Full_Buffer);
453   end Expect;
454
455   procedure Expect
456     (Descriptor  : in out Process_Descriptor;
457      Result      : out Expect_Match;
458      Regexps     : Regexp_Array;
459      Matched     : out GNAT.Regpat.Match_Array;
460      Timeout     : Integer := 10_000;
461      Full_Buffer : Boolean := False)
462   is
463      Patterns : Compiled_Regexp_Array (Regexps'Range);
464
465   begin
466      pragma Assert (Matched'First = 0);
467
468      for J in Regexps'Range loop
469         Patterns (J) := new Pattern_Matcher'(Compile (Regexps (J).all));
470      end loop;
471
472      Expect (Descriptor, Result, Patterns, Matched, Timeout, Full_Buffer);
473
474      for J in Regexps'Range loop
475         Free (Patterns (J));
476      end loop;
477   end Expect;
478
479   procedure Expect
480     (Descriptor  : in out Process_Descriptor;
481      Result      : out Expect_Match;
482      Regexps     : Compiled_Regexp_Array;
483      Matched     : out GNAT.Regpat.Match_Array;
484      Timeout     : Integer := 10_000;
485      Full_Buffer : Boolean := False)
486   is
487      N           : Expect_Match;
488      Descriptors : Array_Of_Pd := (1 => Descriptor'Unrestricted_Access);
489
490   begin
491      pragma Assert (Matched'First = 0);
492
493      Reinitialize_Buffer (Descriptor);
494
495      loop
496         --  First, test if what is already in the buffer matches (This is
497         --  required if this package is used in multi-task mode, since one of
498         --  the tasks might have added something in the buffer, and we don't
499         --  want other tasks to wait for new input to be available before
500         --  checking the regexps).
501
502         if Descriptor.Buffer /= null then
503            for J in Regexps'Range loop
504               Match
505                 (Regexps (J).all,
506                  Descriptor.Buffer (1 .. Descriptor.Buffer_Index),
507                  Matched);
508
509               if Matched (0) /= No_Match then
510                  Result := Expect_Match (J);
511                  Descriptor.Last_Match_Start := Matched (0).First;
512                  Descriptor.Last_Match_End := Matched (0).Last;
513                  return;
514               end if;
515            end loop;
516         end if;
517
518         Expect_Internal (Descriptors, N, Timeout, Full_Buffer);
519
520         case N is
521            when Expect_Internal_Error
522               | Expect_Process_Died
523            =>
524               raise Process_Died;
525
526            when Expect_Full_Buffer
527               | Expect_Timeout
528            =>
529               Result := N;
530               return;
531
532            when others =>
533               null;  --  Continue
534         end case;
535      end loop;
536   end Expect;
537
538   procedure Expect
539     (Result      : out Expect_Match;
540      Regexps     : Multiprocess_Regexp_Array;
541      Matched     : out GNAT.Regpat.Match_Array;
542      Timeout     : Integer := 10_000;
543      Full_Buffer : Boolean := False)
544   is
545      N           : Expect_Match;
546      Descriptors : Array_Of_Pd (Regexps'Range);
547
548   begin
549      pragma Assert (Matched'First = 0);
550
551      for J in Descriptors'Range loop
552         Descriptors (J) := Regexps (J).Descriptor;
553
554         if Descriptors (J) /= null then
555            Reinitialize_Buffer (Regexps (J).Descriptor.all);
556         end if;
557      end loop;
558
559      loop
560         --  First, test if what is already in the buffer matches (This is
561         --  required if this package is used in multi-task mode, since one of
562         --  the tasks might have added something in the buffer, and we don't
563         --  want other tasks to wait for new input to be available before
564         --  checking the regexps).
565
566         for J in Regexps'Range loop
567            if Regexps (J).Regexp /= null
568               and then Regexps (J).Descriptor /= null
569            then
570               Match (Regexps (J).Regexp.all,
571                      Regexps (J).Descriptor.Buffer
572                        (1 .. Regexps (J).Descriptor.Buffer_Index),
573                      Matched);
574
575               if Matched (0) /= No_Match then
576                  Result := Expect_Match (J);
577                  Regexps (J).Descriptor.Last_Match_Start := Matched (0).First;
578                  Regexps (J).Descriptor.Last_Match_End := Matched (0).Last;
579                  return;
580               end if;
581            end if;
582         end loop;
583
584         Expect_Internal (Descriptors, N, Timeout, Full_Buffer);
585
586         case N is
587            when Expect_Internal_Error
588               | Expect_Process_Died
589            =>
590               raise Process_Died;
591
592            when Expect_Full_Buffer
593               | Expect_Timeout
594            =>
595               Result := N;
596               return;
597
598            when others =>
599               null;  --  Continue
600         end case;
601      end loop;
602   end Expect;
603
604   ---------------------
605   -- Expect_Internal --
606   ---------------------
607
608   procedure Expect_Internal
609     (Descriptors : in out Array_Of_Pd;
610      Result      : out Expect_Match;
611      Timeout     : Integer;
612      Full_Buffer : Boolean)
613   is
614      Num_Descriptors : Integer;
615      Buffer_Size     : Integer := 0;
616
617      N : Integer;
618
619      type File_Descriptor_Array is
620        array (0 .. Descriptors'Length - 1) of File_Descriptor;
621      Fds : aliased File_Descriptor_Array;
622      Fds_Count : Natural := 0;
623
624      Fds_To_Descriptor : array (Fds'Range) of Integer;
625      --  Maps file descriptor entries from Fds to entries in Descriptors.
626      --  They do not have the same index when entries in Descriptors are null.
627
628      type Integer_Array is array (Fds'Range) of Integer;
629      Is_Set : aliased Integer_Array;
630
631   begin
632      for J in Descriptors'Range loop
633         if Descriptors (J) /= null then
634            Fds (Fds'First + Fds_Count) := Descriptors (J).Output_Fd;
635            Fds_To_Descriptor (Fds'First + Fds_Count) := J;
636            Fds_Count := Fds_Count + 1;
637
638            if Descriptors (J).Buffer_Size = 0 then
639               Buffer_Size := Integer'Max (Buffer_Size, 4096);
640            else
641               Buffer_Size :=
642                 Integer'Max (Buffer_Size, Descriptors (J).Buffer_Size);
643            end if;
644         end if;
645      end loop;
646
647      declare
648         Buffer : aliased String (1 .. Buffer_Size);
649         --  Buffer used for input. This is allocated only once, not for
650         --  every iteration of the loop
651
652         D : aliased Integer;
653         --  Index in Descriptors
654
655      begin
656         --  Loop until we match or we have a timeout
657
658         loop
659            Num_Descriptors :=
660              Poll (Fds'Address, Fds_Count, Timeout, D'Access, Is_Set'Address);
661
662            case Num_Descriptors is
663
664               --  Error?
665
666               when -1 =>
667                  Result := Expect_Internal_Error;
668
669                  if D /= 0 then
670                     Close (Descriptors (D).Input_Fd);
671                     Descriptors (D).Input_Fd := Invalid_FD;
672                  end if;
673
674                  return;
675
676               --  Timeout?
677
678               when 0  =>
679                  Result := Expect_Timeout;
680                  return;
681
682               --  Some input
683
684               when others =>
685                  for F in Fds'Range loop
686                     if Is_Set (F) = 1 then
687                        D := Fds_To_Descriptor (F);
688
689                        Buffer_Size := Descriptors (D).Buffer_Size;
690
691                        if Buffer_Size = 0 then
692                           Buffer_Size := 4096;
693                        end if;
694
695                        N := Read (Descriptors (D).Output_Fd, Buffer'Address,
696                                   Buffer_Size);
697
698                        --  Error or End of file
699
700                        if N <= 0 then
701                           --  ??? Note that ddd tries again up to three times
702                           --  in that case. See LiterateA.C:174
703
704                           Close (Descriptors (D).Input_Fd);
705                           Descriptors (D).Input_Fd := Invalid_FD;
706                           Result := Expect_Process_Died;
707                           return;
708
709                        else
710                           --  If there is no limit to the buffer size
711
712                           if Descriptors (D).Buffer_Size = 0 then
713                              declare
714                                 Tmp : String_Access := Descriptors (D).Buffer;
715
716                              begin
717                                 if Tmp /= null then
718                                    Descriptors (D).Buffer :=
719                                      new String (1 .. Tmp'Length + N);
720                                    Descriptors (D).Buffer (1 .. Tmp'Length) :=
721                                      Tmp.all;
722                                    Descriptors (D).Buffer
723                                      (Tmp'Length + 1 .. Tmp'Length + N) :=
724                                      Buffer (1 .. N);
725                                    Free (Tmp);
726                                    Descriptors (D).Buffer_Index :=
727                                      Descriptors (D).Buffer'Last;
728
729                                 else
730                                    Descriptors (D).Buffer :=
731                                      new String (1 .. N);
732                                    Descriptors (D).Buffer.all :=
733                                      Buffer (1 .. N);
734                                    Descriptors (D).Buffer_Index := N;
735                                 end if;
736                              end;
737
738                           else
739                              --  Add what we read to the buffer
740
741                              if Descriptors (D).Buffer_Index + N >
742                                   Descriptors (D).Buffer_Size
743                              then
744                                 --  If the user wants to know when we have
745                                 --  read more than the buffer can contain.
746
747                                 if Full_Buffer then
748                                    Result := Expect_Full_Buffer;
749                                    return;
750                                 end if;
751
752                                 --  Keep as much as possible from the buffer,
753                                 --  and forget old characters.
754
755                                 Descriptors (D).Buffer
756                                   (1 .. Descriptors (D).Buffer_Size - N) :=
757                                  Descriptors (D).Buffer
758                                   (N - Descriptors (D).Buffer_Size +
759                                    Descriptors (D).Buffer_Index + 1 ..
760                                    Descriptors (D).Buffer_Index);
761                                 Descriptors (D).Buffer_Index :=
762                                   Descriptors (D).Buffer_Size - N;
763                              end if;
764
765                              --  Keep what we read in the buffer
766
767                              Descriptors (D).Buffer
768                                (Descriptors (D).Buffer_Index + 1 ..
769                                 Descriptors (D).Buffer_Index + N) :=
770                                Buffer (1 .. N);
771                              Descriptors (D).Buffer_Index :=
772                                Descriptors (D).Buffer_Index + N;
773                           end if;
774
775                           --  Call each of the output filter with what we
776                           --  read.
777
778                           Call_Filters
779                             (Descriptors (D).all, Buffer (1 .. N), Output);
780
781                           Result := Expect_Match (D);
782                           return;
783                        end if;
784                     end if;
785                  end loop;
786            end case;
787         end loop;
788      end;
789   end Expect_Internal;
790
791   ----------------
792   -- Expect_Out --
793   ----------------
794
795   function Expect_Out (Descriptor : Process_Descriptor) return String is
796   begin
797      return Descriptor.Buffer (1 .. Descriptor.Last_Match_End);
798   end Expect_Out;
799
800   ----------------------
801   -- Expect_Out_Match --
802   ----------------------
803
804   function Expect_Out_Match (Descriptor : Process_Descriptor) return String is
805   begin
806      return Descriptor.Buffer
807        (Descriptor.Last_Match_Start .. Descriptor.Last_Match_End);
808   end Expect_Out_Match;
809
810   ------------------------
811   -- First_Dead_Process --
812   ------------------------
813
814   function First_Dead_Process
815     (Regexp : Multiprocess_Regexp_Array) return Natural is
816   begin
817      for R in Regexp'Range loop
818         if Regexp (R).Descriptor /= null
819           and then Regexp (R).Descriptor.Input_Fd = GNAT.OS_Lib.Invalid_FD
820         then
821            return R;
822         end if;
823      end loop;
824
825      return 0;
826   end First_Dead_Process;
827
828   -----------
829   -- Flush --
830   -----------
831
832   procedure Flush
833     (Descriptor : in out Process_Descriptor;
834      Timeout    : Integer := 0)
835   is
836      Buffer_Size     : constant Integer := 8192;
837      Num_Descriptors : Integer;
838      N               : aliased Integer;
839      Is_Set          : aliased Integer;
840      Buffer          : aliased String (1 .. Buffer_Size);
841
842   begin
843      --  Empty the current buffer
844
845      Descriptor.Last_Match_End := Descriptor.Buffer_Index;
846      Reinitialize_Buffer (Descriptor);
847
848      --  Read everything from the process to flush its output
849
850      loop
851         Num_Descriptors :=
852           Poll (Descriptor.Output_Fd'Address,
853                 1,
854                 Timeout,
855                 N'Access,
856                 Is_Set'Address);
857
858         case Num_Descriptors is
859
860            --  Error ?
861
862            when -1 =>
863               raise Process_Died;
864
865            --  Timeout => End of flush
866
867            when 0  =>
868               return;
869
870            --  Some input
871
872            when others =>
873               if Is_Set = 1 then
874                  N := Read (Descriptor.Output_Fd, Buffer'Address,
875                             Buffer_Size);
876
877                  if N = -1 then
878                     raise Process_Died;
879                  elsif N = 0 then
880                     return;
881                  end if;
882               end if;
883         end case;
884      end loop;
885   end Flush;
886
887   ----------
888   -- Free --
889   ----------
890
891   procedure Free (Regexp : in out Multiprocess_Regexp) is
892      procedure Unchecked_Free is new Ada.Unchecked_Deallocation
893        (Process_Descriptor'Class, Process_Descriptor_Access);
894   begin
895      Unchecked_Free (Regexp.Descriptor);
896      Free (Regexp.Regexp);
897   end Free;
898
899   ------------------------
900   -- Get_Command_Output --
901   ------------------------
902
903   function Get_Command_Output
904     (Command    : String;
905      Arguments  : GNAT.OS_Lib.Argument_List;
906      Input      : String;
907      Status     : not null access Integer;
908      Err_To_Out : Boolean := False) return String
909   is
910      Process : Process_Descriptor;
911
912      Output : String_Access := new String (1 .. 1024);
913      --  Buffer used to accumulate standard output from the launched
914      --  command, expanded as necessary during execution.
915
916      Last : Integer := 0;
917      --  Index of the last used character within Output
918
919   begin
920      Non_Blocking_Spawn
921        (Process, Command, Arguments, Err_To_Out => Err_To_Out,
922         Buffer_Size => 0);
923
924      if Input'Length > 0 then
925         Send (Process, Input);
926      end if;
927
928      Close (Process.Input_Fd);
929      Process.Input_Fd := Invalid_FD;
930
931      declare
932         Result : Expect_Match;
933         pragma Unreferenced (Result);
934
935      begin
936         --  This loop runs until the call to Expect raises Process_Died
937
938         loop
939            Expect (Process, Result, ".+", Timeout => -1);
940
941            declare
942               NOutput : String_Access;
943               S       : constant String := Expect_Out (Process);
944               pragma Assert (S'Length > 0);
945
946            begin
947               --  Expand buffer if we need more space. Note here that we add
948               --  S'Length to ensure that S will fit in the new buffer size.
949
950               if Last + S'Length > Output'Last then
951                  NOutput := new String (1 .. 2 * Output'Last + S'Length);
952                  NOutput (Output'Range) := Output.all;
953                  Free (Output);
954
955               --  Here if current buffer size is OK
956
957               else
958                  NOutput := Output;
959               end if;
960
961               NOutput (Last + 1 .. Last + S'Length) := S;
962               Last := Last + S'Length;
963               Output := NOutput;
964            end;
965         end loop;
966
967      exception
968         when Process_Died =>
969            Close (Process, Status.all);
970      end;
971
972      if Last = 0 then
973         Free (Output);
974         return "";
975      end if;
976
977      declare
978         S : constant String := Output (1 .. Last);
979      begin
980         Free (Output);
981         return S;
982      end;
983   end Get_Command_Output;
984
985   ------------------
986   -- Get_Error_Fd --
987   ------------------
988
989   function Get_Error_Fd
990     (Descriptor : Process_Descriptor) return GNAT.OS_Lib.File_Descriptor
991   is
992   begin
993      return Descriptor.Error_Fd;
994   end Get_Error_Fd;
995
996   ------------------
997   -- Get_Input_Fd --
998   ------------------
999
1000   function Get_Input_Fd
1001     (Descriptor : Process_Descriptor) return GNAT.OS_Lib.File_Descriptor
1002   is
1003   begin
1004      return Descriptor.Input_Fd;
1005   end Get_Input_Fd;
1006
1007   -------------------
1008   -- Get_Output_Fd --
1009   -------------------
1010
1011   function Get_Output_Fd
1012     (Descriptor : Process_Descriptor) return GNAT.OS_Lib.File_Descriptor
1013   is
1014   begin
1015      return Descriptor.Output_Fd;
1016   end Get_Output_Fd;
1017
1018   -------------
1019   -- Get_Pid --
1020   -------------
1021
1022   function Get_Pid
1023     (Descriptor : Process_Descriptor) return Process_Id
1024   is
1025   begin
1026      return Descriptor.Pid;
1027   end Get_Pid;
1028
1029   -----------------
1030   -- Has_Process --
1031   -----------------
1032
1033   function Has_Process (Regexp : Multiprocess_Regexp_Array) return Boolean is
1034   begin
1035      return Regexp /= (Regexp'Range => (null, null));
1036   end Has_Process;
1037
1038   ---------------
1039   -- Interrupt --
1040   ---------------
1041
1042   procedure Interrupt (Descriptor : in out Process_Descriptor) is
1043      SIGINT : constant := 2;
1044   begin
1045      Send_Signal (Descriptor, SIGINT);
1046   end Interrupt;
1047
1048   ------------------
1049   -- Lock_Filters --
1050   ------------------
1051
1052   procedure Lock_Filters (Descriptor : in out Process_Descriptor) is
1053   begin
1054      Descriptor.Filters_Lock := Descriptor.Filters_Lock + 1;
1055   end Lock_Filters;
1056
1057   ------------------------
1058   -- Non_Blocking_Spawn --
1059   ------------------------
1060
1061   procedure Non_Blocking_Spawn
1062     (Descriptor  : out Process_Descriptor'Class;
1063      Command     : String;
1064      Args        : GNAT.OS_Lib.Argument_List;
1065      Buffer_Size : Natural := 4096;
1066      Err_To_Out  : Boolean := False)
1067   is
1068      function Fork return Process_Id;
1069      pragma Import (C, Fork, "__gnat_expect_fork");
1070      --  Starts a new process if possible. See the Unix command fork for more
1071      --  information. On systems that do not support this capability (such as
1072      --  Windows...), this command does nothing, and Fork will return
1073      --  Null_Pid.
1074
1075      Pipe1, Pipe2, Pipe3 : aliased Pipe_Type;
1076
1077      Arg        : String_Access;
1078      Arg_List   : String_List (1 .. Args'Length + 2);
1079      C_Arg_List : aliased array (1 .. Args'Length + 2) of System.Address;
1080
1081      Command_With_Path : String_Access;
1082
1083   begin
1084      Command_With_Path := Locate_Exec_On_Path (Command);
1085
1086      if Command_With_Path = null then
1087         raise Invalid_Process;
1088      end if;
1089
1090      --  Create the rest of the pipes once we know we will be able to
1091      --  execute the process.
1092
1093      Set_Up_Communications
1094        (Descriptor, Err_To_Out, Pipe1'Access, Pipe2'Access, Pipe3'Access);
1095
1096      --  Fork a new process
1097
1098      Descriptor.Pid := Fork;
1099
1100      --  Are we now in the child (or, for Windows, still in the common
1101      --  process).
1102
1103      if Descriptor.Pid = Null_Pid then
1104         --  Prepare an array of arguments to pass to C
1105
1106         Arg := new String (1 .. Command_With_Path'Length + 1);
1107         Arg (1 .. Command_With_Path'Length) := Command_With_Path.all;
1108         Arg (Arg'Last)        := ASCII.NUL;
1109         Arg_List (1)          := Arg;
1110
1111         for J in Args'Range loop
1112            Arg                     := new String (1 .. Args (J)'Length + 1);
1113            Arg (1 .. Args (J)'Length)    := Args (J).all;
1114            Arg (Arg'Last)                := ASCII.NUL;
1115            Arg_List (J + 2 - Args'First) := Arg.all'Access;
1116         end loop;
1117
1118         Arg_List (Arg_List'Last) := null;
1119
1120         --  Make sure all arguments are compatible with OS conventions
1121
1122         Normalize_Arguments (Arg_List);
1123
1124         --  Prepare low-level argument list from the normalized arguments
1125
1126         for K in Arg_List'Range loop
1127            C_Arg_List (K) :=
1128              (if Arg_List (K) /= null
1129               then Arg_List (K).all'Address
1130               else System.Null_Address);
1131         end loop;
1132
1133         --  This does not return on Unix systems
1134
1135         Set_Up_Child_Communications
1136           (Descriptor, Pipe1, Pipe2, Pipe3, Command_With_Path.all,
1137            C_Arg_List'Address);
1138      end if;
1139
1140      Free (Command_With_Path);
1141
1142      --  Did we have an error when spawning the child ?
1143
1144      if Descriptor.Pid < Null_Pid then
1145         raise Invalid_Process;
1146      else
1147         --  We are now in the parent process
1148
1149         Set_Up_Parent_Communications (Descriptor, Pipe1, Pipe2, Pipe3);
1150      end if;
1151
1152      --  Create the buffer
1153
1154      Descriptor.Buffer_Size := Buffer_Size;
1155
1156      if Buffer_Size /= 0 then
1157         Descriptor.Buffer := new String (1 .. Positive (Buffer_Size));
1158      end if;
1159
1160      --  Initialize the filters
1161
1162      Descriptor.Filters := null;
1163   end Non_Blocking_Spawn;
1164
1165   -------------------------
1166   -- Reinitialize_Buffer --
1167   -------------------------
1168
1169   procedure Reinitialize_Buffer
1170     (Descriptor : in out Process_Descriptor'Class)
1171   is
1172   begin
1173      if Descriptor.Buffer_Size = 0 then
1174         declare
1175            Tmp : String_Access := Descriptor.Buffer;
1176
1177         begin
1178            Descriptor.Buffer :=
1179              new String
1180                (1 .. Descriptor.Buffer_Index - Descriptor.Last_Match_End);
1181
1182            if Tmp /= null then
1183               Descriptor.Buffer.all := Tmp
1184                 (Descriptor.Last_Match_End + 1 .. Descriptor.Buffer_Index);
1185               Free (Tmp);
1186            end if;
1187         end;
1188
1189         Descriptor.Buffer_Index := Descriptor.Buffer'Last;
1190
1191      else
1192         Descriptor.Buffer
1193           (1 .. Descriptor.Buffer_Index - Descriptor.Last_Match_End) :=
1194             Descriptor.Buffer
1195               (Descriptor.Last_Match_End + 1 .. Descriptor.Buffer_Index);
1196
1197         if Descriptor.Buffer_Index > Descriptor.Last_Match_End then
1198            Descriptor.Buffer_Index :=
1199              Descriptor.Buffer_Index - Descriptor.Last_Match_End;
1200         else
1201            Descriptor.Buffer_Index := 0;
1202         end if;
1203      end if;
1204
1205      Descriptor.Last_Match_Start := 0;
1206      Descriptor.Last_Match_End := 0;
1207   end Reinitialize_Buffer;
1208
1209   -------------------
1210   -- Remove_Filter --
1211   -------------------
1212
1213   procedure Remove_Filter
1214     (Descriptor : in out Process_Descriptor;
1215      Filter     : Filter_Function)
1216   is
1217      Previous : Filter_List := null;
1218      Current  : Filter_List := Descriptor.Filters;
1219
1220   begin
1221      while Current /= null loop
1222         if Current.Filter = Filter then
1223            if Previous = null then
1224               Descriptor.Filters := Current.Next;
1225            else
1226               Previous.Next := Current.Next;
1227            end if;
1228         end if;
1229
1230         Previous := Current;
1231         Current := Current.Next;
1232      end loop;
1233   end Remove_Filter;
1234
1235   ----------
1236   -- Send --
1237   ----------
1238
1239   procedure Send
1240     (Descriptor   : in out Process_Descriptor;
1241      Str          : String;
1242      Add_LF       : Boolean := True;
1243      Empty_Buffer : Boolean := False)
1244   is
1245      Line_Feed   : aliased constant String := (1 .. 1 => ASCII.LF);
1246      Descriptors : Array_Of_Pd := (1 => Descriptor'Unrestricted_Access);
1247
1248      Result  : Expect_Match;
1249      Discard : Natural;
1250      pragma Warnings (Off, Result);
1251      pragma Warnings (Off, Discard);
1252
1253   begin
1254      if Empty_Buffer then
1255
1256         --  Force a read on the process if there is anything waiting
1257
1258         Expect_Internal
1259           (Descriptors, Result, Timeout => 0, Full_Buffer => False);
1260
1261         if Result = Expect_Internal_Error
1262           or else Result = Expect_Process_Died
1263         then
1264            raise Process_Died;
1265         end if;
1266
1267         Descriptor.Last_Match_End := Descriptor.Buffer_Index;
1268
1269         --  Empty the buffer
1270
1271         Reinitialize_Buffer (Descriptor);
1272      end if;
1273
1274      Call_Filters (Descriptor, Str, Input);
1275      Discard :=
1276        Write (Descriptor.Input_Fd, Str'Address, Str'Last - Str'First + 1);
1277
1278      if Add_LF then
1279         Call_Filters (Descriptor, Line_Feed, Input);
1280         Discard :=
1281           Write (Descriptor.Input_Fd, Line_Feed'Address, 1);
1282      end if;
1283   end Send;
1284
1285   -----------------
1286   -- Send_Signal --
1287   -----------------
1288
1289   procedure Send_Signal
1290     (Descriptor : Process_Descriptor;
1291      Signal     : Integer)
1292   is
1293   begin
1294      --  A nonpositive process id passed to kill has special meanings. For
1295      --  example, -1 means kill all processes in sight, including self, in
1296      --  POSIX and Windows (and something slightly different in Linux). See
1297      --  man pages for details. In any case, we don't want to do that. Note
1298      --  that Descriptor.Pid will be -1 if the process was not successfully
1299      --  started; we don't want to kill ourself in that case.
1300
1301      if Descriptor.Pid > 0 then
1302         Kill (Descriptor.Pid, Signal, Close => 1);
1303         --  ??? Need to check process status here
1304      else
1305         raise Invalid_Process;
1306      end if;
1307   end Send_Signal;
1308
1309   ---------------------------------
1310   -- Set_Up_Child_Communications --
1311   ---------------------------------
1312
1313   procedure Set_Up_Child_Communications
1314     (Pid   : in out Process_Descriptor;
1315      Pipe1 : in out Pipe_Type;
1316      Pipe2 : in out Pipe_Type;
1317      Pipe3 : in out Pipe_Type;
1318      Cmd   : String;
1319      Args  : System.Address)
1320   is
1321      pragma Warnings (Off, Pid);
1322      pragma Warnings (Off, Pipe1);
1323      pragma Warnings (Off, Pipe2);
1324      pragma Warnings (Off, Pipe3);
1325
1326      Input  : File_Descriptor;
1327      Output : File_Descriptor;
1328      Error  : File_Descriptor;
1329
1330      No_Fork_On_Target : constant Boolean := Target_OS = Windows;
1331
1332   begin
1333      if No_Fork_On_Target then
1334
1335         --  Since Windows does not have a separate fork/exec, we need to
1336         --  perform the following actions:
1337
1338         --    - save stdin, stdout, stderr
1339         --    - replace them by our pipes
1340         --    - create the child with process handle inheritance
1341         --    - revert to the previous stdin, stdout and stderr.
1342
1343         Input  := Dup (GNAT.OS_Lib.Standin);
1344         Output := Dup (GNAT.OS_Lib.Standout);
1345         Error  := Dup (GNAT.OS_Lib.Standerr);
1346      end if;
1347
1348      --  Since we are still called from the parent process, there is no way
1349      --  currently we can cleanly close the unneeded ends of the pipes, but
1350      --  this doesn't really matter.
1351
1352      --  We could close Pipe1.Output, Pipe2.Input, Pipe3.Input
1353
1354      Dup2 (Pipe1.Input,  GNAT.OS_Lib.Standin);
1355      Dup2 (Pipe2.Output, GNAT.OS_Lib.Standout);
1356      Dup2 (Pipe3.Output, GNAT.OS_Lib.Standerr);
1357
1358      Portable_Execvp (Pid.Pid'Access, Cmd & ASCII.NUL, Args);
1359
1360      --  The following lines are only required for Windows systems and will
1361      --  not be executed on Unix systems, but we use the same condition as
1362      --  above to avoid warnings on uninitialized variables on Unix systems.
1363      --  We are now in the parent process.
1364
1365      if No_Fork_On_Target then
1366
1367         --  Restore the old descriptors
1368
1369         Dup2 (Input,  GNAT.OS_Lib.Standin);
1370         Dup2 (Output, GNAT.OS_Lib.Standout);
1371         Dup2 (Error,  GNAT.OS_Lib.Standerr);
1372         Close (Input);
1373         Close (Output);
1374         Close (Error);
1375      end if;
1376   end Set_Up_Child_Communications;
1377
1378   ---------------------------
1379   -- Set_Up_Communications --
1380   ---------------------------
1381
1382   procedure Set_Up_Communications
1383     (Pid        : in out Process_Descriptor;
1384      Err_To_Out : Boolean;
1385      Pipe1      : not null access Pipe_Type;
1386      Pipe2      : not null access Pipe_Type;
1387      Pipe3      : not null access Pipe_Type)
1388   is
1389      Status : Boolean;
1390      pragma Unreferenced (Status);
1391
1392   begin
1393      --  Create the pipes
1394
1395      if Create_Pipe (Pipe1) /= 0 then
1396         return;
1397      end if;
1398
1399      if Create_Pipe (Pipe2) /= 0 then
1400         Close (Pipe1.Input);
1401         Close (Pipe1.Output);
1402         return;
1403      end if;
1404
1405      --  Record the 'parent' end of the two pipes in Pid:
1406      --    Child stdin  is connected to the 'write' end of Pipe1;
1407      --    Child stdout is connected to the 'read'  end of Pipe2.
1408      --  We do not want these descriptors to remain open in the child
1409      --  process, so we mark them close-on-exec/non-inheritable.
1410
1411      Pid.Input_Fd  := Pipe1.Output;
1412      Set_Close_On_Exec (Pipe1.Output, True, Status);
1413      Pid.Output_Fd := Pipe2.Input;
1414      Set_Close_On_Exec (Pipe2.Input, True, Status);
1415
1416      if Err_To_Out then
1417
1418         --  Reuse the standard output pipe for standard error
1419
1420         Pipe3.all := Pipe2.all;
1421
1422      else
1423         --  Create a separate pipe for standard error
1424
1425         if Create_Pipe (Pipe3) /= 0 then
1426            Pipe3.all := Pipe2.all;
1427         end if;
1428      end if;
1429
1430      --  As above, record the proper fd for the child's standard error stream
1431
1432      Pid.Error_Fd := Pipe3.Input;
1433      Set_Close_On_Exec (Pipe3.Input, True, Status);
1434   end Set_Up_Communications;
1435
1436   ----------------------------------
1437   -- Set_Up_Parent_Communications --
1438   ----------------------------------
1439
1440   procedure Set_Up_Parent_Communications
1441     (Pid   : in out Process_Descriptor;
1442      Pipe1 : in out Pipe_Type;
1443      Pipe2 : in out Pipe_Type;
1444      Pipe3 : in out Pipe_Type)
1445   is
1446      pragma Warnings (Off, Pid);
1447      pragma Warnings (Off, Pipe1);
1448      pragma Warnings (Off, Pipe2);
1449      pragma Warnings (Off, Pipe3);
1450
1451   begin
1452      Close (Pipe1.Input);
1453      Close (Pipe2.Output);
1454
1455      if Pipe3.Output /= Pipe2.Output then
1456         Close (Pipe3.Output);
1457      end if;
1458   end Set_Up_Parent_Communications;
1459
1460   ------------------
1461   -- Trace_Filter --
1462   ------------------
1463
1464   procedure Trace_Filter
1465     (Descriptor : Process_Descriptor'Class;
1466      Str        : String;
1467      User_Data  : System.Address := System.Null_Address)
1468   is
1469      pragma Warnings (Off, Descriptor);
1470      pragma Warnings (Off, User_Data);
1471   begin
1472      GNAT.IO.Put (Str);
1473   end Trace_Filter;
1474
1475   --------------------
1476   -- Unlock_Filters --
1477   --------------------
1478
1479   procedure Unlock_Filters (Descriptor : in out Process_Descriptor) is
1480   begin
1481      if Descriptor.Filters_Lock > 0 then
1482         Descriptor.Filters_Lock := Descriptor.Filters_Lock - 1;
1483      end if;
1484   end Unlock_Filters;
1485
1486end GNAT.Expect;
1487