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