gcc/ada/g-expect-vms.adb

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