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