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