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