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