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