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