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