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