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