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-2016, 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
 362                | Expect_Process_Died
 363             =>
 364                raise Process_Died;
 365
 366             when Expect_Full_Buffer
 367                | Expect_Timeout
 368             =>
 369                Result := N;
 370                return;
 371
 372             when others =>
 373                null;  --  See below
 374          end case;
 375
 376          --  Calculate the timeout for the next turn
 377
 378          --  Note that Timeout is, from the caller's perspective, the maximum
 379          --  time until a match, not the maximum time until some output is
 380          --  read, and thus cannot be reused as is for Expect_Internal.
 381
 382          if Timeout /= -1 then
 383             Timeout_Tmp := Integer (Try_Until - Clock) * 1000;
 384
 385             if Timeout_Tmp < 0 then
 386                Result := Expect_Timeout;
 387                exit;
 388             end if;
 389          end if;
 390       end loop;
 391
 392       --  Even if we had the general timeout above, we have to test that the
 393       --  last test we read from the external process didn't match.
 394
 395       Match
 396         (Regexp, Descriptor.Buffer (1 .. Descriptor.Buffer_Index), Matched);
 397
 398       if Matched (0).First /= 0 then
 399          Result := 1;
 400          Descriptor.Last_Match_Start := Matched (0).First;
 401          Descriptor.Last_Match_End := Matched (0).Last;
 402          return;
 403       end if;
 404    end Expect;
 405
 406    procedure Expect
 407      (Descriptor  : in out Process_Descriptor;
 408       Result      : out Expect_Match;
 409       Regexps     : Regexp_Array;
 410       Timeout     : Integer := 10_000;
 411       Full_Buffer : Boolean := False)
 412    is
 413       Patterns : Compiled_Regexp_Array (Regexps'Range);
 414
 415       Matched : GNAT.Regpat.Match_Array (0 .. 0);
 416       pragma Warnings (Off, Matched);
 417
 418    begin
 419       for J in Regexps'Range loop
 420          Patterns (J) := new Pattern_Matcher'(Compile (Regexps (J).all));
 421       end loop;
 422
 423       Expect (Descriptor, Result, Patterns, Matched, Timeout, Full_Buffer);
 424
 425       for J in Regexps'Range loop
 426          Free (Patterns (J));
 427       end loop;
 428    end Expect;
 429
 430    procedure Expect
 431      (Descriptor  : in out Process_Descriptor;
 432       Result      : out Expect_Match;
 433       Regexps     : Compiled_Regexp_Array;
 434       Timeout     : Integer := 10_000;
 435       Full_Buffer : Boolean := False)
 436    is
 437       Matched : GNAT.Regpat.Match_Array (0 .. 0);
 438       pragma Warnings (Off, Matched);
 439    begin
 440       Expect (Descriptor, Result, Regexps, Matched, Timeout, Full_Buffer);
 441    end Expect;
 442
 443    procedure Expect
 444      (Result      : out Expect_Match;
 445       Regexps     : Multiprocess_Regexp_Array;
 446       Timeout     : Integer := 10_000;
 447       Full_Buffer : Boolean := False)
 448    is
 449       Matched : GNAT.Regpat.Match_Array (0 .. 0);
 450       pragma Warnings (Off, Matched);
 451    begin
 452       Expect (Result, Regexps, Matched, Timeout, Full_Buffer);
 453    end Expect;
 454
 455    procedure Expect
 456      (Descriptor  : in out Process_Descriptor;
 457       Result      : out Expect_Match;
 458       Regexps     : Regexp_Array;
 459       Matched     : out GNAT.Regpat.Match_Array;
 460       Timeout     : Integer := 10_000;
 461       Full_Buffer : Boolean := False)
 462    is
 463       Patterns : Compiled_Regexp_Array (Regexps'Range);
 464
 465    begin
 466       pragma Assert (Matched'First = 0);
 467
 468       for J in Regexps'Range loop
 469          Patterns (J) := new Pattern_Matcher'(Compile (Regexps (J).all));
 470       end loop;
 471
 472       Expect (Descriptor, Result, Patterns, Matched, Timeout, Full_Buffer);
 473
 474       for J in Regexps'Range loop
 475          Free (Patterns (J));
 476       end loop;
 477    end Expect;
 478
 479    procedure Expect
 480      (Descriptor  : in out Process_Descriptor;
 481       Result      : out Expect_Match;
 482       Regexps     : Compiled_Regexp_Array;
 483       Matched     : out GNAT.Regpat.Match_Array;
 484       Timeout     : Integer := 10_000;
 485       Full_Buffer : Boolean := False)
 486    is
 487       N           : Expect_Match;
 488       Descriptors : Array_Of_Pd := (1 => Descriptor'Unrestricted_Access);
 489
 490    begin
 491       pragma Assert (Matched'First = 0);
 492
 493       Reinitialize_Buffer (Descriptor);
 494
 495       loop
 496          --  First, test if what is already in the buffer matches (This is
 497          --  required if this package is used in multi-task mode, since one of
 498          --  the tasks might have added something in the buffer, and we don't
 499          --  want other tasks to wait for new input to be available before
 500          --  checking the regexps).
 501
 502          if Descriptor.Buffer /= null then
 503             for J in Regexps'Range loop
 504                Match
 505                  (Regexps (J).all,
 506                   Descriptor.Buffer (1 .. Descriptor.Buffer_Index),
 507                   Matched);
 508
 509                if Matched (0) /= No_Match then
 510                   Result := Expect_Match (J);
 511                   Descriptor.Last_Match_Start := Matched (0).First;
 512                   Descriptor.Last_Match_End := Matched (0).Last;
 513                   return;
 514                end if;
 515             end loop;
 516          end if;
 517
 518          Expect_Internal (Descriptors, N, Timeout, Full_Buffer);
 519
 520          case N is
 521             when Expect_Internal_Error
 522                | Expect_Process_Died
 523             =>
 524                raise Process_Died;
 525
 526             when Expect_Full_Buffer
 527                | Expect_Timeout
 528             =>
 529                Result := N;
 530                return;
 531
 532             when others =>
 533                null;  --  Continue
 534          end case;
 535       end loop;
 536    end Expect;
 537
 538    procedure Expect
 539      (Result      : out Expect_Match;
 540       Regexps     : Multiprocess_Regexp_Array;
 541       Matched     : out GNAT.Regpat.Match_Array;
 542       Timeout     : Integer := 10_000;
 543       Full_Buffer : Boolean := False)
 544    is
 545       N           : Expect_Match;
 546       Descriptors : Array_Of_Pd (Regexps'Range);
 547
 548    begin
 549       pragma Assert (Matched'First = 0);
 550
 551       for J in Descriptors'Range loop
 552          Descriptors (J) := Regexps (J).Descriptor;
 553
 554          if Descriptors (J) /= null then
 555             Reinitialize_Buffer (Regexps (J).Descriptor.all);
 556          end if;
 557       end loop;
 558
 559       loop
 560          --  First, test if what is already in the buffer matches (This is
 561          --  required if this package is used in multi-task mode, since one of
 562          --  the tasks might have added something in the buffer, and we don't
 563          --  want other tasks to wait for new input to be available before
 564          --  checking the regexps).
 565
 566          for J in Regexps'Range loop
 567             if Regexps (J).Regexp /= null
 568                and then Regexps (J).Descriptor /= null
 569             then
 570                Match (Regexps (J).Regexp.all,
 571                       Regexps (J).Descriptor.Buffer
 572                         (1 .. Regexps (J).Descriptor.Buffer_Index),
 573                       Matched);
 574
 575                if Matched (0) /= No_Match then
 576                   Result := Expect_Match (J);
 577                   Regexps (J).Descriptor.Last_Match_Start := Matched (0).First;
 578                   Regexps (J).Descriptor.Last_Match_End := Matched (0).Last;
 579                   return;
 580                end if;
 581             end if;
 582          end loop;
 583
 584          Expect_Internal (Descriptors, N, Timeout, Full_Buffer);
 585
 586          case N is
 587             when Expect_Internal_Error
 588                | Expect_Process_Died
 589             =>
 590                raise Process_Died;
 591
 592             when Expect_Full_Buffer
 593                | Expect_Timeout
 594             =>
 595                Result := N;
 596                return;
 597
 598             when others =>
 599                null;  --  Continue
 600          end case;
 601       end loop;
 602    end Expect;
 603
 604    ---------------------
 605    -- Expect_Internal --
 606    ---------------------
 607
 608    procedure Expect_Internal
 609      (Descriptors : in out Array_Of_Pd;
 610       Result      : out Expect_Match;
 611       Timeout     : Integer;
 612       Full_Buffer : Boolean)
 613    is
 614       Num_Descriptors : Integer;
 615       Buffer_Size     : Integer := 0;
 616
 617       N : Integer;
 618
 619       type File_Descriptor_Array is
 620         array (0 .. Descriptors'Length - 1) of File_Descriptor;
 621       Fds : aliased File_Descriptor_Array;
 622       Fds_Count : Natural := 0;
 623
 624       Fds_To_Descriptor : array (Fds'Range) of Integer;
 625       --  Maps file descriptor entries from Fds to entries in Descriptors.
 626       --  They do not have the same index when entries in Descriptors are null.
 627
 628       type Integer_Array is array (Fds'Range) of Integer;
 629       Is_Set : aliased Integer_Array;
 630
 631    begin
 632       for J in Descriptors'Range loop
 633          if Descriptors (J) /= null then
 634             Fds (Fds'First + Fds_Count) := Descriptors (J).Output_Fd;
 635             Fds_To_Descriptor (Fds'First + Fds_Count) := J;
 636             Fds_Count := Fds_Count + 1;
 637
 638             if Descriptors (J).Buffer_Size = 0 then
 639                Buffer_Size := Integer'Max (Buffer_Size, 4096);
 640             else
 641                Buffer_Size :=
 642                  Integer'Max (Buffer_Size, Descriptors (J).Buffer_Size);
 643             end if;
 644          end if;
 645       end loop;
 646
 647       declare
 648          Buffer : aliased String (1 .. Buffer_Size);
 649          --  Buffer used for input. This is allocated only once, not for
 650          --  every iteration of the loop
 651
 652          D : aliased Integer;
 653          --  Index in Descriptors
 654
 655       begin
 656          --  Loop until we match or we have a timeout
 657
 658          loop
 659             Num_Descriptors :=
 660               Poll (Fds'Address, Fds_Count, Timeout, D'Access, Is_Set'Address);
 661
 662             case Num_Descriptors is
 663
 664                --  Error?
 665
 666                when -1 =>
 667                   Result := Expect_Internal_Error;
 668
 669                   if D /= 0 then
 670                      Close (Descriptors (D).Input_Fd);
 671                      Descriptors (D).Input_Fd := Invalid_FD;
 672                   end if;
 673
 674                   return;
 675
 676                --  Timeout?
 677
 678                when 0  =>
 679                   Result := Expect_Timeout;
 680                   return;
 681
 682                --  Some input
 683
 684                when others =>
 685                   for F in Fds'Range loop
 686                      if Is_Set (F) = 1 then
 687                         D := Fds_To_Descriptor (F);
 688
 689                         Buffer_Size := Descriptors (D).Buffer_Size;
 690
 691                         if Buffer_Size = 0 then
 692                            Buffer_Size := 4096;
 693                         end if;
 694
 695                         N := Read (Descriptors (D).Output_Fd, Buffer'Address,
 696                                    Buffer_Size);
 697
 698                         --  Error or End of file
 699
 700                         if N <= 0 then
 701                            --  ??? Note that ddd tries again up to three times
 702                            --  in that case. See LiterateA.C:174
 703
 704                            Close (Descriptors (D).Input_Fd);
 705                            Descriptors (D).Input_Fd := Invalid_FD;
 706                            Result := Expect_Process_Died;
 707                            return;
 708
 709                         else
 710                            --  If there is no limit to the buffer size
 711
 712                            if Descriptors (D).Buffer_Size = 0 then
 713                               declare
 714                                  Tmp : String_Access := Descriptors (D).Buffer;
 715
 716                               begin
 717                                  if Tmp /= null then
 718                                     Descriptors (D).Buffer :=
 719                                       new String (1 .. Tmp'Length + N);
 720                                     Descriptors (D).Buffer (1 .. Tmp'Length) :=
 721                                       Tmp.all;
 722                                     Descriptors (D).Buffer
 723                                       (Tmp'Length + 1 .. Tmp'Length + N) :=
 724                                       Buffer (1 .. N);
 725                                     Free (Tmp);
 726                                     Descriptors (D).Buffer_Index :=
 727                                       Descriptors (D).Buffer'Last;
 728
 729                                  else
 730                                     Descriptors (D).Buffer :=
 731                                       new String (1 .. N);
 732                                     Descriptors (D).Buffer.all :=
 733                                       Buffer (1 .. N);
 734                                     Descriptors (D).Buffer_Index := N;
 735                                  end if;
 736                               end;
 737
 738                            else
 739                               --  Add what we read to the buffer
 740
 741                               if Descriptors (D).Buffer_Index + N >
 742                                    Descriptors (D).Buffer_Size
 743                               then
 744                                  --  If the user wants to know when we have
 745                                  --  read more than the buffer can contain.
 746
 747                                  if Full_Buffer then
 748                                     Result := Expect_Full_Buffer;
 749                                     return;
 750                                  end if;
 751
 752                                  --  Keep as much as possible from the buffer,
 753                                  --  and forget old characters.
 754
 755                                  Descriptors (D).Buffer
 756                                    (1 .. Descriptors (D).Buffer_Size - N) :=
 757                                   Descriptors (D).Buffer
 758                                    (N - Descriptors (D).Buffer_Size +
 759                                     Descriptors (D).Buffer_Index + 1 ..
 760                                     Descriptors (D).Buffer_Index);
 761                                  Descriptors (D).Buffer_Index :=
 762                                    Descriptors (D).Buffer_Size - N;
 763                               end if;
 764
 765                               --  Keep what we read in the buffer
 766
 767                               Descriptors (D).Buffer
 768                                 (Descriptors (D).Buffer_Index + 1 ..
 769                                  Descriptors (D).Buffer_Index + N) :=
 770                                 Buffer (1 .. N);
 771                               Descriptors (D).Buffer_Index :=
 772                                 Descriptors (D).Buffer_Index + N;
 773                            end if;
 774
 775                            --  Call each of the output filter with what we
 776                            --  read.
 777
 778                            Call_Filters
 779                              (Descriptors (D).all, Buffer (1 .. N), Output);
 780
 781                            Result := Expect_Match (D);
 782                            return;
 783                         end if;
 784                      end if;
 785                   end loop;
 786             end case;
 787          end loop;
 788       end;
 789    end Expect_Internal;
 790
 791    ----------------
 792    -- Expect_Out --
 793    ----------------
 794
 795    function Expect_Out (Descriptor : Process_Descriptor) return String is
 796    begin
 797       return Descriptor.Buffer (1 .. Descriptor.Last_Match_End);
 798    end Expect_Out;
 799
 800    ----------------------
 801    -- Expect_Out_Match --
 802    ----------------------
 803
 804    function Expect_Out_Match (Descriptor : Process_Descriptor) return String is
 805    begin
 806       return Descriptor.Buffer
 807         (Descriptor.Last_Match_Start .. Descriptor.Last_Match_End);
 808    end Expect_Out_Match;
 809
 810    ------------------------
 811    -- First_Dead_Process --
 812    ------------------------
 813
 814    function First_Dead_Process
 815      (Regexp : Multiprocess_Regexp_Array) return Natural is
 816    begin
 817       for R in Regexp'Range loop
 818          if Regexp (R).Descriptor /= null
 819            and then Regexp (R).Descriptor.Input_Fd = GNAT.OS_Lib.Invalid_FD
 820          then
 821             return R;
 822          end if;
 823       end loop;
 824
 825       return 0;
 826    end First_Dead_Process;
 827
 828    -----------
 829    -- Flush --
 830    -----------
 831
 832    procedure Flush
 833      (Descriptor : in out Process_Descriptor;
 834       Timeout    : Integer := 0)
 835    is
 836       Buffer_Size     : constant Integer := 8192;
 837       Num_Descriptors : Integer;
 838       N               : aliased Integer;
 839       Is_Set          : aliased Integer;
 840       Buffer          : aliased String (1 .. Buffer_Size);
 841
 842    begin
 843       --  Empty the current buffer
 844
 845       Descriptor.Last_Match_End := Descriptor.Buffer_Index;
 846       Reinitialize_Buffer (Descriptor);
 847
 848       --  Read everything from the process to flush its output
 849
 850       loop
 851          Num_Descriptors :=
 852            Poll (Descriptor.Output_Fd'Address,
 853                  1,
 854                  Timeout,
 855                  N'Access,
 856                  Is_Set'Address);
 857
 858          case Num_Descriptors is
 859
 860             --  Error ?
 861
 862             when -1 =>
 863                raise Process_Died;
 864
 865             --  Timeout => End of flush
 866
 867             when 0  =>
 868                return;
 869
 870             --  Some input
 871
 872             when others =>
 873                if Is_Set = 1 then
 874                   N := Read (Descriptor.Output_Fd, Buffer'Address,
 875                              Buffer_Size);
 876
 877                   if N = -1 then
 878                      raise Process_Died;
 879                   elsif N = 0 then
 880                      return;
 881                   end if;
 882                end if;
 883          end case;
 884       end loop;
 885    end Flush;
 886
 887    ----------
 888    -- Free --
 889    ----------
 890
 891    procedure Free (Regexp : in out Multiprocess_Regexp) is
 892       procedure Unchecked_Free is new Ada.Unchecked_Deallocation
 893         (Process_Descriptor'Class, Process_Descriptor_Access);
 894    begin
 895       Unchecked_Free (Regexp.Descriptor);
 896       Free (Regexp.Regexp);
 897    end Free;
 898
 899    ------------------------
 900    -- Get_Command_Output --
 901    ------------------------
 902
 903    function Get_Command_Output
 904      (Command    : String;
 905       Arguments  : GNAT.OS_Lib.Argument_List;
 906       Input      : String;
 907       Status     : not null access Integer;
 908       Err_To_Out : Boolean := False) return String
 909    is
 910       use GNAT.Expect;
 911
 912       Process : Process_Descriptor;
 913
 914       Output : String_Access := new String (1 .. 1024);
 915       --  Buffer used to accumulate standard output from the launched
 916       --  command, expanded as necessary during execution.
 917
 918       Last : Integer := 0;
 919       --  Index of the last used character within Output
 920
 921    begin
 922       Non_Blocking_Spawn
 923         (Process, Command, Arguments, Err_To_Out => Err_To_Out,
 924          Buffer_Size => 0);
 925
 926       if Input'Length > 0 then
 927          Send (Process, Input);
 928       end if;
 929
 930       Close (Process.Input_Fd);
 931       Process.Input_Fd := Invalid_FD;
 932
 933       declare
 934          Result : Expect_Match;
 935          pragma Unreferenced (Result);
 936
 937       begin
 938          --  This loop runs until the call to Expect raises Process_Died
 939
 940          loop
 941             Expect (Process, Result, ".+", Timeout => -1);
 942
 943             declare
 944                NOutput : String_Access;
 945                S       : constant String := Expect_Out (Process);
 946                pragma Assert (S'Length > 0);
 947
 948             begin
 949                --  Expand buffer if we need more space. Note here that we add
 950                --  S'Length to ensure that S will fit in the new buffer size.
 951
 952                if Last + S'Length > Output'Last then
 953                   NOutput := new String (1 .. 2 * Output'Last + S'Length);
 954                   NOutput (Output'Range) := Output.all;
 955                   Free (Output);
 956
 957                --  Here if current buffer size is OK
 958
 959                else
 960                   NOutput := Output;
 961                end if;
 962
 963                NOutput (Last + 1 .. Last + S'Length) := S;
 964                Last := Last + S'Length;
 965                Output := NOutput;
 966             end;
 967          end loop;
 968
 969       exception
 970          when Process_Died =>
 971             Close (Process, Status.all);
 972       end;
 973
 974       if Last = 0 then
 975          Free (Output);
 976          return "";
 977       end if;
 978
 979       declare
 980          S : constant String := Output (1 .. Last);
 981       begin
 982          Free (Output);
 983          return S;
 984       end;
 985    end Get_Command_Output;
 986
 987    ------------------
 988    -- Get_Error_Fd --
 989    ------------------
 990
 991    function Get_Error_Fd
 992      (Descriptor : Process_Descriptor) return GNAT.OS_Lib.File_Descriptor
 993    is
 994    begin
 995       return Descriptor.Error_Fd;
 996    end Get_Error_Fd;
 997
 998    ------------------
 999    -- Get_Input_Fd --
1000    ------------------
1001
1002    function Get_Input_Fd
1003      (Descriptor : Process_Descriptor) return GNAT.OS_Lib.File_Descriptor
1004    is
1005    begin
1006       return Descriptor.Input_Fd;
1007    end Get_Input_Fd;
1008
1009    -------------------
1010    -- Get_Output_Fd --
1011    -------------------
1012
1013    function Get_Output_Fd
1014      (Descriptor : Process_Descriptor) return GNAT.OS_Lib.File_Descriptor
1015    is
1016    begin
1017       return Descriptor.Output_Fd;
1018    end Get_Output_Fd;
1019
1020    -------------
1021    -- Get_Pid --
1022    -------------
1023
1024    function Get_Pid
1025      (Descriptor : Process_Descriptor) return Process_Id
1026    is
1027    begin
1028       return Descriptor.Pid;
1029    end Get_Pid;
1030
1031    -----------------
1032    -- Has_Process --
1033    -----------------
1034
1035    function Has_Process (Regexp : Multiprocess_Regexp_Array) return Boolean is
1036    begin
1037       return Regexp /= (Regexp'Range => (null, null));
1038    end Has_Process;
1039
1040    ---------------
1041    -- Interrupt --
1042    ---------------
1043
1044    procedure Interrupt (Descriptor : in out Process_Descriptor) is
1045       SIGINT : constant := 2;
1046    begin
1047       Send_Signal (Descriptor, SIGINT);
1048    end Interrupt;
1049
1050    ------------------
1051    -- Lock_Filters --
1052    ------------------
1053
1054    procedure Lock_Filters (Descriptor : in out Process_Descriptor) is
1055    begin
1056       Descriptor.Filters_Lock := Descriptor.Filters_Lock + 1;
1057    end Lock_Filters;
1058
1059    ------------------------
1060    -- Non_Blocking_Spawn --
1061    ------------------------
1062
1063    procedure Non_Blocking_Spawn
1064      (Descriptor  : out Process_Descriptor'Class;
1065       Command     : String;
1066       Args        : GNAT.OS_Lib.Argument_List;
1067       Buffer_Size : Natural := 4096;
1068       Err_To_Out  : Boolean := False)
1069    is
1070       function Fork return Process_Id;
1071       pragma Import (C, Fork, "__gnat_expect_fork");
1072       --  Starts a new process if possible. See the Unix command fork for more
1073       --  information. On systems that do not support this capability (such as
1074       --  Windows...), this command does nothing, and Fork will return
1075       --  Null_Pid.
1076
1077       Pipe1, Pipe2, Pipe3 : aliased Pipe_Type;
1078
1079       Arg        : String_Access;
1080       Arg_List   : String_List (1 .. Args'Length + 2);
1081       C_Arg_List : aliased array (1 .. Args'Length + 2) of System.Address;
1082
1083       Command_With_Path : String_Access;
1084
1085    begin
1086       Command_With_Path := Locate_Exec_On_Path (Command);
1087
1088       if Command_With_Path = null then
1089          raise Invalid_Process;
1090       end if;
1091
1092       --  Create the rest of the pipes once we know we will be able to
1093       --  execute the process.
1094
1095       Set_Up_Communications
1096         (Descriptor, Err_To_Out, Pipe1'Access, Pipe2'Access, Pipe3'Access);
1097
1098       --  Fork a new process
1099
1100       Descriptor.Pid := Fork;
1101
1102       --  Are we now in the child (or, for Windows, still in the common
1103       --  process).
1104
1105       if Descriptor.Pid = Null_Pid then
1106          --  Prepare an array of arguments to pass to C
1107
1108          Arg := new String (1 .. Command_With_Path'Length + 1);
1109          Arg (1 .. Command_With_Path'Length) := Command_With_Path.all;
1110          Arg (Arg'Last)        := ASCII.NUL;
1111          Arg_List (1)          := Arg;
1112
1113          for J in Args'Range loop
1114             Arg                     := new String (1 .. Args (J)'Length + 1);
1115             Arg (1 .. Args (J)'Length)    := Args (J).all;
1116             Arg (Arg'Last)                := ASCII.NUL;
1117             Arg_List (J + 2 - Args'First) := Arg.all'Access;
1118          end loop;
1119
1120          Arg_List (Arg_List'Last) := null;
1121
1122          --  Make sure all arguments are compatible with OS conventions
1123
1124          Normalize_Arguments (Arg_List);
1125
1126          --  Prepare low-level argument list from the normalized arguments
1127
1128          for K in Arg_List'Range loop
1129             C_Arg_List (K) :=
1130               (if Arg_List (K) /= null
1131                then Arg_List (K).all'Address
1132                else System.Null_Address);
1133          end loop;
1134
1135          --  This does not return on Unix systems
1136
1137          Set_Up_Child_Communications
1138            (Descriptor, Pipe1, Pipe2, Pipe3, Command_With_Path.all,
1139             C_Arg_List'Address);
1140       end if;
1141
1142       Free (Command_With_Path);
1143
1144       --  Did we have an error when spawning the child ?
1145
1146       if Descriptor.Pid < Null_Pid then
1147          raise Invalid_Process;
1148       else
1149          --  We are now in the parent process
1150
1151          Set_Up_Parent_Communications (Descriptor, Pipe1, Pipe2, Pipe3);
1152       end if;
1153
1154       --  Create the buffer
1155
1156       Descriptor.Buffer_Size := Buffer_Size;
1157
1158       if Buffer_Size /= 0 then
1159          Descriptor.Buffer := new String (1 .. Positive (Buffer_Size));
1160       end if;
1161
1162       --  Initialize the filters
1163
1164       Descriptor.Filters := null;
1165    end Non_Blocking_Spawn;
1166
1167    -------------------------
1168    -- Reinitialize_Buffer --
1169    -------------------------
1170
1171    procedure Reinitialize_Buffer
1172      (Descriptor : in out Process_Descriptor'Class)
1173    is
1174    begin
1175       if Descriptor.Buffer_Size = 0 then
1176          declare
1177             Tmp : String_Access := Descriptor.Buffer;
1178
1179          begin
1180             Descriptor.Buffer :=
1181               new String
1182                 (1 .. Descriptor.Buffer_Index - Descriptor.Last_Match_End);
1183
1184             if Tmp /= null then
1185                Descriptor.Buffer.all := Tmp
1186                  (Descriptor.Last_Match_End + 1 .. Descriptor.Buffer_Index);
1187                Free (Tmp);
1188             end if;
1189          end;
1190
1191          Descriptor.Buffer_Index := Descriptor.Buffer'Last;
1192
1193       else
1194          Descriptor.Buffer
1195            (1 .. Descriptor.Buffer_Index - Descriptor.Last_Match_End) :=
1196              Descriptor.Buffer
1197                (Descriptor.Last_Match_End + 1 .. Descriptor.Buffer_Index);
1198
1199          if Descriptor.Buffer_Index > Descriptor.Last_Match_End then
1200             Descriptor.Buffer_Index :=
1201               Descriptor.Buffer_Index - Descriptor.Last_Match_End;
1202          else
1203             Descriptor.Buffer_Index := 0;
1204          end if;
1205       end if;
1206
1207       Descriptor.Last_Match_Start := 0;
1208       Descriptor.Last_Match_End := 0;
1209    end Reinitialize_Buffer;
1210
1211    -------------------
1212    -- Remove_Filter --
1213    -------------------
1214
1215    procedure Remove_Filter
1216      (Descriptor : in out Process_Descriptor;
1217       Filter     : Filter_Function)
1218    is
1219       Previous : Filter_List := null;
1220       Current  : Filter_List := Descriptor.Filters;
1221
1222    begin
1223       while Current /= null loop
1224          if Current.Filter = Filter then
1225             if Previous = null then
1226                Descriptor.Filters := Current.Next;
1227             else
1228                Previous.Next := Current.Next;
1229             end if;
1230          end if;
1231
1232          Previous := Current;
1233          Current := Current.Next;
1234       end loop;
1235    end Remove_Filter;
1236
1237    ----------
1238    -- Send --
1239    ----------
1240
1241    procedure Send
1242      (Descriptor   : in out Process_Descriptor;
1243       Str          : String;
1244       Add_LF       : Boolean := True;
1245       Empty_Buffer : Boolean := False)
1246    is
1247       Line_Feed   : aliased constant String := (1 .. 1 => ASCII.LF);
1248       Descriptors : Array_Of_Pd := (1 => Descriptor'Unrestricted_Access);
1249
1250       Result  : Expect_Match;
1251       Discard : Natural;
1252       pragma Warnings (Off, Result);
1253       pragma Warnings (Off, Discard);
1254
1255    begin
1256       if Empty_Buffer then
1257
1258          --  Force a read on the process if there is anything waiting
1259
1260          Expect_Internal
1261            (Descriptors, Result, Timeout => 0, Full_Buffer => False);
1262
1263          if Result = Expect_Internal_Error
1264            or else Result = Expect_Process_Died
1265          then
1266             raise Process_Died;
1267          end if;
1268
1269          Descriptor.Last_Match_End := Descriptor.Buffer_Index;
1270
1271          --  Empty the buffer
1272
1273          Reinitialize_Buffer (Descriptor);
1274       end if;
1275
1276       Call_Filters (Descriptor, Str, Input);
1277       Discard :=
1278         Write (Descriptor.Input_Fd, Str'Address, Str'Last - Str'First + 1);
1279
1280       if Add_LF then
1281          Call_Filters (Descriptor, Line_Feed, Input);
1282          Discard :=
1283            Write (Descriptor.Input_Fd, Line_Feed'Address, 1);
1284       end if;
1285    end Send;
1286
1287    -----------------
1288    -- Send_Signal --
1289    -----------------
1290
1291    procedure Send_Signal
1292      (Descriptor : Process_Descriptor;
1293       Signal     : Integer)
1294    is
1295    begin
1296       --  A nonpositive process id passed to kill has special meanings. For
1297       --  example, -1 means kill all processes in sight, including self, in
1298       --  POSIX and Windows (and something slightly different in Linux). See
1299       --  man pages for details. In any case, we don't want to do that. Note
1300       --  that Descriptor.Pid will be -1 if the process was not successfully
1301       --  started; we don't want to kill ourself in that case.
1302
1303       if Descriptor.Pid > 0 then
1304          Kill (Descriptor.Pid, Signal, Close => 1);
1305          --  ??? Need to check process status here
1306       else
1307          raise Invalid_Process;
1308       end if;
1309    end Send_Signal;
1310
1311    ---------------------------------
1312    -- Set_Up_Child_Communications --
1313    ---------------------------------
1314
1315    procedure Set_Up_Child_Communications
1316      (Pid   : in out Process_Descriptor;
1317       Pipe1 : in out Pipe_Type;
1318       Pipe2 : in out Pipe_Type;
1319       Pipe3 : in out Pipe_Type;
1320       Cmd   : String;
1321       Args  : System.Address)
1322    is
1323       pragma Warnings (Off, Pid);
1324       pragma Warnings (Off, Pipe1);
1325       pragma Warnings (Off, Pipe2);
1326       pragma Warnings (Off, Pipe3);
1327
1328       Input  : File_Descriptor;
1329       Output : File_Descriptor;
1330       Error  : File_Descriptor;
1331
1332       No_Fork_On_Target : constant Boolean := Target_OS = Windows;
1333
1334    begin
1335       if No_Fork_On_Target then
1336
1337          --  Since Windows does not have a separate fork/exec, we need to
1338          --  perform the following actions:
1339
1340          --    - save stdin, stdout, stderr
1341          --    - replace them by our pipes
1342          --    - create the child with process handle inheritance
1343          --    - revert to the previous stdin, stdout and stderr.
1344
1345          Input  := Dup (GNAT.OS_Lib.Standin);
1346          Output := Dup (GNAT.OS_Lib.Standout);
1347          Error  := Dup (GNAT.OS_Lib.Standerr);
1348       end if;
1349
1350       --  Since we are still called from the parent process, there is no way
1351       --  currently we can cleanly close the unneeded ends of the pipes, but
1352       --  this doesn't really matter.
1353
1354       --  We could close Pipe1.Output, Pipe2.Input, Pipe3.Input
1355
1356       Dup2 (Pipe1.Input,  GNAT.OS_Lib.Standin);
1357       Dup2 (Pipe2.Output, GNAT.OS_Lib.Standout);
1358       Dup2 (Pipe3.Output, GNAT.OS_Lib.Standerr);
1359
1360       Portable_Execvp (Pid.Pid'Access, Cmd & ASCII.NUL, Args);
1361
1362       --  The following lines are only required for Windows systems and will
1363       --  not be executed on Unix systems, but we use the same condition as
1364       --  above to avoid warnings on uninitialized variables on Unix systems.
1365       --  We are now in the parent process.
1366
1367       if No_Fork_On_Target then
1368
1369          --  Restore the old descriptors
1370
1371          Dup2 (Input,  GNAT.OS_Lib.Standin);
1372          Dup2 (Output, GNAT.OS_Lib.Standout);
1373          Dup2 (Error,  GNAT.OS_Lib.Standerr);
1374          Close (Input);
1375          Close (Output);
1376          Close (Error);
1377       end if;
1378    end Set_Up_Child_Communications;
1379
1380    ---------------------------
1381    -- Set_Up_Communications --
1382    ---------------------------
1383
1384    procedure Set_Up_Communications
1385      (Pid        : in out Process_Descriptor;
1386       Err_To_Out : Boolean;
1387       Pipe1      : not null access Pipe_Type;
1388       Pipe2      : not null access Pipe_Type;
1389       Pipe3      : not null access Pipe_Type)
1390    is
1391       Status : Boolean;
1392       pragma Unreferenced (Status);
1393
1394    begin
1395       --  Create the pipes
1396
1397       if Create_Pipe (Pipe1) /= 0 then
1398          return;
1399       end if;
1400
1401       if Create_Pipe (Pipe2) /= 0 then
1402          Close (Pipe1.Input);
1403          Close (Pipe1.Output);
1404          return;
1405       end if;
1406
1407       --  Record the 'parent' end of the two pipes in Pid:
1408       --    Child stdin  is connected to the 'write' end of Pipe1;
1409       --    Child stdout is connected to the 'read'  end of Pipe2.
1410       --  We do not want these descriptors to remain open in the child
1411       --  process, so we mark them close-on-exec/non-inheritable.
1412
1413       Pid.Input_Fd  := Pipe1.Output;
1414       Set_Close_On_Exec (Pipe1.Output, True, Status);
1415       Pid.Output_Fd := Pipe2.Input;
1416       Set_Close_On_Exec (Pipe2.Input, True, Status);
1417
1418       if Err_To_Out then
1419
1420          --  Reuse the standard output pipe for standard error
1421
1422          Pipe3.all := Pipe2.all;
1423
1424       else
1425          --  Create a separate pipe for standard error
1426
1427          if Create_Pipe (Pipe3) /= 0 then
1428             Pipe3.all := Pipe2.all;
1429          end if;
1430       end if;
1431
1432       --  As above, record the proper fd for the child's standard error stream
1433
1434       Pid.Error_Fd := Pipe3.Input;
1435       Set_Close_On_Exec (Pipe3.Input, True, Status);
1436    end Set_Up_Communications;
1437
1438    ----------------------------------
1439    -- Set_Up_Parent_Communications --
1440    ----------------------------------
1441
1442    procedure Set_Up_Parent_Communications
1443      (Pid   : in out Process_Descriptor;
1444       Pipe1 : in out Pipe_Type;
1445       Pipe2 : in out Pipe_Type;
1446       Pipe3 : in out Pipe_Type)
1447    is
1448       pragma Warnings (Off, Pid);
1449       pragma Warnings (Off, Pipe1);
1450       pragma Warnings (Off, Pipe2);
1451       pragma Warnings (Off, Pipe3);
1452
1453    begin
1454       Close (Pipe1.Input);
1455       Close (Pipe2.Output);
1456
1457       if Pipe3.Output /= Pipe2.Output then
1458          Close (Pipe3.Output);
1459       end if;
1460    end Set_Up_Parent_Communications;
1461
1462    ------------------
1463    -- Trace_Filter --
1464    ------------------
1465
1466    procedure Trace_Filter
1467      (Descriptor : Process_Descriptor'Class;
1468       Str        : String;
1469       User_Data  : System.Address := System.Null_Address)
1470    is
1471       pragma Warnings (Off, Descriptor);
1472       pragma Warnings (Off, User_Data);
1473    begin
1474       GNAT.IO.Put (Str);
1475    end Trace_Filter;
1476
1477    --------------------
1478    -- Unlock_Filters --
1479    --------------------
1480
1481    procedure Unlock_Filters (Descriptor : in out Process_Descriptor) is
1482    begin
1483       if Descriptor.Filters_Lock > 0 then
1484          Descriptor.Filters_Lock := Descriptor.Filters_Lock - 1;
1485       end if;
1486    end Unlock_Filters;
1487
1488 end GNAT.Expect;