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