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