1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- S Y S T E M . O S _ L I B -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1995-2013, 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 32pragma Compiler_Unit; 33 34with Ada.Unchecked_Conversion; 35with Ada.Unchecked_Deallocation; 36with System; use System; 37with System.Case_Util; 38with System.CRTL; 39with System.Soft_Links; 40 41package body System.OS_Lib is 42 43 -- Imported procedures Dup and Dup2 are used in procedures Spawn and 44 -- Non_Blocking_Spawn. 45 46 function Dup (Fd : File_Descriptor) return File_Descriptor; 47 pragma Import (C, Dup, "__gnat_dup"); 48 49 procedure Dup2 (Old_Fd, New_Fd : File_Descriptor); 50 pragma Import (C, Dup2, "__gnat_dup2"); 51 52 On_Windows : constant Boolean := Directory_Separator = '\'; 53 -- An indication that we are on Windows. Used in Normalize_Pathname, to 54 -- deal with drive letters in the beginning of absolute paths. 55 56 package SSL renames System.Soft_Links; 57 58 -- The following are used by Create_Temp_File 59 60 First_Temp_File_Name : constant String := "GNAT-TEMP-000000.TMP"; 61 -- Used to initialize Current_Temp_File_Name and Temp_File_Name_Last_Digit 62 63 Current_Temp_File_Name : String := First_Temp_File_Name; 64 -- Name of the temp file last created 65 66 Temp_File_Name_Last_Digit : constant Positive := 67 First_Temp_File_Name'Last - 4; 68 -- Position of the last digit in Current_Temp_File_Name 69 70 Max_Attempts : constant := 100; 71 -- The maximum number of attempts to create a new temp file 72 73 ----------------------- 74 -- Local Subprograms -- 75 ----------------------- 76 77 function Args_Length (Args : Argument_List) return Natural; 78 -- Returns total number of characters needed to create a string of all Args 79 -- terminated by ASCII.NUL characters. 80 81 procedure Create_Temp_File_Internal 82 (FD : out File_Descriptor; 83 Name : out String_Access; 84 Stdout : Boolean); 85 -- Internal routine to implement two Create_Temp_File routines. If Stdout 86 -- is set to True the created descriptor is stdout-compatible, otherwise 87 -- it might not be depending on the OS (VMS is one example). The first two 88 -- parameters are as in Create_Temp_File. 89 90 function C_String_Length (S : Address) return Integer; 91 -- Returns the length of a C string. Does check for null address 92 -- (returns 0). 93 94 procedure Spawn_Internal 95 (Program_Name : String; 96 Args : Argument_List; 97 Result : out Integer; 98 Pid : out Process_Id; 99 Blocking : Boolean); 100 -- Internal routine to implement the two Spawn (blocking/non blocking) 101 -- routines. If Blocking is set to True then the spawn is blocking 102 -- otherwise it is non blocking. In this latter case the Pid contains the 103 -- process id number. The first three parameters are as in Spawn. Note that 104 -- Spawn_Internal normalizes the argument list before calling the low level 105 -- system spawn routines (see Normalize_Arguments). 106 -- 107 -- Note: Normalize_Arguments is designed to do nothing if it is called more 108 -- than once, so calling Normalize_Arguments before calling one of the 109 -- spawn routines is fine. 110 111 function To_Path_String_Access 112 (Path_Addr : Address; 113 Path_Len : Integer) return String_Access; 114 -- Converts a C String to an Ada String. We could do this making use of 115 -- Interfaces.C.Strings but we prefer not to import that entire package 116 117 --------- 118 -- "<" -- 119 --------- 120 121 function "<" (X, Y : OS_Time) return Boolean is 122 begin 123 return Long_Integer (X) < Long_Integer (Y); 124 end "<"; 125 126 ---------- 127 -- "<=" -- 128 ---------- 129 130 function "<=" (X, Y : OS_Time) return Boolean is 131 begin 132 return Long_Integer (X) <= Long_Integer (Y); 133 end "<="; 134 135 --------- 136 -- ">" -- 137 --------- 138 139 function ">" (X, Y : OS_Time) return Boolean is 140 begin 141 return Long_Integer (X) > Long_Integer (Y); 142 end ">"; 143 144 ---------- 145 -- ">=" -- 146 ---------- 147 148 function ">=" (X, Y : OS_Time) return Boolean is 149 begin 150 return Long_Integer (X) >= Long_Integer (Y); 151 end ">="; 152 153 ----------------- 154 -- Args_Length -- 155 ----------------- 156 157 function Args_Length (Args : Argument_List) return Natural is 158 Len : Natural := 0; 159 160 begin 161 for J in Args'Range loop 162 Len := Len + Args (J)'Length + 1; -- One extra for ASCII.NUL 163 end loop; 164 165 return Len; 166 end Args_Length; 167 168 ----------------------------- 169 -- Argument_String_To_List -- 170 ----------------------------- 171 172 function Argument_String_To_List 173 (Arg_String : String) return Argument_List_Access 174 is 175 Max_Args : constant Integer := Arg_String'Length; 176 New_Argv : Argument_List (1 .. Max_Args); 177 New_Argc : Natural := 0; 178 Idx : Integer; 179 180 begin 181 Idx := Arg_String'First; 182 183 loop 184 exit when Idx > Arg_String'Last; 185 186 declare 187 Quoted : Boolean := False; 188 Backqd : Boolean := False; 189 Old_Idx : Integer; 190 191 begin 192 Old_Idx := Idx; 193 194 loop 195 -- An unquoted space is the end of an argument 196 197 if not (Backqd or Quoted) 198 and then Arg_String (Idx) = ' ' 199 then 200 exit; 201 202 -- Start of a quoted string 203 204 elsif not (Backqd or Quoted) 205 and then Arg_String (Idx) = '"' 206 then 207 Quoted := True; 208 209 -- End of a quoted string and end of an argument 210 211 elsif (Quoted and not Backqd) 212 and then Arg_String (Idx) = '"' 213 then 214 Idx := Idx + 1; 215 exit; 216 217 -- Following character is backquoted 218 219 elsif Arg_String (Idx) = '\' then 220 Backqd := True; 221 222 -- Turn off backquoting after advancing one character 223 224 elsif Backqd then 225 Backqd := False; 226 227 end if; 228 229 Idx := Idx + 1; 230 exit when Idx > Arg_String'Last; 231 end loop; 232 233 -- Found an argument 234 235 New_Argc := New_Argc + 1; 236 New_Argv (New_Argc) := 237 new String'(Arg_String (Old_Idx .. Idx - 1)); 238 239 -- Skip extraneous spaces 240 241 while Idx <= Arg_String'Last and then Arg_String (Idx) = ' ' loop 242 Idx := Idx + 1; 243 end loop; 244 end; 245 end loop; 246 247 return new Argument_List'(New_Argv (1 .. New_Argc)); 248 end Argument_String_To_List; 249 250 --------------------- 251 -- C_String_Length -- 252 --------------------- 253 254 function C_String_Length (S : Address) return Integer is 255 function Strlen (S : Address) return Integer; 256 pragma Import (C, Strlen, "strlen"); 257 begin 258 if S = Null_Address then 259 return 0; 260 else 261 return Strlen (S); 262 end if; 263 end C_String_Length; 264 265 ----------- 266 -- Close -- 267 ----------- 268 269 procedure Close (FD : File_Descriptor) is 270 procedure C_Close (FD : File_Descriptor); 271 pragma Import (C, C_Close, "close"); 272 begin 273 C_Close (FD); 274 end Close; 275 276 procedure Close (FD : File_Descriptor; Status : out Boolean) is 277 function C_Close (FD : File_Descriptor) return Integer; 278 pragma Import (C, C_Close, "close"); 279 begin 280 Status := (C_Close (FD) = 0); 281 end Close; 282 283 --------------- 284 -- Copy_File -- 285 --------------- 286 287 procedure Copy_File 288 (Name : String; 289 Pathname : String; 290 Success : out Boolean; 291 Mode : Copy_Mode := Copy; 292 Preserve : Attribute := Time_Stamps) 293 is 294 From : File_Descriptor; 295 To : File_Descriptor; 296 297 Copy_Error : exception; 298 -- Internal exception raised to signal error in copy 299 300 function Build_Path (Dir : String; File : String) return String; 301 -- Returns pathname Dir concatenated with File adding the directory 302 -- separator only if needed. 303 304 procedure Copy (From, To : File_Descriptor); 305 -- Read data from From and place them into To. In both cases the 306 -- operations uses the current file position. Raises Constraint_Error 307 -- if a problem occurs during the copy. 308 309 procedure Copy_To (To_Name : String); 310 -- Does a straight copy from source to designated destination file 311 312 ---------------- 313 -- Build_Path -- 314 ---------------- 315 316 function Build_Path (Dir : String; File : String) return String is 317 Res : String (1 .. Dir'Length + File'Length + 1); 318 319 Base_File_Ptr : Integer; 320 -- The base file name is File (Base_File_Ptr + 1 .. File'Last) 321 322 function Is_Dirsep (C : Character) return Boolean; 323 pragma Inline (Is_Dirsep); 324 -- Returns True if C is a directory separator. On Windows we 325 -- handle both styles of directory separator. 326 327 --------------- 328 -- Is_Dirsep -- 329 --------------- 330 331 function Is_Dirsep (C : Character) return Boolean is 332 begin 333 return C = Directory_Separator or else C = '/'; 334 end Is_Dirsep; 335 336 -- Start of processing for Build_Path 337 338 begin 339 -- Find base file name 340 341 Base_File_Ptr := File'Last; 342 while Base_File_Ptr >= File'First loop 343 exit when Is_Dirsep (File (Base_File_Ptr)); 344 Base_File_Ptr := Base_File_Ptr - 1; 345 end loop; 346 347 declare 348 Base_File : String renames 349 File (Base_File_Ptr + 1 .. File'Last); 350 351 begin 352 Res (1 .. Dir'Length) := Dir; 353 354 if Is_Dirsep (Dir (Dir'Last)) then 355 Res (Dir'Length + 1 .. Dir'Length + Base_File'Length) := 356 Base_File; 357 return Res (1 .. Dir'Length + Base_File'Length); 358 359 else 360 Res (Dir'Length + 1) := Directory_Separator; 361 Res (Dir'Length + 2 .. Dir'Length + 1 + Base_File'Length) := 362 Base_File; 363 return Res (1 .. Dir'Length + 1 + Base_File'Length); 364 end if; 365 end; 366 end Build_Path; 367 368 ---------- 369 -- Copy -- 370 ---------- 371 372 procedure Copy (From, To : File_Descriptor) is 373 Buf_Size : constant := 200_000; 374 type Buf is array (1 .. Buf_Size) of Character; 375 type Buf_Ptr is access Buf; 376 377 Buffer : Buf_Ptr; 378 R : Integer; 379 W : Integer; 380 381 Status_From : Boolean; 382 Status_To : Boolean; 383 -- Statuses for the calls to Close 384 385 procedure Free is new Ada.Unchecked_Deallocation (Buf, Buf_Ptr); 386 387 begin 388 -- Check for invalid descriptors, making sure that we do not 389 -- accidentally leave an open file descriptor around. 390 391 if From = Invalid_FD then 392 if To /= Invalid_FD then 393 Close (To, Status_To); 394 end if; 395 396 raise Copy_Error; 397 398 elsif To = Invalid_FD then 399 Close (From, Status_From); 400 raise Copy_Error; 401 end if; 402 403 -- Allocate the buffer on the heap 404 405 Buffer := new Buf; 406 407 loop 408 R := Read (From, Buffer (1)'Address, Buf_Size); 409 410 -- For VMS, the buffer may not be full. So, we need to try again 411 -- until there is nothing to read. 412 413 exit when R = 0; 414 415 W := Write (To, Buffer (1)'Address, R); 416 417 if W < R then 418 419 -- Problem writing data, could be a disk full. Close files 420 -- without worrying about status, since we are raising a 421 -- Copy_Error exception in any case. 422 423 Close (From, Status_From); 424 Close (To, Status_To); 425 426 Free (Buffer); 427 428 raise Copy_Error; 429 end if; 430 end loop; 431 432 Close (From, Status_From); 433 Close (To, Status_To); 434 435 Free (Buffer); 436 437 if not (Status_From and Status_To) then 438 raise Copy_Error; 439 end if; 440 end Copy; 441 442 ------------- 443 -- Copy_To -- 444 ------------- 445 446 procedure Copy_To (To_Name : String) is 447 448 function Copy_Attributes 449 (From, To : System.Address; 450 Mode : Integer) return Integer; 451 pragma Import (C, Copy_Attributes, "__gnat_copy_attribs"); 452 -- Mode = 0 - copy only time stamps. 453 -- Mode = 1 - copy time stamps and read/write/execute attributes 454 455 C_From : String (1 .. Name'Length + 1); 456 C_To : String (1 .. To_Name'Length + 1); 457 458 begin 459 From := Open_Read (Name, Binary); 460 461 -- Do not clobber destination file if source file could not be opened 462 463 if From /= Invalid_FD then 464 To := Create_File (To_Name, Binary); 465 end if; 466 467 Copy (From, To); 468 469 -- Copy attributes 470 471 C_From (1 .. Name'Length) := Name; 472 C_From (C_From'Last) := ASCII.NUL; 473 474 C_To (1 .. To_Name'Length) := To_Name; 475 C_To (C_To'Last) := ASCII.NUL; 476 477 case Preserve is 478 479 when Time_Stamps => 480 if Copy_Attributes (C_From'Address, C_To'Address, 0) = -1 then 481 raise Copy_Error; 482 end if; 483 484 when Full => 485 if Copy_Attributes (C_From'Address, C_To'Address, 1) = -1 then 486 raise Copy_Error; 487 end if; 488 489 when None => 490 null; 491 end case; 492 493 end Copy_To; 494 495 -- Start of processing for Copy_File 496 497 begin 498 Success := True; 499 500 -- The source file must exist 501 502 if not Is_Regular_File (Name) then 503 raise Copy_Error; 504 end if; 505 506 -- The source file exists 507 508 case Mode is 509 510 -- Copy case, target file must not exist 511 512 when Copy => 513 514 -- If the target file exists, we have an error 515 516 if Is_Regular_File (Pathname) then 517 raise Copy_Error; 518 519 -- Case of target is a directory 520 521 elsif Is_Directory (Pathname) then 522 declare 523 Dest : constant String := Build_Path (Pathname, Name); 524 525 begin 526 -- If target file exists, we have an error, else do copy 527 528 if Is_Regular_File (Dest) then 529 raise Copy_Error; 530 else 531 Copy_To (Dest); 532 end if; 533 end; 534 535 -- Case of normal copy to file (destination does not exist) 536 537 else 538 Copy_To (Pathname); 539 end if; 540 541 -- Overwrite case (destination file may or may not exist) 542 543 when Overwrite => 544 if Is_Directory (Pathname) then 545 Copy_To (Build_Path (Pathname, Name)); 546 else 547 Copy_To (Pathname); 548 end if; 549 550 -- Append case (destination file may or may not exist) 551 552 when Append => 553 554 -- Appending to existing file 555 556 if Is_Regular_File (Pathname) then 557 558 -- Append mode and destination file exists, append data at the 559 -- end of Pathname. But if we fail to open source file, do not 560 -- touch destination file at all. 561 562 From := Open_Read (Name, Binary); 563 if From /= Invalid_FD then 564 To := Open_Read_Write (Pathname, Binary); 565 end if; 566 567 Lseek (To, 0, Seek_End); 568 569 Copy (From, To); 570 571 -- Appending to directory, not allowed 572 573 elsif Is_Directory (Pathname) then 574 raise Copy_Error; 575 576 -- Appending when target file does not exist 577 578 else 579 Copy_To (Pathname); 580 end if; 581 end case; 582 583 -- All error cases are caught here 584 585 exception 586 when Copy_Error => 587 Success := False; 588 end Copy_File; 589 590 procedure Copy_File 591 (Name : C_File_Name; 592 Pathname : C_File_Name; 593 Success : out Boolean; 594 Mode : Copy_Mode := Copy; 595 Preserve : Attribute := Time_Stamps) 596 is 597 Ada_Name : String_Access := 598 To_Path_String_Access 599 (Name, C_String_Length (Name)); 600 Ada_Pathname : String_Access := 601 To_Path_String_Access 602 (Pathname, C_String_Length (Pathname)); 603 begin 604 Copy_File (Ada_Name.all, Ada_Pathname.all, Success, Mode, Preserve); 605 Free (Ada_Name); 606 Free (Ada_Pathname); 607 end Copy_File; 608 609 ---------------------- 610 -- Copy_Time_Stamps -- 611 ---------------------- 612 613 procedure Copy_Time_Stamps (Source, Dest : String; Success : out Boolean) is 614 615 function Copy_Attributes 616 (From, To : System.Address; 617 Mode : Integer) return Integer; 618 pragma Import (C, Copy_Attributes, "__gnat_copy_attribs"); 619 -- Mode = 0 - copy only time stamps. 620 -- Mode = 1 - copy time stamps and read/write/execute attributes 621 622 begin 623 if Is_Regular_File (Source) and then Is_Writable_File (Dest) then 624 declare 625 C_Source : String (1 .. Source'Length + 1); 626 C_Dest : String (1 .. Dest'Length + 1); 627 628 begin 629 C_Source (1 .. Source'Length) := Source; 630 C_Source (C_Source'Last) := ASCII.NUL; 631 632 C_Dest (1 .. Dest'Length) := Dest; 633 C_Dest (C_Dest'Last) := ASCII.NUL; 634 635 if Copy_Attributes (C_Source'Address, C_Dest'Address, 0) = -1 then 636 Success := False; 637 else 638 Success := True; 639 end if; 640 end; 641 642 else 643 Success := False; 644 end if; 645 end Copy_Time_Stamps; 646 647 procedure Copy_Time_Stamps 648 (Source, Dest : C_File_Name; 649 Success : out Boolean) 650 is 651 Ada_Source : String_Access := 652 To_Path_String_Access 653 (Source, C_String_Length (Source)); 654 Ada_Dest : String_Access := 655 To_Path_String_Access 656 (Dest, C_String_Length (Dest)); 657 begin 658 Copy_Time_Stamps (Ada_Source.all, Ada_Dest.all, Success); 659 Free (Ada_Source); 660 Free (Ada_Dest); 661 end Copy_Time_Stamps; 662 663 ----------------- 664 -- Create_File -- 665 ----------------- 666 667 function Create_File 668 (Name : C_File_Name; 669 Fmode : Mode) return File_Descriptor 670 is 671 function C_Create_File 672 (Name : C_File_Name; 673 Fmode : Mode) return File_Descriptor; 674 pragma Import (C, C_Create_File, "__gnat_open_create"); 675 676 begin 677 return C_Create_File (Name, Fmode); 678 end Create_File; 679 680 function Create_File 681 (Name : String; 682 Fmode : Mode) return File_Descriptor 683 is 684 C_Name : String (1 .. Name'Length + 1); 685 686 begin 687 C_Name (1 .. Name'Length) := Name; 688 C_Name (C_Name'Last) := ASCII.NUL; 689 return Create_File (C_Name (C_Name'First)'Address, Fmode); 690 end Create_File; 691 692 --------------------- 693 -- Create_New_File -- 694 --------------------- 695 696 function Create_New_File 697 (Name : C_File_Name; 698 Fmode : Mode) return File_Descriptor 699 is 700 function C_Create_New_File 701 (Name : C_File_Name; 702 Fmode : Mode) return File_Descriptor; 703 pragma Import (C, C_Create_New_File, "__gnat_open_new"); 704 705 begin 706 return C_Create_New_File (Name, Fmode); 707 end Create_New_File; 708 709 function Create_New_File 710 (Name : String; 711 Fmode : Mode) return File_Descriptor 712 is 713 C_Name : String (1 .. Name'Length + 1); 714 715 begin 716 C_Name (1 .. Name'Length) := Name; 717 C_Name (C_Name'Last) := ASCII.NUL; 718 return Create_New_File (C_Name (C_Name'First)'Address, Fmode); 719 end Create_New_File; 720 721 ----------------------------- 722 -- Create_Output_Text_File -- 723 ----------------------------- 724 725 function Create_Output_Text_File (Name : String) return File_Descriptor is 726 function C_Create_File 727 (Name : C_File_Name) return File_Descriptor; 728 pragma Import (C, C_Create_File, "__gnat_create_output_file"); 729 730 C_Name : String (1 .. Name'Length + 1); 731 732 begin 733 C_Name (1 .. Name'Length) := Name; 734 C_Name (C_Name'Last) := ASCII.NUL; 735 return C_Create_File (C_Name (C_Name'First)'Address); 736 end Create_Output_Text_File; 737 738 ---------------------- 739 -- Create_Temp_File -- 740 ---------------------- 741 742 procedure Create_Temp_File 743 (FD : out File_Descriptor; 744 Name : out Temp_File_Name) 745 is 746 function Open_New_Temp 747 (Name : System.Address; 748 Fmode : Mode) return File_Descriptor; 749 pragma Import (C, Open_New_Temp, "__gnat_open_new_temp"); 750 751 begin 752 FD := Open_New_Temp (Name'Address, Binary); 753 end Create_Temp_File; 754 755 procedure Create_Temp_File 756 (FD : out File_Descriptor; 757 Name : out String_Access) 758 is 759 begin 760 Create_Temp_File_Internal (FD, Name, Stdout => False); 761 end Create_Temp_File; 762 763 procedure Create_Temp_Output_File 764 (FD : out File_Descriptor; 765 Name : out String_Access) 766 is 767 begin 768 Create_Temp_File_Internal (FD, Name, Stdout => True); 769 end Create_Temp_Output_File; 770 771 ------------------------------- 772 -- Create_Temp_File_Internal -- 773 ------------------------------- 774 775 procedure Create_Temp_File_Internal 776 (FD : out File_Descriptor; 777 Name : out String_Access; 778 Stdout : Boolean) 779 is 780 Pos : Positive; 781 Attempts : Natural := 0; 782 Current : String (Current_Temp_File_Name'Range); 783 784 --------------------------------- 785 -- Create_New_Output_Text_File -- 786 --------------------------------- 787 788 function Create_New_Output_Text_File 789 (Name : String) return File_Descriptor; 790 -- Similar to Create_Output_Text_File, except it fails if the file 791 -- already exists. We need this behavior to ensure we don't accidentally 792 -- open a temp file that has just been created by a concurrently running 793 -- process. There is no point exposing this function, as it's generally 794 -- not particularly useful. 795 796 function Create_New_Output_Text_File 797 (Name : String) return File_Descriptor is 798 function C_Create_File 799 (Name : C_File_Name) return File_Descriptor; 800 pragma Import (C, C_Create_File, "__gnat_create_output_file_new"); 801 802 C_Name : String (1 .. Name'Length + 1); 803 804 begin 805 C_Name (1 .. Name'Length) := Name; 806 C_Name (C_Name'Last) := ASCII.NUL; 807 return C_Create_File (C_Name (C_Name'First)'Address); 808 end Create_New_Output_Text_File; 809 810 begin 811 -- Loop until a new temp file can be created 812 813 File_Loop : loop 814 Locked : begin 815 -- We need to protect global variable Current_Temp_File_Name 816 -- against concurrent access by different tasks. 817 818 SSL.Lock_Task.all; 819 820 -- Start at the last digit 821 822 Pos := Temp_File_Name_Last_Digit; 823 824 Digit_Loop : 825 loop 826 -- Increment the digit by one 827 828 case Current_Temp_File_Name (Pos) is 829 when '0' .. '8' => 830 Current_Temp_File_Name (Pos) := 831 Character'Succ (Current_Temp_File_Name (Pos)); 832 exit Digit_Loop; 833 834 when '9' => 835 836 -- For 9, set the digit to 0 and go to the previous digit 837 838 Current_Temp_File_Name (Pos) := '0'; 839 Pos := Pos - 1; 840 841 when others => 842 843 -- If it is not a digit, then there are no available 844 -- temp file names. Return Invalid_FD. There is almost 845 -- no chance that this code will be ever be executed, 846 -- since it would mean that there are one million temp 847 -- files in the same directory! 848 849 SSL.Unlock_Task.all; 850 FD := Invalid_FD; 851 Name := null; 852 exit File_Loop; 853 end case; 854 end loop Digit_Loop; 855 856 Current := Current_Temp_File_Name; 857 858 -- We can now release the lock, because we are no longer 859 -- accessing Current_Temp_File_Name. 860 861 SSL.Unlock_Task.all; 862 863 exception 864 when others => 865 SSL.Unlock_Task.all; 866 raise; 867 end Locked; 868 869 -- Attempt to create the file 870 871 if Stdout then 872 FD := Create_New_Output_Text_File (Current); 873 else 874 FD := Create_New_File (Current, Binary); 875 end if; 876 877 if FD /= Invalid_FD then 878 Name := new String'(Current); 879 exit File_Loop; 880 end if; 881 882 if not Is_Regular_File (Current) then 883 884 -- If the file does not already exist and we are unable to create 885 -- it, we give up after Max_Attempts. Otherwise, we try again with 886 -- the next available file name. 887 888 Attempts := Attempts + 1; 889 890 if Attempts >= Max_Attempts then 891 FD := Invalid_FD; 892 Name := null; 893 exit File_Loop; 894 end if; 895 end if; 896 end loop File_Loop; 897 end Create_Temp_File_Internal; 898 899 ----------------- 900 -- Delete_File -- 901 ----------------- 902 903 procedure Delete_File (Name : Address; Success : out Boolean) is 904 R : Integer; 905 begin 906 R := System.CRTL.unlink (Name); 907 Success := (R = 0); 908 end Delete_File; 909 910 procedure Delete_File (Name : String; Success : out Boolean) is 911 C_Name : String (1 .. Name'Length + 1); 912 913 begin 914 C_Name (1 .. Name'Length) := Name; 915 C_Name (C_Name'Last) := ASCII.NUL; 916 917 Delete_File (C_Name'Address, Success); 918 end Delete_File; 919 920 --------------------- 921 -- File_Time_Stamp -- 922 --------------------- 923 924 function File_Time_Stamp (FD : File_Descriptor) return OS_Time is 925 function File_Time (FD : File_Descriptor) return OS_Time; 926 pragma Import (C, File_Time, "__gnat_file_time_fd"); 927 begin 928 return File_Time (FD); 929 end File_Time_Stamp; 930 931 function File_Time_Stamp (Name : C_File_Name) return OS_Time is 932 function File_Time (Name : Address) return OS_Time; 933 pragma Import (C, File_Time, "__gnat_file_time_name"); 934 begin 935 return File_Time (Name); 936 end File_Time_Stamp; 937 938 function File_Time_Stamp (Name : String) return OS_Time is 939 F_Name : String (1 .. Name'Length + 1); 940 begin 941 F_Name (1 .. Name'Length) := Name; 942 F_Name (F_Name'Last) := ASCII.NUL; 943 return File_Time_Stamp (F_Name'Address); 944 end File_Time_Stamp; 945 946 --------------------------- 947 -- Get_Debuggable_Suffix -- 948 --------------------------- 949 950 function Get_Debuggable_Suffix return String_Access is 951 procedure Get_Suffix_Ptr (Length, Ptr : Address); 952 pragma Import (C, Get_Suffix_Ptr, "__gnat_get_debuggable_suffix_ptr"); 953 954 procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer); 955 pragma Import (C, Strncpy, "strncpy"); 956 957 Suffix_Ptr : Address; 958 Suffix_Length : Integer; 959 Result : String_Access; 960 961 begin 962 Get_Suffix_Ptr (Suffix_Length'Address, Suffix_Ptr'Address); 963 964 Result := new String (1 .. Suffix_Length); 965 966 if Suffix_Length > 0 then 967 Strncpy (Result.all'Address, Suffix_Ptr, Suffix_Length); 968 end if; 969 970 return Result; 971 end Get_Debuggable_Suffix; 972 973 --------------------------- 974 -- Get_Executable_Suffix -- 975 --------------------------- 976 977 function Get_Executable_Suffix return String_Access is 978 procedure Get_Suffix_Ptr (Length, Ptr : Address); 979 pragma Import (C, Get_Suffix_Ptr, "__gnat_get_executable_suffix_ptr"); 980 981 procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer); 982 pragma Import (C, Strncpy, "strncpy"); 983 984 Suffix_Ptr : Address; 985 Suffix_Length : Integer; 986 Result : String_Access; 987 988 begin 989 Get_Suffix_Ptr (Suffix_Length'Address, Suffix_Ptr'Address); 990 991 Result := new String (1 .. Suffix_Length); 992 993 if Suffix_Length > 0 then 994 Strncpy (Result.all'Address, Suffix_Ptr, Suffix_Length); 995 end if; 996 997 return Result; 998 end Get_Executable_Suffix; 999 1000 ----------------------- 1001 -- Get_Object_Suffix -- 1002 ----------------------- 1003 1004 function Get_Object_Suffix return String_Access is 1005 procedure Get_Suffix_Ptr (Length, Ptr : Address); 1006 pragma Import (C, Get_Suffix_Ptr, "__gnat_get_object_suffix_ptr"); 1007 1008 procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer); 1009 pragma Import (C, Strncpy, "strncpy"); 1010 1011 Suffix_Ptr : Address; 1012 Suffix_Length : Integer; 1013 Result : String_Access; 1014 1015 begin 1016 Get_Suffix_Ptr (Suffix_Length'Address, Suffix_Ptr'Address); 1017 1018 Result := new String (1 .. Suffix_Length); 1019 1020 if Suffix_Length > 0 then 1021 Strncpy (Result.all'Address, Suffix_Ptr, Suffix_Length); 1022 end if; 1023 1024 return Result; 1025 end Get_Object_Suffix; 1026 1027 ---------------------------------- 1028 -- Get_Target_Debuggable_Suffix -- 1029 ---------------------------------- 1030 1031 function Get_Target_Debuggable_Suffix return String_Access is 1032 Target_Exec_Ext_Ptr : Address; 1033 pragma Import 1034 (C, Target_Exec_Ext_Ptr, "__gnat_target_debuggable_extension"); 1035 1036 procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer); 1037 pragma Import (C, Strncpy, "strncpy"); 1038 1039 function Strlen (Cstring : Address) return Integer; 1040 pragma Import (C, Strlen, "strlen"); 1041 1042 Suffix_Length : Integer; 1043 Result : String_Access; 1044 1045 begin 1046 Suffix_Length := Strlen (Target_Exec_Ext_Ptr); 1047 1048 Result := new String (1 .. Suffix_Length); 1049 1050 if Suffix_Length > 0 then 1051 Strncpy (Result.all'Address, Target_Exec_Ext_Ptr, Suffix_Length); 1052 end if; 1053 1054 return Result; 1055 end Get_Target_Debuggable_Suffix; 1056 1057 ---------------------------------- 1058 -- Get_Target_Executable_Suffix -- 1059 ---------------------------------- 1060 1061 function Get_Target_Executable_Suffix return String_Access is 1062 Target_Exec_Ext_Ptr : Address; 1063 pragma Import 1064 (C, Target_Exec_Ext_Ptr, "__gnat_target_executable_extension"); 1065 1066 procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer); 1067 pragma Import (C, Strncpy, "strncpy"); 1068 1069 function Strlen (Cstring : Address) return Integer; 1070 pragma Import (C, Strlen, "strlen"); 1071 1072 Suffix_Length : Integer; 1073 Result : String_Access; 1074 1075 begin 1076 Suffix_Length := Strlen (Target_Exec_Ext_Ptr); 1077 1078 Result := new String (1 .. Suffix_Length); 1079 1080 if Suffix_Length > 0 then 1081 Strncpy (Result.all'Address, Target_Exec_Ext_Ptr, Suffix_Length); 1082 end if; 1083 1084 return Result; 1085 end Get_Target_Executable_Suffix; 1086 1087 ------------------------------ 1088 -- Get_Target_Object_Suffix -- 1089 ------------------------------ 1090 1091 function Get_Target_Object_Suffix return String_Access is 1092 Target_Object_Ext_Ptr : Address; 1093 pragma Import 1094 (C, Target_Object_Ext_Ptr, "__gnat_target_object_extension"); 1095 1096 procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer); 1097 pragma Import (C, Strncpy, "strncpy"); 1098 1099 function Strlen (Cstring : Address) return Integer; 1100 pragma Import (C, Strlen, "strlen"); 1101 1102 Suffix_Length : Integer; 1103 Result : String_Access; 1104 1105 begin 1106 Suffix_Length := Strlen (Target_Object_Ext_Ptr); 1107 1108 Result := new String (1 .. Suffix_Length); 1109 1110 if Suffix_Length > 0 then 1111 Strncpy (Result.all'Address, Target_Object_Ext_Ptr, Suffix_Length); 1112 end if; 1113 1114 return Result; 1115 end Get_Target_Object_Suffix; 1116 1117 ------------ 1118 -- Getenv -- 1119 ------------ 1120 1121 function Getenv (Name : String) return String_Access is 1122 procedure Get_Env_Value_Ptr (Name, Length, Ptr : Address); 1123 pragma Import (C, Get_Env_Value_Ptr, "__gnat_getenv"); 1124 1125 procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer); 1126 pragma Import (C, Strncpy, "strncpy"); 1127 1128 Env_Value_Ptr : aliased Address; 1129 Env_Value_Length : aliased Integer; 1130 F_Name : aliased String (1 .. Name'Length + 1); 1131 Result : String_Access; 1132 1133 begin 1134 F_Name (1 .. Name'Length) := Name; 1135 F_Name (F_Name'Last) := ASCII.NUL; 1136 1137 Get_Env_Value_Ptr 1138 (F_Name'Address, Env_Value_Length'Address, Env_Value_Ptr'Address); 1139 1140 Result := new String (1 .. Env_Value_Length); 1141 1142 if Env_Value_Length > 0 then 1143 Strncpy (Result.all'Address, Env_Value_Ptr, Env_Value_Length); 1144 end if; 1145 1146 return Result; 1147 end Getenv; 1148 1149 ------------ 1150 -- GM_Day -- 1151 ------------ 1152 1153 function GM_Day (Date : OS_Time) return Day_Type is 1154 D : Day_Type; 1155 1156 pragma Warnings (Off); 1157 Y : Year_Type; 1158 Mo : Month_Type; 1159 H : Hour_Type; 1160 Mn : Minute_Type; 1161 S : Second_Type; 1162 pragma Warnings (On); 1163 1164 begin 1165 GM_Split (Date, Y, Mo, D, H, Mn, S); 1166 return D; 1167 end GM_Day; 1168 1169 ------------- 1170 -- GM_Hour -- 1171 ------------- 1172 1173 function GM_Hour (Date : OS_Time) return Hour_Type is 1174 H : Hour_Type; 1175 1176 pragma Warnings (Off); 1177 Y : Year_Type; 1178 Mo : Month_Type; 1179 D : Day_Type; 1180 Mn : Minute_Type; 1181 S : Second_Type; 1182 pragma Warnings (On); 1183 1184 begin 1185 GM_Split (Date, Y, Mo, D, H, Mn, S); 1186 return H; 1187 end GM_Hour; 1188 1189 --------------- 1190 -- GM_Minute -- 1191 --------------- 1192 1193 function GM_Minute (Date : OS_Time) return Minute_Type is 1194 Mn : Minute_Type; 1195 1196 pragma Warnings (Off); 1197 Y : Year_Type; 1198 Mo : Month_Type; 1199 D : Day_Type; 1200 H : Hour_Type; 1201 S : Second_Type; 1202 pragma Warnings (On); 1203 1204 begin 1205 GM_Split (Date, Y, Mo, D, H, Mn, S); 1206 return Mn; 1207 end GM_Minute; 1208 1209 -------------- 1210 -- GM_Month -- 1211 -------------- 1212 1213 function GM_Month (Date : OS_Time) return Month_Type is 1214 Mo : Month_Type; 1215 1216 pragma Warnings (Off); 1217 Y : Year_Type; 1218 D : Day_Type; 1219 H : Hour_Type; 1220 Mn : Minute_Type; 1221 S : Second_Type; 1222 pragma Warnings (On); 1223 1224 begin 1225 GM_Split (Date, Y, Mo, D, H, Mn, S); 1226 return Mo; 1227 end GM_Month; 1228 1229 --------------- 1230 -- GM_Second -- 1231 --------------- 1232 1233 function GM_Second (Date : OS_Time) return Second_Type is 1234 S : Second_Type; 1235 1236 pragma Warnings (Off); 1237 Y : Year_Type; 1238 Mo : Month_Type; 1239 D : Day_Type; 1240 H : Hour_Type; 1241 Mn : Minute_Type; 1242 pragma Warnings (On); 1243 1244 begin 1245 GM_Split (Date, Y, Mo, D, H, Mn, S); 1246 return S; 1247 end GM_Second; 1248 1249 -------------- 1250 -- GM_Split -- 1251 -------------- 1252 1253 procedure GM_Split 1254 (Date : OS_Time; 1255 Year : out Year_Type; 1256 Month : out Month_Type; 1257 Day : out Day_Type; 1258 Hour : out Hour_Type; 1259 Minute : out Minute_Type; 1260 Second : out Second_Type) 1261 is 1262 procedure To_GM_Time 1263 (P_Time_T, P_Year, P_Month, P_Day, P_Hours, P_Mins, P_Secs : Address); 1264 pragma Import (C, To_GM_Time, "__gnat_to_gm_time"); 1265 1266 T : OS_Time := Date; 1267 Y : Integer; 1268 Mo : Integer; 1269 D : Integer; 1270 H : Integer; 1271 Mn : Integer; 1272 S : Integer; 1273 1274 begin 1275 -- Use the global lock because To_GM_Time is not thread safe 1276 1277 Locked_Processing : begin 1278 SSL.Lock_Task.all; 1279 To_GM_Time 1280 (T'Address, Y'Address, Mo'Address, D'Address, 1281 H'Address, Mn'Address, S'Address); 1282 SSL.Unlock_Task.all; 1283 1284 exception 1285 when others => 1286 SSL.Unlock_Task.all; 1287 raise; 1288 end Locked_Processing; 1289 1290 Year := Y + 1900; 1291 Month := Mo + 1; 1292 Day := D; 1293 Hour := H; 1294 Minute := Mn; 1295 Second := S; 1296 end GM_Split; 1297 1298 ------------- 1299 -- GM_Year -- 1300 ------------- 1301 1302 function GM_Year (Date : OS_Time) return Year_Type is 1303 Y : Year_Type; 1304 1305 pragma Warnings (Off); 1306 Mo : Month_Type; 1307 D : Day_Type; 1308 H : Hour_Type; 1309 Mn : Minute_Type; 1310 S : Second_Type; 1311 pragma Warnings (On); 1312 1313 begin 1314 GM_Split (Date, Y, Mo, D, H, Mn, S); 1315 return Y; 1316 end GM_Year; 1317 1318 ---------------------- 1319 -- Is_Absolute_Path -- 1320 ---------------------- 1321 1322 function Is_Absolute_Path (Name : String) return Boolean is 1323 function Is_Absolute_Path 1324 (Name : Address; 1325 Length : Integer) return Integer; 1326 pragma Import (C, Is_Absolute_Path, "__gnat_is_absolute_path"); 1327 begin 1328 return Is_Absolute_Path (Name'Address, Name'Length) /= 0; 1329 end Is_Absolute_Path; 1330 1331 ------------------ 1332 -- Is_Directory -- 1333 ------------------ 1334 1335 function Is_Directory (Name : C_File_Name) return Boolean is 1336 function Is_Directory (Name : Address) return Integer; 1337 pragma Import (C, Is_Directory, "__gnat_is_directory"); 1338 begin 1339 return Is_Directory (Name) /= 0; 1340 end Is_Directory; 1341 1342 function Is_Directory (Name : String) return Boolean is 1343 F_Name : String (1 .. Name'Length + 1); 1344 begin 1345 F_Name (1 .. Name'Length) := Name; 1346 F_Name (F_Name'Last) := ASCII.NUL; 1347 return Is_Directory (F_Name'Address); 1348 end Is_Directory; 1349 1350 ---------------------- 1351 -- Is_Readable_File -- 1352 ---------------------- 1353 1354 function Is_Readable_File (Name : C_File_Name) return Boolean is 1355 function Is_Readable_File (Name : Address) return Integer; 1356 pragma Import (C, Is_Readable_File, "__gnat_is_readable_file"); 1357 begin 1358 return Is_Readable_File (Name) /= 0; 1359 end Is_Readable_File; 1360 1361 function Is_Readable_File (Name : String) return Boolean is 1362 F_Name : String (1 .. Name'Length + 1); 1363 begin 1364 F_Name (1 .. Name'Length) := Name; 1365 F_Name (F_Name'Last) := ASCII.NUL; 1366 return Is_Readable_File (F_Name'Address); 1367 end Is_Readable_File; 1368 1369 ------------------------ 1370 -- Is_Executable_File -- 1371 ------------------------ 1372 1373 function Is_Executable_File (Name : C_File_Name) return Boolean is 1374 function Is_Executable_File (Name : Address) return Integer; 1375 pragma Import (C, Is_Executable_File, "__gnat_is_executable_file"); 1376 begin 1377 return Is_Executable_File (Name) /= 0; 1378 end Is_Executable_File; 1379 1380 function Is_Executable_File (Name : String) return Boolean is 1381 F_Name : String (1 .. Name'Length + 1); 1382 begin 1383 F_Name (1 .. Name'Length) := Name; 1384 F_Name (F_Name'Last) := ASCII.NUL; 1385 return Is_Executable_File (F_Name'Address); 1386 end Is_Executable_File; 1387 1388 --------------------- 1389 -- Is_Regular_File -- 1390 --------------------- 1391 1392 function Is_Regular_File (Name : C_File_Name) return Boolean is 1393 function Is_Regular_File (Name : Address) return Integer; 1394 pragma Import (C, Is_Regular_File, "__gnat_is_regular_file"); 1395 begin 1396 return Is_Regular_File (Name) /= 0; 1397 end Is_Regular_File; 1398 1399 function Is_Regular_File (Name : String) return Boolean is 1400 F_Name : String (1 .. Name'Length + 1); 1401 begin 1402 F_Name (1 .. Name'Length) := Name; 1403 F_Name (F_Name'Last) := ASCII.NUL; 1404 return Is_Regular_File (F_Name'Address); 1405 end Is_Regular_File; 1406 1407 ---------------------- 1408 -- Is_Symbolic_Link -- 1409 ---------------------- 1410 1411 function Is_Symbolic_Link (Name : C_File_Name) return Boolean is 1412 function Is_Symbolic_Link (Name : Address) return Integer; 1413 pragma Import (C, Is_Symbolic_Link, "__gnat_is_symbolic_link"); 1414 begin 1415 return Is_Symbolic_Link (Name) /= 0; 1416 end Is_Symbolic_Link; 1417 1418 function Is_Symbolic_Link (Name : String) return Boolean is 1419 F_Name : String (1 .. Name'Length + 1); 1420 begin 1421 F_Name (1 .. Name'Length) := Name; 1422 F_Name (F_Name'Last) := ASCII.NUL; 1423 return Is_Symbolic_Link (F_Name'Address); 1424 end Is_Symbolic_Link; 1425 1426 ---------------------- 1427 -- Is_Writable_File -- 1428 ---------------------- 1429 1430 function Is_Writable_File (Name : C_File_Name) return Boolean is 1431 function Is_Writable_File (Name : Address) return Integer; 1432 pragma Import (C, Is_Writable_File, "__gnat_is_writable_file"); 1433 begin 1434 return Is_Writable_File (Name) /= 0; 1435 end Is_Writable_File; 1436 1437 function Is_Writable_File (Name : String) return Boolean is 1438 F_Name : String (1 .. Name'Length + 1); 1439 begin 1440 F_Name (1 .. Name'Length) := Name; 1441 F_Name (F_Name'Last) := ASCII.NUL; 1442 return Is_Writable_File (F_Name'Address); 1443 end Is_Writable_File; 1444 1445 ------------------------- 1446 -- Locate_Exec_On_Path -- 1447 ------------------------- 1448 1449 function Locate_Exec_On_Path 1450 (Exec_Name : String) return String_Access 1451 is 1452 function Locate_Exec_On_Path (C_Exec_Name : Address) return Address; 1453 pragma Import (C, Locate_Exec_On_Path, "__gnat_locate_exec_on_path"); 1454 1455 procedure Free (Ptr : System.Address); 1456 pragma Import (C, Free, "free"); 1457 1458 C_Exec_Name : String (1 .. Exec_Name'Length + 1); 1459 Path_Addr : Address; 1460 Path_Len : Integer; 1461 Result : String_Access; 1462 1463 begin 1464 C_Exec_Name (1 .. Exec_Name'Length) := Exec_Name; 1465 C_Exec_Name (C_Exec_Name'Last) := ASCII.NUL; 1466 1467 Path_Addr := Locate_Exec_On_Path (C_Exec_Name'Address); 1468 Path_Len := C_String_Length (Path_Addr); 1469 1470 if Path_Len = 0 then 1471 return null; 1472 1473 else 1474 Result := To_Path_String_Access (Path_Addr, Path_Len); 1475 Free (Path_Addr); 1476 1477 -- Always return an absolute path name 1478 1479 if not Is_Absolute_Path (Result.all) then 1480 declare 1481 Absolute_Path : constant String := 1482 Normalize_Pathname (Result.all, Resolve_Links => False); 1483 begin 1484 Free (Result); 1485 Result := new String'(Absolute_Path); 1486 end; 1487 end if; 1488 1489 return Result; 1490 end if; 1491 end Locate_Exec_On_Path; 1492 1493 ------------------------- 1494 -- Locate_Regular_File -- 1495 ------------------------- 1496 1497 function Locate_Regular_File 1498 (File_Name : C_File_Name; 1499 Path : C_File_Name) return String_Access 1500 is 1501 function Locate_Regular_File 1502 (C_File_Name, Path_Val : Address) return Address; 1503 pragma Import (C, Locate_Regular_File, "__gnat_locate_regular_file"); 1504 1505 procedure Free (Ptr : System.Address); 1506 pragma Import (C, Free, "free"); 1507 1508 Path_Addr : Address; 1509 Path_Len : Integer; 1510 Result : String_Access; 1511 1512 begin 1513 Path_Addr := Locate_Regular_File (File_Name, Path); 1514 Path_Len := C_String_Length (Path_Addr); 1515 1516 if Path_Len = 0 then 1517 return null; 1518 1519 else 1520 Result := To_Path_String_Access (Path_Addr, Path_Len); 1521 Free (Path_Addr); 1522 return Result; 1523 end if; 1524 end Locate_Regular_File; 1525 1526 function Locate_Regular_File 1527 (File_Name : String; 1528 Path : String) return String_Access 1529 is 1530 C_File_Name : String (1 .. File_Name'Length + 1); 1531 C_Path : String (1 .. Path'Length + 1); 1532 Result : String_Access; 1533 1534 begin 1535 C_File_Name (1 .. File_Name'Length) := File_Name; 1536 C_File_Name (C_File_Name'Last) := ASCII.NUL; 1537 1538 C_Path (1 .. Path'Length) := Path; 1539 C_Path (C_Path'Last) := ASCII.NUL; 1540 1541 Result := Locate_Regular_File (C_File_Name'Address, C_Path'Address); 1542 1543 -- Always return an absolute path name 1544 1545 if Result /= null and then not Is_Absolute_Path (Result.all) then 1546 declare 1547 Absolute_Path : constant String := Normalize_Pathname (Result.all); 1548 begin 1549 Free (Result); 1550 Result := new String'(Absolute_Path); 1551 end; 1552 end if; 1553 1554 return Result; 1555 end Locate_Regular_File; 1556 1557 ------------------------ 1558 -- Non_Blocking_Spawn -- 1559 ------------------------ 1560 1561 function Non_Blocking_Spawn 1562 (Program_Name : String; 1563 Args : Argument_List) return Process_Id 1564 is 1565 Pid : Process_Id; 1566 Junk : Integer; 1567 pragma Warnings (Off, Junk); 1568 begin 1569 Spawn_Internal (Program_Name, Args, Junk, Pid, Blocking => False); 1570 return Pid; 1571 end Non_Blocking_Spawn; 1572 1573 function Non_Blocking_Spawn 1574 (Program_Name : String; 1575 Args : Argument_List; 1576 Output_File_Descriptor : File_Descriptor; 1577 Err_To_Out : Boolean := True) return Process_Id 1578 is 1579 Saved_Output : File_Descriptor; 1580 Saved_Error : File_Descriptor := Invalid_FD; -- prevent warning 1581 Pid : Process_Id; 1582 1583 begin 1584 if Output_File_Descriptor = Invalid_FD then 1585 return Invalid_Pid; 1586 end if; 1587 1588 -- Set standard output and, if specified, error to the temporary file 1589 1590 Saved_Output := Dup (Standout); 1591 Dup2 (Output_File_Descriptor, Standout); 1592 1593 if Err_To_Out then 1594 Saved_Error := Dup (Standerr); 1595 Dup2 (Output_File_Descriptor, Standerr); 1596 end if; 1597 1598 -- Spawn the program 1599 1600 Pid := Non_Blocking_Spawn (Program_Name, Args); 1601 1602 -- Restore the standard output and error 1603 1604 Dup2 (Saved_Output, Standout); 1605 1606 if Err_To_Out then 1607 Dup2 (Saved_Error, Standerr); 1608 end if; 1609 1610 -- And close the saved standard output and error file descriptors 1611 1612 Close (Saved_Output); 1613 1614 if Err_To_Out then 1615 Close (Saved_Error); 1616 end if; 1617 1618 return Pid; 1619 end Non_Blocking_Spawn; 1620 1621 function Non_Blocking_Spawn 1622 (Program_Name : String; 1623 Args : Argument_List; 1624 Output_File : String; 1625 Err_To_Out : Boolean := True) return Process_Id 1626 is 1627 Output_File_Descriptor : constant File_Descriptor := 1628 Create_Output_Text_File (Output_File); 1629 Result : Process_Id; 1630 1631 begin 1632 -- Do not attempt to spawn if the output file could not be created 1633 1634 if Output_File_Descriptor = Invalid_FD then 1635 return Invalid_Pid; 1636 1637 else 1638 Result := Non_Blocking_Spawn 1639 (Program_Name, Args, Output_File_Descriptor, Err_To_Out); 1640 1641 -- Close the file just created for the output, as the file descriptor 1642 -- cannot be used anywhere, being a local value. It is safe to do 1643 -- that, as the file descriptor has been duplicated to form 1644 -- standard output and error of the spawned process. 1645 1646 Close (Output_File_Descriptor); 1647 1648 return Result; 1649 end if; 1650 end Non_Blocking_Spawn; 1651 1652 ------------------------- 1653 -- Normalize_Arguments -- 1654 ------------------------- 1655 1656 procedure Normalize_Arguments (Args : in out Argument_List) is 1657 1658 procedure Quote_Argument (Arg : in out String_Access); 1659 -- Add quote around argument if it contains spaces (or HT characters) 1660 1661 C_Argument_Needs_Quote : Integer; 1662 pragma Import (C, C_Argument_Needs_Quote, "__gnat_argument_needs_quote"); 1663 Argument_Needs_Quote : constant Boolean := C_Argument_Needs_Quote /= 0; 1664 1665 -------------------- 1666 -- Quote_Argument -- 1667 -------------------- 1668 1669 procedure Quote_Argument (Arg : in out String_Access) is 1670 Res : String (1 .. Arg'Length * 2); 1671 J : Positive := 1; 1672 Quote_Needed : Boolean := False; 1673 1674 begin 1675 if Arg (Arg'First) /= '"' or else Arg (Arg'Last) /= '"' then 1676 1677 -- Starting quote 1678 1679 Res (J) := '"'; 1680 1681 for K in Arg'Range loop 1682 1683 J := J + 1; 1684 1685 if Arg (K) = '"' then 1686 Res (J) := '\'; 1687 J := J + 1; 1688 Res (J) := '"'; 1689 Quote_Needed := True; 1690 1691 elsif Arg (K) = ' ' or else Arg (K) = ASCII.HT then 1692 Res (J) := Arg (K); 1693 Quote_Needed := True; 1694 1695 else 1696 Res (J) := Arg (K); 1697 end if; 1698 end loop; 1699 1700 if Quote_Needed then 1701 1702 -- Case of null terminated string 1703 1704 if Res (J) = ASCII.NUL then 1705 1706 -- If the string ends with \, double it 1707 1708 if Res (J - 1) = '\' then 1709 Res (J) := '\'; 1710 J := J + 1; 1711 end if; 1712 1713 -- Put a quote just before the null at the end 1714 1715 Res (J) := '"'; 1716 J := J + 1; 1717 Res (J) := ASCII.NUL; 1718 1719 -- If argument is terminated by '\', then double it. Otherwise 1720 -- the ending quote will be taken as-is. This is quite strange 1721 -- spawn behavior from Windows, but this is what we see! 1722 1723 else 1724 if Res (J) = '\' then 1725 J := J + 1; 1726 Res (J) := '\'; 1727 end if; 1728 1729 -- Ending quote 1730 1731 J := J + 1; 1732 Res (J) := '"'; 1733 end if; 1734 1735 declare 1736 Old : String_Access := Arg; 1737 1738 begin 1739 Arg := new String'(Res (1 .. J)); 1740 Free (Old); 1741 end; 1742 end if; 1743 1744 end if; 1745 end Quote_Argument; 1746 1747 -- Start of processing for Normalize_Arguments 1748 1749 begin 1750 if Argument_Needs_Quote then 1751 for K in Args'Range loop 1752 if Args (K) /= null and then Args (K)'Length /= 0 then 1753 Quote_Argument (Args (K)); 1754 end if; 1755 end loop; 1756 end if; 1757 end Normalize_Arguments; 1758 1759 ------------------------ 1760 -- Normalize_Pathname -- 1761 ------------------------ 1762 1763 function Normalize_Pathname 1764 (Name : String; 1765 Directory : String := ""; 1766 Resolve_Links : Boolean := True; 1767 Case_Sensitive : Boolean := True) return String 1768 is 1769 Max_Path : Integer; 1770 pragma Import (C, Max_Path, "__gnat_max_path_len"); 1771 -- Maximum length of a path name 1772 1773 procedure Get_Current_Dir 1774 (Dir : System.Address; 1775 Length : System.Address); 1776 pragma Import (C, Get_Current_Dir, "__gnat_get_current_dir"); 1777 1778 Path_Buffer : String (1 .. Max_Path + Max_Path + 2); 1779 End_Path : Natural := 0; 1780 Link_Buffer : String (1 .. Max_Path + 2); 1781 Status : Integer; 1782 Last : Positive; 1783 Start : Natural; 1784 Finish : Positive; 1785 1786 Max_Iterations : constant := 500; 1787 1788 function Get_File_Names_Case_Sensitive return Integer; 1789 pragma Import 1790 (C, Get_File_Names_Case_Sensitive, 1791 "__gnat_get_file_names_case_sensitive"); 1792 1793 Fold_To_Lower_Case : constant Boolean := 1794 not Case_Sensitive 1795 and then Get_File_Names_Case_Sensitive = 0; 1796 1797 function Readlink 1798 (Path : System.Address; 1799 Buf : System.Address; 1800 Bufsiz : Integer) return Integer; 1801 pragma Import (C, Readlink, "__gnat_readlink"); 1802 1803 function To_Canonical_File_Spec 1804 (Host_File : System.Address) return System.Address; 1805 pragma Import 1806 (C, To_Canonical_File_Spec, "__gnat_to_canonical_file_spec"); 1807 1808 The_Name : String (1 .. Name'Length + 1); 1809 Canonical_File_Addr : System.Address; 1810 Canonical_File_Len : Integer; 1811 1812 function Strlen (S : System.Address) return Integer; 1813 pragma Import (C, Strlen, "strlen"); 1814 1815 function Final_Value (S : String) return String; 1816 -- Make final adjustment to the returned string. This function strips 1817 -- trailing directory separators, and folds returned string to lower 1818 -- case if required. 1819 1820 function Get_Directory (Dir : String) return String; 1821 -- If Dir is not empty, return it, adding a directory separator 1822 -- if not already present, otherwise return current working directory 1823 -- with terminating directory separator. 1824 1825 ----------------- 1826 -- Final_Value -- 1827 ----------------- 1828 1829 function Final_Value (S : String) return String is 1830 S1 : String := S; 1831 -- We may need to fold S to lower case, so we need a variable 1832 1833 Last : Natural; 1834 1835 begin 1836 if Fold_To_Lower_Case then 1837 System.Case_Util.To_Lower (S1); 1838 end if; 1839 1840 -- Remove trailing directory separator, if any 1841 1842 Last := S1'Last; 1843 1844 if Last > 1 1845 and then (S1 (Last) = '/' 1846 or else 1847 S1 (Last) = Directory_Separator) 1848 then 1849 -- Special case for Windows: C:\ 1850 1851 if Last = 3 1852 and then S1 (1) /= Directory_Separator 1853 and then S1 (2) = ':' 1854 then 1855 null; 1856 1857 else 1858 Last := Last - 1; 1859 end if; 1860 end if; 1861 1862 return S1 (1 .. Last); 1863 end Final_Value; 1864 1865 ------------------- 1866 -- Get_Directory -- 1867 ------------------- 1868 1869 function Get_Directory (Dir : String) return String is 1870 Result : String (1 .. Dir'Length + 1); 1871 Length : constant Natural := Dir'Length; 1872 1873 begin 1874 -- Directory given, add directory separator if needed 1875 1876 if Length > 0 then 1877 Result (1 .. Length) := Dir; 1878 1879 -- On Windows, change all '/' to '\' 1880 1881 if On_Windows then 1882 for J in 1 .. Length loop 1883 if Result (J) = '/' then 1884 Result (J) := Directory_Separator; 1885 end if; 1886 end loop; 1887 end if; 1888 1889 -- Add directory separator, if needed 1890 1891 if Result (Length) = Directory_Separator then 1892 return Result (1 .. Length); 1893 else 1894 Result (Result'Length) := Directory_Separator; 1895 return Result; 1896 end if; 1897 1898 -- Directory name not given, get current directory 1899 1900 else 1901 declare 1902 Buffer : String (1 .. Max_Path + 2); 1903 Path_Len : Natural := Max_Path; 1904 1905 begin 1906 Get_Current_Dir (Buffer'Address, Path_Len'Address); 1907 1908 if Buffer (Path_Len) /= Directory_Separator then 1909 Path_Len := Path_Len + 1; 1910 Buffer (Path_Len) := Directory_Separator; 1911 end if; 1912 1913 -- By default, the drive letter on Windows is in upper case 1914 1915 if On_Windows 1916 and then Path_Len >= 2 1917 and then Buffer (2) = ':' 1918 then 1919 System.Case_Util.To_Upper (Buffer (1 .. 1)); 1920 end if; 1921 1922 return Buffer (1 .. Path_Len); 1923 end; 1924 end if; 1925 end Get_Directory; 1926 1927 -- Start of processing for Normalize_Pathname 1928 1929 begin 1930 -- Special case, if name is null, then return null 1931 1932 if Name'Length = 0 then 1933 return ""; 1934 end if; 1935 1936 -- First, convert VMS file spec to Unix file spec. 1937 -- If Name is not in VMS syntax, then this is equivalent 1938 -- to put Name at the beginning of Path_Buffer. 1939 1940 VMS_Conversion : begin 1941 The_Name (1 .. Name'Length) := Name; 1942 The_Name (The_Name'Last) := ASCII.NUL; 1943 1944 Canonical_File_Addr := To_Canonical_File_Spec (The_Name'Address); 1945 Canonical_File_Len := Strlen (Canonical_File_Addr); 1946 1947 -- If VMS syntax conversion has failed, return an empty string 1948 -- to indicate the failure. 1949 1950 if Canonical_File_Len = 0 then 1951 return ""; 1952 end if; 1953 1954 declare 1955 subtype Path_String is String (1 .. Canonical_File_Len); 1956 type Path_String_Access is access Path_String; 1957 1958 function Address_To_Access is new 1959 Ada.Unchecked_Conversion (Source => Address, 1960 Target => Path_String_Access); 1961 1962 Path_Access : constant Path_String_Access := 1963 Address_To_Access (Canonical_File_Addr); 1964 1965 begin 1966 Path_Buffer (1 .. Canonical_File_Len) := Path_Access.all; 1967 End_Path := Canonical_File_Len; 1968 Last := 1; 1969 end; 1970 end VMS_Conversion; 1971 1972 -- Replace all '/' by Directory Separators (this is for Windows) 1973 1974 if Directory_Separator /= '/' then 1975 for Index in 1 .. End_Path loop 1976 if Path_Buffer (Index) = '/' then 1977 Path_Buffer (Index) := Directory_Separator; 1978 end if; 1979 end loop; 1980 end if; 1981 1982 -- Resolve directory names for Windows (formerly also VMS) 1983 1984 -- On VMS, if we have a Unix path such as /temp/..., and TEMP is a 1985 -- logical name, we must not try to resolve this logical name, because 1986 -- it may have multiple equivalences and if resolved we will only 1987 -- get the first one. 1988 1989 if On_Windows then 1990 1991 -- On Windows, if we have an absolute path starting with a directory 1992 -- separator, we need to have the drive letter appended in front. 1993 1994 -- On Windows, Get_Current_Dir will return a suitable directory name 1995 -- (path starting with a drive letter on Windows). So we take this 1996 -- drive letter and prepend it to the current path. 1997 1998 if Path_Buffer (1) = Directory_Separator 1999 and then Path_Buffer (2) /= Directory_Separator 2000 then 2001 declare 2002 Cur_Dir : constant String := Get_Directory (""); 2003 -- Get the current directory to get the drive letter 2004 2005 begin 2006 if Cur_Dir'Length > 2 2007 and then Cur_Dir (Cur_Dir'First + 1) = ':' 2008 then 2009 Path_Buffer (3 .. End_Path + 2) := 2010 Path_Buffer (1 .. End_Path); 2011 Path_Buffer (1 .. 2) := 2012 Cur_Dir (Cur_Dir'First .. Cur_Dir'First + 1); 2013 End_Path := End_Path + 2; 2014 end if; 2015 end; 2016 2017 -- We have a drive letter, ensure it is upper-case 2018 2019 elsif Path_Buffer (1) in 'a' .. 'z' 2020 and then Path_Buffer (2) = ':' 2021 then 2022 System.Case_Util.To_Upper (Path_Buffer (1 .. 1)); 2023 end if; 2024 end if; 2025 2026 -- On Windows, remove all double-quotes that are possibly part of the 2027 -- path but can cause problems with other methods. 2028 2029 if On_Windows then 2030 declare 2031 Index : Natural; 2032 2033 begin 2034 Index := Path_Buffer'First; 2035 for Current in Path_Buffer'First .. End_Path loop 2036 if Path_Buffer (Current) /= '"' then 2037 Path_Buffer (Index) := Path_Buffer (Current); 2038 Index := Index + 1; 2039 end if; 2040 end loop; 2041 2042 End_Path := Index - 1; 2043 end; 2044 end if; 2045 2046 -- Start the conversions 2047 2048 -- If this is not finished after Max_Iterations, give up and return an 2049 -- empty string. 2050 2051 for J in 1 .. Max_Iterations loop 2052 2053 -- If we don't have an absolute pathname, prepend the directory 2054 -- Reference_Dir. 2055 2056 if Last = 1 2057 and then not Is_Absolute_Path (Path_Buffer (1 .. End_Path)) 2058 then 2059 declare 2060 Reference_Dir : constant String := Get_Directory (Directory); 2061 Ref_Dir_Len : constant Natural := Reference_Dir'Length; 2062 -- Current directory name specified and its length 2063 2064 begin 2065 Path_Buffer (Ref_Dir_Len + 1 .. Ref_Dir_Len + End_Path) := 2066 Path_Buffer (1 .. End_Path); 2067 End_Path := Ref_Dir_Len + End_Path; 2068 Path_Buffer (1 .. Ref_Dir_Len) := Reference_Dir; 2069 Last := Ref_Dir_Len; 2070 end; 2071 end if; 2072 2073 Start := Last + 1; 2074 Finish := Last; 2075 2076 -- Ensure that Windows network drives are kept, e.g: \\server\drive-c 2077 2078 if Start = 2 2079 and then Directory_Separator = '\' 2080 and then Path_Buffer (1 .. 2) = "\\" 2081 then 2082 Start := 3; 2083 end if; 2084 2085 -- If we have traversed the full pathname, return it 2086 2087 if Start > End_Path then 2088 return Final_Value (Path_Buffer (1 .. End_Path)); 2089 end if; 2090 2091 -- Remove duplicate directory separators 2092 2093 while Path_Buffer (Start) = Directory_Separator loop 2094 if Start = End_Path then 2095 return Final_Value (Path_Buffer (1 .. End_Path - 1)); 2096 2097 else 2098 Path_Buffer (Start .. End_Path - 1) := 2099 Path_Buffer (Start + 1 .. End_Path); 2100 End_Path := End_Path - 1; 2101 end if; 2102 end loop; 2103 2104 -- Find the end of the current field: last character or the one 2105 -- preceding the next directory separator. 2106 2107 while Finish < End_Path 2108 and then Path_Buffer (Finish + 1) /= Directory_Separator 2109 loop 2110 Finish := Finish + 1; 2111 end loop; 2112 2113 -- Remove "." field 2114 2115 if Start = Finish and then Path_Buffer (Start) = '.' then 2116 if Start = End_Path then 2117 if Last = 1 then 2118 return (1 => Directory_Separator); 2119 else 2120 2121 if Fold_To_Lower_Case then 2122 System.Case_Util.To_Lower (Path_Buffer (1 .. Last - 1)); 2123 end if; 2124 2125 return Path_Buffer (1 .. Last - 1); 2126 2127 end if; 2128 2129 else 2130 Path_Buffer (Last + 1 .. End_Path - 2) := 2131 Path_Buffer (Last + 3 .. End_Path); 2132 End_Path := End_Path - 2; 2133 end if; 2134 2135 -- Remove ".." fields 2136 2137 elsif Finish = Start + 1 2138 and then Path_Buffer (Start .. Finish) = ".." 2139 then 2140 Start := Last; 2141 loop 2142 Start := Start - 1; 2143 exit when Start < 1 2144 or else Path_Buffer (Start) = Directory_Separator; 2145 end loop; 2146 2147 if Start <= 1 then 2148 if Finish = End_Path then 2149 return (1 => Directory_Separator); 2150 2151 else 2152 Path_Buffer (1 .. End_Path - Finish) := 2153 Path_Buffer (Finish + 1 .. End_Path); 2154 End_Path := End_Path - Finish; 2155 Last := 1; 2156 end if; 2157 2158 else 2159 if Finish = End_Path then 2160 return Final_Value (Path_Buffer (1 .. Start - 1)); 2161 2162 else 2163 Path_Buffer (Start + 1 .. Start + End_Path - Finish - 1) := 2164 Path_Buffer (Finish + 2 .. End_Path); 2165 End_Path := Start + End_Path - Finish - 1; 2166 Last := Start; 2167 end if; 2168 end if; 2169 2170 -- Check if current field is a symbolic link 2171 2172 elsif Resolve_Links then 2173 declare 2174 Saved : constant Character := Path_Buffer (Finish + 1); 2175 2176 begin 2177 Path_Buffer (Finish + 1) := ASCII.NUL; 2178 Status := Readlink (Path_Buffer'Address, 2179 Link_Buffer'Address, 2180 Link_Buffer'Length); 2181 Path_Buffer (Finish + 1) := Saved; 2182 end; 2183 2184 -- Not a symbolic link, move to the next field, if any 2185 2186 if Status <= 0 then 2187 Last := Finish + 1; 2188 2189 -- Replace symbolic link with its value 2190 2191 else 2192 if Is_Absolute_Path (Link_Buffer (1 .. Status)) then 2193 Path_Buffer (Status + 1 .. End_Path - (Finish - Status)) := 2194 Path_Buffer (Finish + 1 .. End_Path); 2195 End_Path := End_Path - (Finish - Status); 2196 Path_Buffer (1 .. Status) := Link_Buffer (1 .. Status); 2197 Last := 1; 2198 2199 else 2200 Path_Buffer 2201 (Last + Status + 1 .. End_Path - Finish + Last + Status) := 2202 Path_Buffer (Finish + 1 .. End_Path); 2203 End_Path := End_Path - Finish + Last + Status; 2204 Path_Buffer (Last + 1 .. Last + Status) := 2205 Link_Buffer (1 .. Status); 2206 end if; 2207 end if; 2208 2209 else 2210 Last := Finish + 1; 2211 end if; 2212 end loop; 2213 2214 -- Too many iterations: give up 2215 2216 -- This can happen when there is a circularity in the symbolic links: A 2217 -- is a symbolic link for B, which itself is a symbolic link, and the 2218 -- target of B or of another symbolic link target of B is A. In this 2219 -- case, we return an empty string to indicate failure to resolve. 2220 2221 return ""; 2222 end Normalize_Pathname; 2223 2224 --------------- 2225 -- Open_Read -- 2226 --------------- 2227 2228 function Open_Read 2229 (Name : C_File_Name; 2230 Fmode : Mode) return File_Descriptor 2231 is 2232 function C_Open_Read 2233 (Name : C_File_Name; 2234 Fmode : Mode) return File_Descriptor; 2235 pragma Import (C, C_Open_Read, "__gnat_open_read"); 2236 begin 2237 return C_Open_Read (Name, Fmode); 2238 end Open_Read; 2239 2240 function Open_Read 2241 (Name : String; 2242 Fmode : Mode) return File_Descriptor 2243 is 2244 C_Name : String (1 .. Name'Length + 1); 2245 begin 2246 C_Name (1 .. Name'Length) := Name; 2247 C_Name (C_Name'Last) := ASCII.NUL; 2248 return Open_Read (C_Name (C_Name'First)'Address, Fmode); 2249 end Open_Read; 2250 2251 --------------------- 2252 -- Open_Read_Write -- 2253 --------------------- 2254 2255 function Open_Read_Write 2256 (Name : C_File_Name; 2257 Fmode : Mode) return File_Descriptor 2258 is 2259 function C_Open_Read_Write 2260 (Name : C_File_Name; 2261 Fmode : Mode) return File_Descriptor; 2262 pragma Import (C, C_Open_Read_Write, "__gnat_open_rw"); 2263 begin 2264 return C_Open_Read_Write (Name, Fmode); 2265 end Open_Read_Write; 2266 2267 function Open_Read_Write 2268 (Name : String; 2269 Fmode : Mode) return File_Descriptor 2270 is 2271 C_Name : String (1 .. Name'Length + 1); 2272 begin 2273 C_Name (1 .. Name'Length) := Name; 2274 C_Name (C_Name'Last) := ASCII.NUL; 2275 return Open_Read_Write (C_Name (C_Name'First)'Address, Fmode); 2276 end Open_Read_Write; 2277 2278 ------------- 2279 -- OS_Exit -- 2280 ------------- 2281 2282 procedure OS_Exit (Status : Integer) is 2283 begin 2284 OS_Exit_Ptr (Status); 2285 raise Program_Error; 2286 end OS_Exit; 2287 2288 --------------------- 2289 -- OS_Exit_Default -- 2290 --------------------- 2291 2292 procedure OS_Exit_Default (Status : Integer) is 2293 procedure GNAT_OS_Exit (Status : Integer); 2294 pragma Import (C, GNAT_OS_Exit, "__gnat_os_exit"); 2295 pragma No_Return (GNAT_OS_Exit); 2296 begin 2297 GNAT_OS_Exit (Status); 2298 end OS_Exit_Default; 2299 2300 -------------------- 2301 -- Pid_To_Integer -- 2302 -------------------- 2303 2304 function Pid_To_Integer (Pid : Process_Id) return Integer is 2305 begin 2306 return Integer (Pid); 2307 end Pid_To_Integer; 2308 2309 ---------- 2310 -- Read -- 2311 ---------- 2312 2313 function Read 2314 (FD : File_Descriptor; 2315 A : System.Address; 2316 N : Integer) return Integer 2317 is 2318 begin 2319 return 2320 Integer (System.CRTL.read 2321 (System.CRTL.int (FD), 2322 System.CRTL.chars (A), 2323 System.CRTL.size_t (N))); 2324 end Read; 2325 2326 ----------------- 2327 -- Rename_File -- 2328 ----------------- 2329 2330 procedure Rename_File 2331 (Old_Name : C_File_Name; 2332 New_Name : C_File_Name; 2333 Success : out Boolean) 2334 is 2335 function rename (From, To : Address) return Integer; 2336 pragma Import (C, rename, "__gnat_rename"); 2337 R : Integer; 2338 begin 2339 R := rename (Old_Name, New_Name); 2340 Success := (R = 0); 2341 end Rename_File; 2342 2343 procedure Rename_File 2344 (Old_Name : String; 2345 New_Name : String; 2346 Success : out Boolean) 2347 is 2348 C_Old_Name : String (1 .. Old_Name'Length + 1); 2349 C_New_Name : String (1 .. New_Name'Length + 1); 2350 begin 2351 C_Old_Name (1 .. Old_Name'Length) := Old_Name; 2352 C_Old_Name (C_Old_Name'Last) := ASCII.NUL; 2353 C_New_Name (1 .. New_Name'Length) := New_Name; 2354 C_New_Name (C_New_Name'Last) := ASCII.NUL; 2355 Rename_File (C_Old_Name'Address, C_New_Name'Address, Success); 2356 end Rename_File; 2357 2358 ----------------------- 2359 -- Set_Close_On_Exec -- 2360 ----------------------- 2361 2362 procedure Set_Close_On_Exec 2363 (FD : File_Descriptor; 2364 Close_On_Exec : Boolean; 2365 Status : out Boolean) 2366 is 2367 function C_Set_Close_On_Exec 2368 (FD : File_Descriptor; Close_On_Exec : System.CRTL.int) 2369 return System.CRTL.int; 2370 pragma Import (C, C_Set_Close_On_Exec, "__gnat_set_close_on_exec"); 2371 begin 2372 Status := C_Set_Close_On_Exec (FD, Boolean'Pos (Close_On_Exec)) = 0; 2373 end Set_Close_On_Exec; 2374 2375 -------------------- 2376 -- Set_Executable -- 2377 -------------------- 2378 2379 procedure Set_Executable (Name : String) is 2380 procedure C_Set_Executable (Name : C_File_Name); 2381 pragma Import (C, C_Set_Executable, "__gnat_set_executable"); 2382 C_Name : aliased String (Name'First .. Name'Last + 1); 2383 begin 2384 C_Name (Name'Range) := Name; 2385 C_Name (C_Name'Last) := ASCII.NUL; 2386 C_Set_Executable (C_Name (C_Name'First)'Address); 2387 end Set_Executable; 2388 2389 ---------------------- 2390 -- Set_Non_Readable -- 2391 ---------------------- 2392 2393 procedure Set_Non_Readable (Name : String) is 2394 procedure C_Set_Non_Readable (Name : C_File_Name); 2395 pragma Import (C, C_Set_Non_Readable, "__gnat_set_non_readable"); 2396 C_Name : aliased String (Name'First .. Name'Last + 1); 2397 begin 2398 C_Name (Name'Range) := Name; 2399 C_Name (C_Name'Last) := ASCII.NUL; 2400 C_Set_Non_Readable (C_Name (C_Name'First)'Address); 2401 end Set_Non_Readable; 2402 2403 ---------------------- 2404 -- Set_Non_Writable -- 2405 ---------------------- 2406 2407 procedure Set_Non_Writable (Name : String) is 2408 procedure C_Set_Non_Writable (Name : C_File_Name); 2409 pragma Import (C, C_Set_Non_Writable, "__gnat_set_non_writable"); 2410 C_Name : aliased String (Name'First .. Name'Last + 1); 2411 begin 2412 C_Name (Name'Range) := Name; 2413 C_Name (C_Name'Last) := ASCII.NUL; 2414 C_Set_Non_Writable (C_Name (C_Name'First)'Address); 2415 end Set_Non_Writable; 2416 2417 ------------------ 2418 -- Set_Readable -- 2419 ------------------ 2420 2421 procedure Set_Readable (Name : String) is 2422 procedure C_Set_Readable (Name : C_File_Name); 2423 pragma Import (C, C_Set_Readable, "__gnat_set_readable"); 2424 C_Name : aliased String (Name'First .. Name'Last + 1); 2425 begin 2426 C_Name (Name'Range) := Name; 2427 C_Name (C_Name'Last) := ASCII.NUL; 2428 C_Set_Readable (C_Name (C_Name'First)'Address); 2429 end Set_Readable; 2430 2431 -------------------- 2432 -- Set_Writable -- 2433 -------------------- 2434 2435 procedure Set_Writable (Name : String) is 2436 procedure C_Set_Writable (Name : C_File_Name); 2437 pragma Import (C, C_Set_Writable, "__gnat_set_writable"); 2438 C_Name : aliased String (Name'First .. Name'Last + 1); 2439 begin 2440 C_Name (Name'Range) := Name; 2441 C_Name (C_Name'Last) := ASCII.NUL; 2442 C_Set_Writable (C_Name (C_Name'First)'Address); 2443 end Set_Writable; 2444 2445 ------------ 2446 -- Setenv -- 2447 ------------ 2448 2449 procedure Setenv (Name : String; Value : String) is 2450 F_Name : String (1 .. Name'Length + 1); 2451 F_Value : String (1 .. Value'Length + 1); 2452 2453 procedure Set_Env_Value (Name, Value : System.Address); 2454 pragma Import (C, Set_Env_Value, "__gnat_setenv"); 2455 2456 begin 2457 F_Name (1 .. Name'Length) := Name; 2458 F_Name (F_Name'Last) := ASCII.NUL; 2459 2460 F_Value (1 .. Value'Length) := Value; 2461 F_Value (F_Value'Last) := ASCII.NUL; 2462 2463 Set_Env_Value (F_Name'Address, F_Value'Address); 2464 end Setenv; 2465 2466 ----------- 2467 -- Spawn -- 2468 ----------- 2469 2470 function Spawn 2471 (Program_Name : String; 2472 Args : Argument_List) return Integer 2473 is 2474 Result : Integer; 2475 Junk : Process_Id; 2476 pragma Warnings (Off, Junk); 2477 begin 2478 Spawn_Internal (Program_Name, Args, Result, Junk, Blocking => True); 2479 return Result; 2480 end Spawn; 2481 2482 procedure Spawn 2483 (Program_Name : String; 2484 Args : Argument_List; 2485 Success : out Boolean) 2486 is 2487 begin 2488 Success := (Spawn (Program_Name, Args) = 0); 2489 end Spawn; 2490 2491 procedure Spawn 2492 (Program_Name : String; 2493 Args : Argument_List; 2494 Output_File_Descriptor : File_Descriptor; 2495 Return_Code : out Integer; 2496 Err_To_Out : Boolean := True) 2497 is 2498 Saved_Output : File_Descriptor; 2499 Saved_Error : File_Descriptor := Invalid_FD; -- prevent compiler warning 2500 2501 begin 2502 -- Set standard output and error to the temporary file 2503 2504 Saved_Output := Dup (Standout); 2505 Dup2 (Output_File_Descriptor, Standout); 2506 2507 if Err_To_Out then 2508 Saved_Error := Dup (Standerr); 2509 Dup2 (Output_File_Descriptor, Standerr); 2510 end if; 2511 2512 -- Spawn the program 2513 2514 Return_Code := Spawn (Program_Name, Args); 2515 2516 -- Restore the standard output and error 2517 2518 Dup2 (Saved_Output, Standout); 2519 2520 if Err_To_Out then 2521 Dup2 (Saved_Error, Standerr); 2522 end if; 2523 2524 -- And close the saved standard output and error file descriptors 2525 2526 Close (Saved_Output); 2527 2528 if Err_To_Out then 2529 Close (Saved_Error); 2530 end if; 2531 end Spawn; 2532 2533 procedure Spawn 2534 (Program_Name : String; 2535 Args : Argument_List; 2536 Output_File : String; 2537 Success : out Boolean; 2538 Return_Code : out Integer; 2539 Err_To_Out : Boolean := True) 2540 is 2541 FD : File_Descriptor; 2542 2543 begin 2544 Success := True; 2545 Return_Code := 0; 2546 2547 FD := Create_Output_Text_File (Output_File); 2548 2549 if FD = Invalid_FD then 2550 Success := False; 2551 return; 2552 end if; 2553 2554 Spawn (Program_Name, Args, FD, Return_Code, Err_To_Out); 2555 2556 Close (FD, Success); 2557 end Spawn; 2558 2559 -------------------- 2560 -- Spawn_Internal -- 2561 -------------------- 2562 2563 procedure Spawn_Internal 2564 (Program_Name : String; 2565 Args : Argument_List; 2566 Result : out Integer; 2567 Pid : out Process_Id; 2568 Blocking : Boolean) 2569 is 2570 2571 procedure Spawn (Args : Argument_List); 2572 -- Call Spawn with given argument list 2573 2574 N_Args : Argument_List (Args'Range); 2575 -- Normalized arguments 2576 2577 ----------- 2578 -- Spawn -- 2579 ----------- 2580 2581 procedure Spawn (Args : Argument_List) is 2582 type Chars is array (Positive range <>) of aliased Character; 2583 type Char_Ptr is access constant Character; 2584 2585 Command_Len : constant Positive := Program_Name'Length + 1 2586 + Args_Length (Args); 2587 Command_Last : Natural := 0; 2588 Command : aliased Chars (1 .. Command_Len); 2589 -- Command contains all characters of the Program_Name and Args, all 2590 -- terminated by ASCII.NUL characters. 2591 2592 Arg_List_Len : constant Positive := Args'Length + 2; 2593 Arg_List_Last : Natural := 0; 2594 Arg_List : aliased array (1 .. Arg_List_Len) of Char_Ptr; 2595 -- List with pointers to NUL-terminated strings of the Program_Name 2596 -- and the Args and terminated with a null pointer. We rely on the 2597 -- default initialization for the last null pointer. 2598 2599 procedure Add_To_Command (S : String); 2600 -- Add S and a NUL character to Command, updating Last 2601 2602 function Portable_Spawn (Args : Address) return Integer; 2603 pragma Import (C, Portable_Spawn, "__gnat_portable_spawn"); 2604 2605 function Portable_No_Block_Spawn (Args : Address) return Process_Id; 2606 pragma Import 2607 (C, Portable_No_Block_Spawn, "__gnat_portable_no_block_spawn"); 2608 2609 -------------------- 2610 -- Add_To_Command -- 2611 -------------------- 2612 2613 procedure Add_To_Command (S : String) is 2614 First : constant Natural := Command_Last + 1; 2615 2616 begin 2617 Command_Last := Command_Last + S'Length; 2618 2619 -- Move characters one at a time, because Command has aliased 2620 -- components. 2621 2622 -- But not volatile, so why is this necessary ??? 2623 2624 for J in S'Range loop 2625 Command (First + J - S'First) := S (J); 2626 end loop; 2627 2628 Command_Last := Command_Last + 1; 2629 Command (Command_Last) := ASCII.NUL; 2630 2631 Arg_List_Last := Arg_List_Last + 1; 2632 Arg_List (Arg_List_Last) := Command (First)'Access; 2633 end Add_To_Command; 2634 2635 -- Start of processing for Spawn 2636 2637 begin 2638 Add_To_Command (Program_Name); 2639 2640 for J in Args'Range loop 2641 Add_To_Command (Args (J).all); 2642 end loop; 2643 2644 if Blocking then 2645 Pid := Invalid_Pid; 2646 Result := Portable_Spawn (Arg_List'Address); 2647 else 2648 Pid := Portable_No_Block_Spawn (Arg_List'Address); 2649 Result := Boolean'Pos (Pid /= Invalid_Pid); 2650 end if; 2651 end Spawn; 2652 2653 -- Start of processing for Spawn_Internal 2654 2655 begin 2656 -- Copy arguments into a local structure 2657 2658 for K in N_Args'Range loop 2659 N_Args (K) := new String'(Args (K).all); 2660 end loop; 2661 2662 -- Normalize those arguments 2663 2664 Normalize_Arguments (N_Args); 2665 2666 -- Call spawn using the normalized arguments 2667 2668 Spawn (N_Args); 2669 2670 -- Free arguments list 2671 2672 for K in N_Args'Range loop 2673 Free (N_Args (K)); 2674 end loop; 2675 end Spawn_Internal; 2676 2677 --------------------------- 2678 -- To_Path_String_Access -- 2679 --------------------------- 2680 2681 function To_Path_String_Access 2682 (Path_Addr : Address; 2683 Path_Len : Integer) return String_Access 2684 is 2685 subtype Path_String is String (1 .. Path_Len); 2686 type Path_String_Access is access Path_String; 2687 2688 function Address_To_Access is new Ada.Unchecked_Conversion 2689 (Source => Address, Target => Path_String_Access); 2690 2691 Path_Access : constant Path_String_Access := 2692 Address_To_Access (Path_Addr); 2693 2694 Return_Val : String_Access; 2695 2696 begin 2697 Return_Val := new String (1 .. Path_Len); 2698 2699 for J in 1 .. Path_Len loop 2700 Return_Val (J) := Path_Access (J); 2701 end loop; 2702 2703 return Return_Val; 2704 end To_Path_String_Access; 2705 2706 ------------------ 2707 -- Wait_Process -- 2708 ------------------ 2709 2710 procedure Wait_Process (Pid : out Process_Id; Success : out Boolean) is 2711 Status : Integer; 2712 2713 function Portable_Wait (S : Address) return Process_Id; 2714 pragma Import (C, Portable_Wait, "__gnat_portable_wait"); 2715 2716 begin 2717 Pid := Portable_Wait (Status'Address); 2718 Success := (Status = 0); 2719 end Wait_Process; 2720 2721 ----------- 2722 -- Write -- 2723 ----------- 2724 2725 function Write 2726 (FD : File_Descriptor; 2727 A : System.Address; 2728 N : Integer) return Integer 2729 is 2730 begin 2731 return 2732 Integer (System.CRTL.write 2733 (System.CRTL.int (FD), 2734 System.CRTL.chars (A), 2735 System.CRTL.size_t (N))); 2736 end Write; 2737 2738end System.OS_Lib; 2739