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