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