gcc/ada/g-expect.adb

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