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