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