gcc/ada/3vexpect.adb

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