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