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