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