gcc/ada/g-expect.adb

   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 --                                                                          --
  10 --           Copyright (C) 2000-2002 Ada Core Technologies, Inc.            --
  11 --                                                                          --
  12 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  13 -- terms of the  GNU General Public License as published  by the Free Soft- --
  14 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  15 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  16 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  17 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  18 -- for  more details.  You should have  received  a copy of the GNU General --
  19 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  20 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  21 -- MA 02111-1307, USA.                                                      --
  22 --                                                                          --
  23 -- As a special exception,  if other files  instantiate  generics from this --
  24 -- unit, or you link  this unit with other files  to produce an executable, --
  25 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  26 -- covered  by the  GNU  General  Public  License.  This exception does not --
  27 -- however invalidate  any other reasons why  the executable file  might be --
  28 -- covered by the  GNU Public License.                                      --
  29 --                                                                          --
  30 -- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com).   --
  31 --                                                                          --
  32 ------------------------------------------------------------------------------
  33
  34 with System;        use System;
  35 with Ada.Calendar;  use Ada.Calendar;
  36
  37 with GNAT.IO;
  38 with GNAT.OS_Lib;   use GNAT.OS_Lib;
  39 with GNAT.Regpat;   use GNAT.Regpat;
  40
  41 with Unchecked_Deallocation;
  42
  43 package body GNAT.Expect is
  44
  45    type Array_Of_Pd is array (Positive range <>) of Process_Descriptor_Access;
  46
  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.
  53    --
  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.
  63
  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.
  68
  69    procedure Free is new Unchecked_Deallocation
  70      (Pattern_Matcher, Pattern_Matcher_Access);
  71
  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
  78
  79    ------------------------------
  80    -- Target dependent section --
  81    ------------------------------
  82
  83    function Dup (Fd : File_Descriptor) return File_Descriptor;
  84    pragma Import (C, Dup);
  85
  86    procedure Dup2 (Old_Fd, New_Fd : File_Descriptor);
  87    pragma Import (C, Dup2);
  88
  89    procedure Kill (Pid : Process_Id; Sig_Num : Integer);
  90    pragma Import (C, Kill);
  91
  92    function Create_Pipe (Pipe : access Pipe_Type) return Integer;
  93    pragma Import (C, Create_Pipe, "__gnat_pipe");
  94
  95    function Read
  96      (Fd   : File_Descriptor;
  97       A    : System.Address;
  98       N    : Integer)
  99       return Integer;
 100    pragma Import (C, Read, "read");
 101    --  Read N bytes to address A from file referenced by FD. Returned value
 102    --  is count of bytes actually read, which can be less than N at EOF.
 103
 104    procedure Close (Fd : File_Descriptor);
 105    pragma Import (C, Close);
 106    --  Close a file given its file descriptor.
 107
 108    function Write
 109      (Fd   : File_Descriptor;
 110       A    : System.Address;
 111       N    : Integer)
 112       return Integer;
 113    pragma Import (C, Write, "write");
 114    --  Read N bytes to address A from file referenced by FD. Returned value
 115    --  is count of bytes actually read, which can be less than N at EOF.
 116
 117    function Poll
 118      (Fds     : System.Address;
 119       Num_Fds : Integer;
 120       Timeout : Integer;
 121       Is_Set  : System.Address) return Integer;
 122    pragma Import (C, Poll, "__gnat_expect_poll");
 123    --  Check whether there is any data waiting on the file descriptor
 124    --  Out_fd, and wait if there is none, at most Timeout milliseconds
 125    --  Returns -1 in case of error, 0 if the timeout expired before
 126    --  data became available.
 127    --
 128    --  Out_Is_Set is set to 1 if data was available, 0 otherwise.
 129
 130    function Waitpid (Pid : Process_Id) return Integer;
 131    pragma Import (C, Waitpid, "__gnat_waitpid");
 132    --  Wait for a specific process id, and return its exit code.
 133
 134    ---------
 135    -- "+" --
 136    ---------
 137
 138    function "+" (S : String) return GNAT.OS_Lib.String_Access is
 139    begin
 140       return new String'(S);
 141    end "+";
 142
 143    ---------
 144    -- "+" --
 145    ---------
 146
 147    function "+"
 148      (P    : GNAT.Regpat.Pattern_Matcher)
 149       return Pattern_Matcher_Access
 150    is
 151    begin
 152       return new GNAT.Regpat.Pattern_Matcher'(P);
 153    end "+";
 154
 155    ----------------
 156    -- Add_Filter --
 157    ----------------
 158
 159    procedure Add_Filter
 160      (Descriptor : in out Process_Descriptor;
 161       Filter     : Filter_Function;
 162       Filter_On  : Filter_Type := Output;
 163       User_Data  : System.Address := System.Null_Address;
 164       After      : Boolean := False)
 165    is
 166       Current : Filter_List := Descriptor.Filters;
 167
 168    begin
 169       if After then
 170          while Current /= null and then Current.Next /= null loop
 171             Current := Current.Next;
 172          end loop;
 173
 174          if Current = null then
 175             Descriptor.Filters :=
 176               new Filter_List_Elem'
 177                (Filter => Filter, Filter_On => Filter_On,
 178                 User_Data => User_Data, Next => null);
 179          else
 180             Current.Next :=
 181               new Filter_List_Elem'
 182               (Filter => Filter, Filter_On => Filter_On,
 183                User_Data => User_Data, Next => null);
 184          end if;
 185
 186       else
 187          Descriptor.Filters :=
 188            new Filter_List_Elem'
 189              (Filter => Filter, Filter_On => Filter_On,
 190               User_Data => User_Data, Next => Descriptor.Filters);
 191       end if;
 192    end Add_Filter;
 193
 194    ------------------
 195    -- Call_Filters --
 196    ------------------
 197
 198    procedure Call_Filters
 199      (Pid       : Process_Descriptor'Class;
 200       Str       : String;
 201       Filter_On : Filter_Type)
 202    is
 203       Current_Filter  : Filter_List;
 204
 205    begin
 206       if Pid.Filters_Lock = 0 then
 207          Current_Filter := Pid.Filters;
 208
 209          while Current_Filter /= null loop
 210             if Current_Filter.Filter_On = Filter_On then
 211                Current_Filter.Filter
 212                  (Pid, Str, Current_Filter.User_Data);
 213             end if;
 214
 215             Current_Filter := Current_Filter.Next;
 216          end loop;
 217       end if;
 218    end Call_Filters;
 219
 220    -----------
 221    -- Close --
 222    -----------
 223
 224    procedure Close
 225      (Descriptor : in out Process_Descriptor;
 226       Status     : out Integer)
 227    is
 228    begin
 229       Close (Descriptor.Input_Fd);
 230
 231       if Descriptor.Error_Fd /= Descriptor.Output_Fd then
 232          Close (Descriptor.Error_Fd);
 233       end if;
 234
 235       Close (Descriptor.Output_Fd);
 236
 237       --  ??? Should have timeouts for different signals
 238       Kill (Descriptor.Pid, 9);
 239
 240       GNAT.OS_Lib.Free (Descriptor.Buffer);
 241       Descriptor.Buffer_Size := 0;
 242
 243       Status := Waitpid (Descriptor.Pid);
 244    end Close;
 245
 246    procedure Close (Descriptor : in out Process_Descriptor) is
 247       Status : Integer;
 248    begin
 249       Close (Descriptor, Status);
 250    end Close;
 251
 252    ------------
 253    -- Expect --
 254    ------------
 255
 256    procedure Expect
 257      (Descriptor  : in out Process_Descriptor;
 258       Result      : out Expect_Match;
 259       Regexp      : String;
 260       Timeout     : Integer := 10000;
 261       Full_Buffer : Boolean := False)
 262    is
 263    begin
 264       if Regexp = "" then
 265          Expect (Descriptor, Result, Never_Match, Timeout, Full_Buffer);
 266       else
 267          Expect (Descriptor, Result, Compile (Regexp), Timeout, Full_Buffer);
 268       end if;
 269    end Expect;
 270
 271    procedure Expect
 272      (Descriptor  : in out Process_Descriptor;
 273       Result      : out Expect_Match;
 274       Regexp      : String;
 275       Matched     : out GNAT.Regpat.Match_Array;
 276       Timeout     : Integer := 10000;
 277       Full_Buffer : Boolean := False)
 278    is
 279    begin
 280       pragma Assert (Matched'First = 0);
 281       if Regexp = "" then
 282          Expect
 283            (Descriptor, Result, Never_Match, Matched, Timeout, Full_Buffer);
 284       else
 285          Expect
 286            (Descriptor, Result, Compile (Regexp), Matched, Timeout,
 287             Full_Buffer);
 288       end if;
 289    end Expect;
 290
 291    procedure Expect
 292      (Descriptor  : in out Process_Descriptor;
 293       Result      : out Expect_Match;
 294       Regexp      : GNAT.Regpat.Pattern_Matcher;
 295       Timeout     : Integer := 10000;
 296       Full_Buffer : Boolean := False)
 297    is
 298       Matched : GNAT.Regpat.Match_Array (0 .. 0);
 299
 300    begin
 301       Expect (Descriptor, Result, Regexp, Matched, Timeout, Full_Buffer);
 302    end Expect;
 303
 304    procedure Expect
 305      (Descriptor  : in out Process_Descriptor;
 306       Result      : out Expect_Match;
 307       Regexp      : GNAT.Regpat.Pattern_Matcher;
 308       Matched     : out GNAT.Regpat.Match_Array;
 309       Timeout     : Integer := 10000;
 310       Full_Buffer : Boolean := False)
 311    is
 312       N           : Expect_Match;
 313       Descriptors : Array_Of_Pd := (1 => Descriptor'Unrestricted_Access);
 314       Try_Until   : Time := Clock + Duration (Timeout) / 1000.0;
 315       Timeout_Tmp : Integer := Timeout;
 316
 317    begin
 318       pragma Assert (Matched'First = 0);
 319       Reinitialize_Buffer (Descriptor);
 320
 321       loop
 322          --  First, test if what is already in the buffer matches (This is
 323          --  required if this package is used in multi-task mode, since one of
 324          --  the tasks might have added something in the buffer, and we don't
 325          --  want other tasks to wait for new input to be available before
 326          --  checking the regexps).
 327
 328          Match
 329            (Regexp, Descriptor.Buffer (1 .. Descriptor.Buffer_Index), Matched);
 330
 331          if Descriptor.Buffer_Index >= 1 and then Matched (0).First /= 0 then
 332             Result := 1;
 333             Descriptor.Last_Match_Start := Matched (0).First;
 334             Descriptor.Last_Match_End := Matched (0).Last;
 335             return;
 336          end if;
 337
 338          --  Else try to read new input
 339
 340          Expect_Internal (Descriptors, N, Timeout_Tmp, Full_Buffer);
 341
 342          if N = Expect_Timeout or else N = Expect_Full_Buffer then
 343             Result := N;
 344             return;
 345          end if;
 346
 347          --  Calculate the timeout for the next turn.
 348          --  Note that Timeout is, from the caller's perspective, the maximum
 349          --  time until a match, not the maximum time until some output is
 350          --  read, and thus can not be reused as is for Expect_Internal.
 351
 352          if Timeout /= -1 then
 353             Timeout_Tmp := Integer (Try_Until - Clock) * 1000;
 354
 355             if Timeout_Tmp < 0 then
 356                Result := Expect_Timeout;
 357                exit;
 358             end if;
 359          end if;
 360       end loop;
 361
 362       --  Even if we had the general timeout above, we have to test that the
 363       --  last test we read from the external process didn't match.
 364
 365       Match
 366         (Regexp, Descriptor.Buffer (1 .. Descriptor.Buffer_Index), Matched);
 367
 368       if Matched (0).First /= 0 then
 369          Result := 1;
 370          Descriptor.Last_Match_Start := Matched (0).First;
 371          Descriptor.Last_Match_End := Matched (0).Last;
 372          return;
 373       end if;
 374    end Expect;
 375
 376    procedure Expect
 377      (Descriptor  : in out Process_Descriptor;
 378       Result      : out Expect_Match;
 379       Regexps     : Regexp_Array;
 380       Timeout     : Integer := 10000;
 381       Full_Buffer : Boolean := False)
 382    is
 383       Patterns : Compiled_Regexp_Array (Regexps'Range);
 384       Matched  : GNAT.Regpat.Match_Array (0 .. 0);
 385
 386    begin
 387       for J in Regexps'Range loop
 388          Patterns (J) := new Pattern_Matcher'(Compile (Regexps (J).all));
 389       end loop;
 390
 391       Expect (Descriptor, Result, Patterns, Matched, Timeout, Full_Buffer);
 392
 393       for J in Regexps'Range loop
 394          Free (Patterns (J));
 395       end loop;
 396    end Expect;
 397
 398    procedure Expect
 399      (Descriptor  : in out Process_Descriptor;
 400       Result      : out Expect_Match;
 401       Regexps     : Compiled_Regexp_Array;
 402       Timeout     : Integer := 10000;
 403       Full_Buffer : Boolean := False)
 404    is
 405       Matched : GNAT.Regpat.Match_Array (0 .. 0);
 406
 407    begin
 408       Expect (Descriptor, Result, Regexps, Matched, Timeout, Full_Buffer);
 409    end Expect;
 410
 411    procedure Expect
 412      (Result      : out Expect_Match;
 413       Regexps     : Multiprocess_Regexp_Array;
 414       Timeout     : Integer := 10000;
 415       Full_Buffer : Boolean := False)
 416    is
 417       Matched : GNAT.Regpat.Match_Array (0 .. 0);
 418
 419    begin
 420       Expect (Result, Regexps, Matched, Timeout, Full_Buffer);
 421    end Expect;
 422
 423    procedure Expect
 424      (Descriptor  : in out Process_Descriptor;
 425       Result      : out Expect_Match;
 426       Regexps     : Regexp_Array;
 427       Matched     : out GNAT.Regpat.Match_Array;
 428       Timeout     : Integer := 10000;
 429       Full_Buffer : Boolean := False)
 430    is
 431       Patterns : Compiled_Regexp_Array (Regexps'Range);
 432
 433    begin
 434       pragma Assert (Matched'First = 0);
 435
 436       for J in Regexps'Range loop
 437          Patterns (J) := new Pattern_Matcher'(Compile (Regexps (J).all));
 438       end loop;
 439
 440       Expect (Descriptor, Result, Patterns, Matched, Timeout, Full_Buffer);
 441
 442       for J in Regexps'Range loop
 443          Free (Patterns (J));
 444       end loop;
 445    end Expect;
 446
 447    procedure Expect
 448      (Descriptor  : in out Process_Descriptor;
 449       Result      : out Expect_Match;
 450       Regexps     : Compiled_Regexp_Array;
 451       Matched     : out GNAT.Regpat.Match_Array;
 452       Timeout     : Integer := 10000;
 453       Full_Buffer : Boolean := False)
 454    is
 455       N           : Expect_Match;
 456       Descriptors : Array_Of_Pd := (1 => Descriptor'Unrestricted_Access);
 457
 458    begin
 459       pragma Assert (Matched'First = 0);
 460
 461       Reinitialize_Buffer (Descriptor);
 462
 463       loop
 464          --  First, test if what is already in the buffer matches (This is
 465          --  required if this package is used in multi-task mode, since one of
 466          --  the tasks might have added something in the buffer, and we don't
 467          --  want other tasks to wait for new input to be available before
 468          --  checking the regexps).
 469
 470          if Descriptor.Buffer /= null then
 471             for J in Regexps'Range loop
 472                Match
 473                  (Regexps (J).all,
 474                   Descriptor.Buffer (1 .. Descriptor.Buffer_Index),
 475                   Matched);
 476
 477                if Matched (0) /= No_Match then
 478                   Result := Expect_Match (J);
 479                   Descriptor.Last_Match_Start := Matched (0).First;
 480                   Descriptor.Last_Match_End := Matched (0).Last;
 481                   return;
 482                end if;
 483             end loop;
 484          end if;
 485
 486          Expect_Internal (Descriptors, N, Timeout, Full_Buffer);
 487
 488          if N = Expect_Timeout or else N = Expect_Full_Buffer then
 489             Result := N;
 490             return;
 491          end if;
 492       end loop;
 493    end Expect;
 494
 495    procedure Expect
 496      (Result      : out Expect_Match;
 497       Regexps     : Multiprocess_Regexp_Array;
 498       Matched     : out GNAT.Regpat.Match_Array;
 499       Timeout     : Integer := 10000;
 500       Full_Buffer : Boolean := False)
 501    is
 502       N           : Expect_Match;
 503       Descriptors : Array_Of_Pd (Regexps'Range);
 504
 505    begin
 506       pragma Assert (Matched'First = 0);
 507
 508       for J in Descriptors'Range loop
 509          Descriptors (J) := Regexps (J).Descriptor;
 510          Reinitialize_Buffer (Regexps (J).Descriptor.all);
 511       end loop;
 512
 513       loop
 514          --  First, test if what is already in the buffer matches (This is
 515          --  required if this package is used in multi-task mode, since one of
 516          --  the tasks might have added something in the buffer, and we don't
 517          --  want other tasks to wait for new input to be available before
 518          --  checking the regexps).
 519
 520          for J in Regexps'Range loop
 521             Match (Regexps (J).Regexp.all,
 522                    Regexps (J).Descriptor.Buffer
 523                      (1 .. Regexps (J).Descriptor.Buffer_Index),
 524                    Matched);
 525
 526             if Matched (0) /= No_Match then
 527                Result := Expect_Match (J);
 528                Regexps (J).Descriptor.Last_Match_Start := Matched (0).First;
 529                Regexps (J).Descriptor.Last_Match_End := Matched (0).Last;
 530                return;
 531             end if;
 532          end loop;
 533
 534          Expect_Internal (Descriptors, N, Timeout, Full_Buffer);
 535
 536          if N = Expect_Timeout or else N = Expect_Full_Buffer then
 537             Result := N;
 538             return;
 539          end if;
 540       end loop;
 541    end Expect;
 542
 543    ---------------------
 544    -- Expect_Internal --
 545    ---------------------
 546
 547    procedure Expect_Internal
 548      (Descriptors : in out Array_Of_Pd;
 549       Result      : out Expect_Match;
 550       Timeout     : Integer;
 551       Full_Buffer : Boolean)
 552    is
 553       Num_Descriptors : Integer;
 554       Buffer_Size     : Integer := 0;
 555
 556       N : Integer;
 557
 558       type File_Descriptor_Array is
 559         array (Descriptors'Range) of File_Descriptor;
 560       Fds : aliased File_Descriptor_Array;
 561
 562       type Integer_Array is array (Descriptors'Range) of Integer;
 563       Is_Set : aliased Integer_Array;
 564
 565    begin
 566       for J in Descriptors'Range loop
 567          Fds (J) := Descriptors (J).Output_Fd;
 568
 569          if Descriptors (J).Buffer_Size = 0 then
 570             Buffer_Size := Integer'Max (Buffer_Size, 4096);
 571          else
 572             Buffer_Size :=
 573               Integer'Max (Buffer_Size, Descriptors (J).Buffer_Size);
 574          end if;
 575       end loop;
 576
 577       declare
 578          Buffer : aliased String (1 .. Buffer_Size);
 579          --  Buffer used for input. This is allocated only once, not for
 580          --  every iteration of the loop
 581
 582       begin
 583          --  Loop until we match or we have a timeout
 584
 585          loop
 586             Num_Descriptors :=
 587               Poll (Fds'Address, Fds'Length, Timeout, Is_Set'Address);
 588
 589             case Num_Descriptors is
 590
 591                --  Error?
 592
 593                when -1 =>
 594                   raise Process_Died;
 595
 596                --  Timeout?
 597
 598                when 0  =>
 599                   Result := Expect_Timeout;
 600                   return;
 601
 602                --  Some input
 603
 604                when others =>
 605                   for J in Descriptors'Range loop
 606                      if Is_Set (J) = 1 then
 607                         Buffer_Size := Descriptors (J).Buffer_Size;
 608
 609                         if Buffer_Size = 0 then
 610                            Buffer_Size := 4096;
 611                         end if;
 612
 613                         N := Read (Descriptors (J).Output_Fd, Buffer'Address,
 614                                    Buffer_Size);
 615
 616                         --  Error or End of file
 617
 618                         if N <= 0 then
 619                            --  ??? Note that ddd tries again up to three times
 620                            --  in that case. See LiterateA.C:174
 621                            raise Process_Died;
 622
 623                         else
 624                            --  If there is no limit to the buffer size
 625
 626                            if Descriptors (J).Buffer_Size = 0 then
 627
 628                               declare
 629                                  Tmp : String_Access := Descriptors (J).Buffer;
 630
 631                               begin
 632                                  if Tmp /= null then
 633                                     Descriptors (J).Buffer :=
 634                                       new String (1 .. Tmp'Length + N);
 635                                     Descriptors (J).Buffer (1 .. Tmp'Length) :=
 636                                       Tmp.all;
 637                                     Descriptors (J).Buffer
 638                                       (Tmp'Length + 1 .. Tmp'Length + N) :=
 639                                       Buffer (1 .. N);
 640                                     Free (Tmp);
 641                                     Descriptors (J).Buffer_Index :=
 642                                       Descriptors (J).Buffer'Last;
 643
 644                                  else
 645                                     Descriptors (J).Buffer :=
 646                                       new String (1 .. N);
 647                                     Descriptors (J).Buffer.all :=
 648                                       Buffer (1 .. N);
 649                                     Descriptors (J).Buffer_Index := N;
 650                                  end if;
 651                               end;
 652
 653                            else
 654                               --  Add what we read to the buffer
 655
 656                               if Descriptors (J).Buffer_Index + N - 1 >
 657                                 Descriptors (J).Buffer_Size
 658                               then
 659                                  --  If the user wants to know when we have
 660                                  --  read more than the buffer can contain.
 661
 662                                  if Full_Buffer then
 663                                     Result := Expect_Full_Buffer;
 664                                     return;
 665                                  end if;
 666
 667                                  --  Keep as much as possible from the buffer,
 668                                  --  and forget old characters.
 669
 670                                  Descriptors (J).Buffer
 671                                    (1 .. Descriptors (J).Buffer_Size - N) :=
 672                                   Descriptors (J).Buffer
 673                                    (N - Descriptors (J).Buffer_Size +
 674                                     Descriptors (J).Buffer_Index + 1 ..
 675                                     Descriptors (J).Buffer_Index);
 676                                  Descriptors (J).Buffer_Index :=
 677                                    Descriptors (J).Buffer_Size - N;
 678                               end if;
 679
 680                               --  Keep what we read in the buffer.
 681
 682                               Descriptors (J).Buffer
 683                                 (Descriptors (J).Buffer_Index + 1 ..
 684                                  Descriptors (J).Buffer_Index + N) :=
 685                                 Buffer (1 .. N);
 686                               Descriptors (J).Buffer_Index :=
 687                                 Descriptors (J).Buffer_Index + N;
 688                            end if;
 689
 690                            --  Call each of the output filter with what we
 691                            --  read.
 692
 693                            Call_Filters
 694                              (Descriptors (J).all, Buffer (1 .. N), Output);
 695
 696                            Result := Expect_Match (N);
 697                            return;
 698                         end if;
 699                      end if;
 700                   end loop;
 701             end case;
 702          end loop;
 703       end;
 704    end Expect_Internal;
 705
 706    ----------------
 707    -- Expect_Out --
 708    ----------------
 709
 710    function Expect_Out (Descriptor : Process_Descriptor) return String is
 711    begin
 712       return Descriptor.Buffer (1 .. Descriptor.Last_Match_End);
 713    end Expect_Out;
 714
 715    ----------------------
 716    -- Expect_Out_Match --
 717    ----------------------
 718
 719    function Expect_Out_Match (Descriptor : Process_Descriptor) return String is
 720    begin
 721       return Descriptor.Buffer
 722         (Descriptor.Last_Match_Start .. Descriptor.Last_Match_End);
 723    end Expect_Out_Match;
 724
 725    -----------
 726    -- Flush --
 727    -----------
 728
 729    procedure Flush
 730      (Descriptor : in out Process_Descriptor;
 731       Timeout    : Integer := 0)
 732    is
 733       Num_Descriptors : Integer;
 734       N               : Integer;
 735       Is_Set          : aliased Integer;
 736       Buffer_Size     : Integer := 8192;
 737       Buffer          : aliased String (1 .. Buffer_Size);
 738
 739    begin
 740       --  Empty the current buffer
 741
 742       Descriptor.Last_Match_End := Descriptor.Buffer_Index;
 743       Reinitialize_Buffer (Descriptor);
 744
 745       --  Read everything from the process to flush its output
 746
 747       loop
 748          Num_Descriptors :=
 749            Poll (Descriptor.Output_Fd'Address, 1, Timeout, Is_Set'Address);
 750
 751          case Num_Descriptors is
 752
 753             --  Error ?
 754
 755             when -1 =>
 756                raise Process_Died;
 757
 758             --  Timeout => End of flush
 759
 760             when 0  =>
 761                return;
 762
 763             --  Some input
 764
 765             when others =>
 766                if Is_Set = 1 then
 767                   N := Read (Descriptor.Output_Fd, Buffer'Address,
 768                              Buffer_Size);
 769
 770                   if N = -1 then
 771                      raise Process_Died;
 772                   elsif N = 0 then
 773                      return;
 774                   end if;
 775                end if;
 776          end case;
 777       end loop;
 778
 779    end Flush;
 780
 781    ------------------
 782    -- Get_Error_Fd --
 783    ------------------
 784
 785    function Get_Error_Fd
 786      (Descriptor : Process_Descriptor)
 787       return       GNAT.OS_Lib.File_Descriptor
 788    is
 789    begin
 790       return Descriptor.Error_Fd;
 791    end Get_Error_Fd;
 792
 793    ------------------
 794    -- Get_Input_Fd --
 795    ------------------
 796
 797    function Get_Input_Fd
 798      (Descriptor : Process_Descriptor)
 799       return       GNAT.OS_Lib.File_Descriptor
 800    is
 801    begin
 802       return Descriptor.Input_Fd;
 803    end Get_Input_Fd;
 804
 805    -------------------
 806    -- Get_Output_Fd --
 807    -------------------
 808
 809    function Get_Output_Fd
 810      (Descriptor : Process_Descriptor)
 811       return       GNAT.OS_Lib.File_Descriptor
 812    is
 813    begin
 814       return Descriptor.Output_Fd;
 815    end Get_Output_Fd;
 816
 817    -------------
 818    -- Get_Pid --
 819    -------------
 820
 821    function Get_Pid
 822      (Descriptor : Process_Descriptor)
 823       return       Process_Id
 824    is
 825    begin
 826       return Descriptor.Pid;
 827    end Get_Pid;
 828
 829    ---------------
 830    -- Interrupt --
 831    ---------------
 832
 833    procedure Interrupt (Descriptor : in out Process_Descriptor) is
 834       SIGINT : constant := 2;
 835
 836    begin
 837       Send_Signal (Descriptor, SIGINT);
 838    end Interrupt;
 839
 840    ------------------
 841    -- Lock_Filters --
 842    ------------------
 843
 844    procedure Lock_Filters (Descriptor : in out Process_Descriptor) is
 845    begin
 846       Descriptor.Filters_Lock := Descriptor.Filters_Lock + 1;
 847    end Lock_Filters;
 848
 849    ------------------------
 850    -- Non_Blocking_Spawn --
 851    ------------------------
 852
 853    procedure Non_Blocking_Spawn
 854      (Descriptor  : out Process_Descriptor'Class;
 855       Command     : String;
 856       Args        : GNAT.OS_Lib.Argument_List;
 857       Buffer_Size : Natural := 4096;
 858       Err_To_Out  : Boolean := False)
 859    is
 860    separate;
 861
 862    -------------------------
 863    -- Reinitialize_Buffer --
 864    -------------------------
 865
 866    procedure Reinitialize_Buffer
 867      (Descriptor : in out Process_Descriptor'Class)
 868    is
 869    begin
 870       if Descriptor.Buffer_Size = 0 then
 871          declare
 872             Tmp : String_Access := Descriptor.Buffer;
 873
 874          begin
 875             Descriptor.Buffer :=
 876               new String
 877                 (1 .. Descriptor.Buffer_Index - Descriptor.Last_Match_End);
 878
 879             if Tmp /= null then
 880                Descriptor.Buffer.all := Tmp
 881                  (Descriptor.Last_Match_End + 1 .. Descriptor.Buffer_Index);
 882                Free (Tmp);
 883             end if;
 884          end;
 885
 886          Descriptor.Buffer_Index := Descriptor.Buffer'Last;
 887
 888       else
 889          Descriptor.Buffer
 890            (1 .. Descriptor.Buffer_Index - Descriptor.Last_Match_End) :=
 891              Descriptor.Buffer
 892                (Descriptor.Last_Match_End + 1 .. Descriptor.Buffer_Index);
 893
 894          if Descriptor.Buffer_Index > Descriptor.Last_Match_End then
 895             Descriptor.Buffer_Index :=
 896               Descriptor.Buffer_Index - Descriptor.Last_Match_End;
 897          else
 898             Descriptor.Buffer_Index := 0;
 899          end if;
 900       end if;
 901
 902       Descriptor.Last_Match_Start := 0;
 903       Descriptor.Last_Match_End := 0;
 904    end Reinitialize_Buffer;
 905
 906    -------------------
 907    -- Remove_Filter --
 908    -------------------
 909
 910    procedure Remove_Filter
 911      (Descriptor : in out Process_Descriptor;
 912       Filter     : Filter_Function)
 913    is
 914       Previous : Filter_List := null;
 915       Current  : Filter_List := Descriptor.Filters;
 916
 917    begin
 918       while Current /= null loop
 919          if Current.Filter = Filter then
 920             if Previous = null then
 921                Descriptor.Filters := Current.Next;
 922             else
 923                Previous.Next := Current.Next;
 924             end if;
 925          end if;
 926
 927          Previous := Current;
 928          Current := Current.Next;
 929       end loop;
 930    end Remove_Filter;
 931
 932    ----------
 933    -- Send --
 934    ----------
 935
 936    procedure Send
 937      (Descriptor : in out Process_Descriptor;
 938       Str        : String;
 939       Add_LF     : Boolean := True;
 940       Empty_Buffer : Boolean := False)
 941    is
 942       N           : Natural;
 943       Full_Str    : constant String := Str & ASCII.LF;
 944       Last        : Natural;
 945       Result      : Expect_Match;
 946       Descriptors : Array_Of_Pd := (1 => Descriptor'Unrestricted_Access);
 947
 948    begin
 949       if Empty_Buffer then
 950
 951          --  Force a read on the process if there is anything waiting.
 952
 953          Expect_Internal (Descriptors, Result,
 954                           Timeout => 0, Full_Buffer => False);
 955          Descriptor.Last_Match_End := Descriptor.Buffer_Index;
 956
 957          --  Empty the buffer
 958
 959          Reinitialize_Buffer (Descriptor);
 960       end if;
 961
 962       if Add_LF then
 963          Last := Full_Str'Last;
 964       else
 965          Last := Full_Str'Last - 1;
 966       end if;
 967
 968       Call_Filters (Descriptor, Full_Str (Full_Str'First .. Last), Input);
 969
 970       N := Write (Descriptor.Input_Fd,
 971                   Full_Str'Address,
 972                   Last - Full_Str'First + 1);
 973    end Send;
 974
 975    -----------------
 976    -- Send_Signal --
 977    -----------------
 978
 979    procedure Send_Signal
 980      (Descriptor : Process_Descriptor;
 981       Signal     : Integer)
 982    is
 983    begin
 984       Kill (Descriptor.Pid, Signal);
 985       --  ??? Need to check process status here.
 986    end Send_Signal;
 987
 988    ---------------------------------
 989    -- Set_Up_Child_Communications --
 990    ---------------------------------
 991
 992    procedure Set_Up_Child_Communications
 993      (Pid   : in out Process_Descriptor;
 994       Pipe1 : in out Pipe_Type;
 995       Pipe2 : in out Pipe_Type;
 996       Pipe3 : in out Pipe_Type;
 997       Cmd   : in String;
 998       Args  : in System.Address)
 999    is
1000       pragma Warnings (Off, Pid);
1001
1002       Input  : File_Descriptor;
1003       Output : File_Descriptor;
1004       Error  : File_Descriptor;
1005
1006    begin
1007       --  Since Windows does not have a separate fork/exec, we need to
1008       --  perform the following actions:
1009       --    - save stdin, stdout, stderr
1010       --    - replace them by our pipes
1011       --    - create the child with process handle inheritance
1012       --    - revert to the previous stdin, stdout and stderr.
1013
1014       Input  := Dup (GNAT.OS_Lib.Standin);
1015       Output := Dup (GNAT.OS_Lib.Standout);
1016       Error  := Dup (GNAT.OS_Lib.Standerr);
1017
1018       --  Since we are still called from the parent process, there is no way
1019       --  currently we can cleanly close the unneeded ends of the pipes, but
1020       --  this doesn't really matter.
1021       --  We could close Pipe1.Output, Pipe2.Input, Pipe3.Input.
1022
1023       Dup2 (Pipe1.Input,  GNAT.OS_Lib.Standin);
1024       Dup2 (Pipe2.Output, GNAT.OS_Lib.Standout);
1025       Dup2 (Pipe3.Output, GNAT.OS_Lib.Standerr);
1026
1027       Portable_Execvp (Pid.Pid'Access, Cmd & ASCII.Nul, Args);
1028
1029       --  The following commands are not executed on Unix systems, and are
1030       --  only required for Windows systems. We are now in the parent process.
1031
1032       --  Restore the old descriptors
1033
1034       Dup2 (Input,  GNAT.OS_Lib.Standin);
1035       Dup2 (Output, GNAT.OS_Lib.Standout);
1036       Dup2 (Error, GNAT.OS_Lib.Standerr);
1037       Close (Input);
1038       Close (Output);
1039       Close (Error);
1040    end Set_Up_Child_Communications;
1041
1042    ---------------------------
1043    -- Set_Up_Communications --
1044    ---------------------------
1045
1046    procedure Set_Up_Communications
1047      (Pid        : in out Process_Descriptor;
1048       Err_To_Out : Boolean;
1049       Pipe1      : access Pipe_Type;
1050       Pipe2      : access Pipe_Type;
1051       Pipe3      : access Pipe_Type)
1052    is
1053    begin
1054       --  Create the pipes
1055
1056       if Create_Pipe (Pipe1) /= 0 then
1057          return;
1058       end if;
1059
1060       if Create_Pipe (Pipe2) /= 0 then
1061          return;
1062       end if;
1063
1064       Pid.Input_Fd  := Pipe1.Output;
1065       Pid.Output_Fd := Pipe2.Input;
1066
1067       if Err_To_Out then
1068          Pipe3.all := Pipe2.all;
1069       else
1070          if Create_Pipe (Pipe3) /= 0 then
1071             return;
1072          end if;
1073       end if;
1074
1075       Pid.Error_Fd := Pipe3.Input;
1076    end Set_Up_Communications;
1077
1078    ----------------------------------
1079    -- Set_Up_Parent_Communications --
1080    ----------------------------------
1081
1082    procedure Set_Up_Parent_Communications
1083      (Pid   : in out Process_Descriptor;
1084       Pipe1 : in out Pipe_Type;
1085       Pipe2 : in out Pipe_Type;
1086       Pipe3 : in out Pipe_Type)
1087    is
1088       pragma Warnings (Off, Pid);
1089
1090    begin
1091       Close (Pipe1.Input);
1092       Close (Pipe2.Output);
1093       Close (Pipe3.Output);
1094    end Set_Up_Parent_Communications;
1095
1096    ------------------
1097    -- Trace_Filter --
1098    ------------------
1099
1100    procedure Trace_Filter
1101      (Descriptor : Process_Descriptor'Class;
1102       Str        : String;
1103       User_Data  : System.Address := System.Null_Address)
1104    is
1105       pragma Warnings (Off, Descriptor);
1106       pragma Warnings (Off, User_Data);
1107
1108    begin
1109       GNAT.IO.Put (Str);
1110    end Trace_Filter;
1111
1112    --------------------
1113    -- Unlock_Filters --
1114    --------------------
1115
1116    procedure Unlock_Filters (Descriptor : in out Process_Descriptor) is
1117    begin
1118       if Descriptor.Filters_Lock > 0 then
1119          Descriptor.Filters_Lock := Descriptor.Filters_Lock - 1;
1120       end if;
1121    end Unlock_Filters;
1122
1123 end GNAT.Expect;