1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- G N A T . O S _ L I B -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1995-2003 Ada Core Technologies, Inc. -- 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 2, 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. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING. If not, write -- 19-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- 20-- MA 02111-1307, USA. -- 21-- -- 22-- As a special exception, if other files instantiate generics from this -- 23-- unit, or you link this unit with other files to produce an executable, -- 24-- this unit does not by itself cause the resulting executable to be -- 25-- covered by the GNU General Public License. This exception does not -- 26-- however invalidate any other reasons why the executable file might be -- 27-- covered by the GNU Public License. -- 28-- -- 29-- GNAT was originally developed by the GNAT team at New York University. -- 30-- Extensive contributions were provided by Ada Core Technologies Inc. -- 31-- -- 32------------------------------------------------------------------------------ 33 34with System.Case_Util; 35with System.CRTL; 36with System.Soft_Links; 37with Unchecked_Conversion; 38with System; use System; 39 40package body GNAT.OS_Lib is 41 42 package SSL renames System.Soft_Links; 43 44 -- The following are used by Create_Temp_File 45 46 Current_Temp_File_Name : String := "GNAT-TEMP-000000.TMP"; 47 -- Name of the temp file last created 48 49 Temp_File_Name_Last_Digit : constant Positive := 50 Current_Temp_File_Name'Last - 4; 51 -- Position of the last digit in Current_Temp_File_Name 52 53 Max_Attempts : constant := 100; 54 -- The maximum number of attempts to create a new temp file 55 56 ----------------------- 57 -- Local Subprograms -- 58 ----------------------- 59 60 function Args_Length (Args : Argument_List) return Natural; 61 -- Returns total number of characters needed to create a string 62 -- of all Args terminated by ASCII.NUL characters 63 64 function C_String_Length (S : Address) return Integer; 65 -- Returns the length of a C string. Does check for null address 66 -- (returns 0). 67 68 procedure Spawn_Internal 69 (Program_Name : String; 70 Args : Argument_List; 71 Result : out Integer; 72 Pid : out Process_Id; 73 Blocking : Boolean); 74 -- Internal routine to implement the two Spawn (blocking/non blocking) 75 -- routines. If Blocking is set to True then the spawn is blocking 76 -- otherwise it is non blocking. In this latter case the Pid contains 77 -- the process id number. The first three parameters are as in Spawn. 78 -- Note that Spawn_Internal normalizes the argument list before calling 79 -- the low level system spawn routines (see Normalize_Arguments). Note 80 -- that Normalize_Arguments is designed to do nothing if it is called 81 -- more than once, so calling Normalize_Arguments before calling one 82 -- of the spawn routines is fine. 83 84 function To_Path_String_Access 85 (Path_Addr : Address; 86 Path_Len : Integer) return String_Access; 87 -- Converts a C String to an Ada String. We could do this making use of 88 -- Interfaces.C.Strings but we prefer not to import that entire package 89 90 --------- 91 -- "<" -- 92 --------- 93 94 function "<" (X, Y : OS_Time) return Boolean is 95 begin 96 return Long_Integer (X) < Long_Integer (Y); 97 end "<"; 98 99 ---------- 100 -- "<=" -- 101 ---------- 102 103 function "<=" (X, Y : OS_Time) return Boolean is 104 begin 105 return Long_Integer (X) <= Long_Integer (Y); 106 end "<="; 107 108 --------- 109 -- ">" -- 110 --------- 111 112 function ">" (X, Y : OS_Time) return Boolean is 113 begin 114 return Long_Integer (X) > Long_Integer (Y); 115 end ">"; 116 117 ---------- 118 -- ">=" -- 119 ---------- 120 121 function ">=" (X, Y : OS_Time) return Boolean is 122 begin 123 return Long_Integer (X) >= Long_Integer (Y); 124 end ">="; 125 126 ----------------- 127 -- Args_Length -- 128 ----------------- 129 130 function Args_Length (Args : Argument_List) return Natural is 131 Len : Natural := 0; 132 133 begin 134 for J in Args'Range loop 135 Len := Len + Args (J)'Length + 1; -- One extra for ASCII.NUL 136 end loop; 137 138 return Len; 139 end Args_Length; 140 141 ----------------------------- 142 -- Argument_String_To_List -- 143 ----------------------------- 144 145 function Argument_String_To_List 146 (Arg_String : String) return Argument_List_Access 147 is 148 Max_Args : constant Integer := Arg_String'Length; 149 New_Argv : Argument_List (1 .. Max_Args); 150 New_Argc : Natural := 0; 151 Idx : Integer; 152 153 begin 154 Idx := Arg_String'First; 155 156 loop 157 exit when Idx > Arg_String'Last; 158 159 declare 160 Quoted : Boolean := False; 161 Backqd : Boolean := False; 162 Old_Idx : Integer; 163 164 begin 165 Old_Idx := Idx; 166 167 loop 168 -- An unquoted space is the end of an argument 169 170 if not (Backqd or Quoted) 171 and then Arg_String (Idx) = ' ' 172 then 173 exit; 174 175 -- Start of a quoted string 176 177 elsif not (Backqd or Quoted) 178 and then Arg_String (Idx) = '"' 179 then 180 Quoted := True; 181 182 -- End of a quoted string and end of an argument 183 184 elsif (Quoted and not Backqd) 185 and then Arg_String (Idx) = '"' 186 then 187 Idx := Idx + 1; 188 exit; 189 190 -- Following character is backquoted 191 192 elsif Arg_String (Idx) = '\' then 193 Backqd := True; 194 195 -- Turn off backquoting after advancing one character 196 197 elsif Backqd then 198 Backqd := False; 199 200 end if; 201 202 Idx := Idx + 1; 203 exit when Idx > Arg_String'Last; 204 end loop; 205 206 -- Found an argument 207 208 New_Argc := New_Argc + 1; 209 New_Argv (New_Argc) := 210 new String'(Arg_String (Old_Idx .. Idx - 1)); 211 212 -- Skip extraneous spaces 213 214 while Idx <= Arg_String'Last and then Arg_String (Idx) = ' ' loop 215 Idx := Idx + 1; 216 end loop; 217 end; 218 end loop; 219 220 return new Argument_List'(New_Argv (1 .. New_Argc)); 221 end Argument_String_To_List; 222 223 --------------------- 224 -- C_String_Length -- 225 --------------------- 226 227 function C_String_Length (S : Address) return Integer is 228 229 function Strlen (S : Address) return Integer; 230 pragma Import (C, Strlen, "strlen"); 231 232 begin 233 if S = Null_Address then 234 return 0; 235 else 236 return Strlen (S); 237 end if; 238 end C_String_Length; 239 240 ----------- 241 -- Close -- 242 ----------- 243 244 procedure Close (FD : File_Descriptor) is 245 procedure C_Close (FD : File_Descriptor); 246 pragma Import (C, C_Close, "close"); 247 begin 248 C_Close (FD); 249 end Close; 250 251 procedure Close (FD : File_Descriptor; Status : out Boolean) is 252 function C_Close (FD : File_Descriptor) return Integer; 253 pragma Import (C, C_Close, "close"); 254 begin 255 Status := (C_Close (FD) = 0); 256 end Close; 257 258 --------------- 259 -- Copy_File -- 260 --------------- 261 262 procedure Copy_File 263 (Name : String; 264 Pathname : String; 265 Success : out Boolean; 266 Mode : Copy_Mode := Copy; 267 Preserve : Attribute := Time_Stamps) 268 is 269 From : File_Descriptor; 270 To : File_Descriptor; 271 272 Copy_Error : exception; 273 -- Internal exception raised to signal error in copy 274 275 function Build_Path (Dir : String; File : String) return String; 276 -- Returns pathname Dir catenated with File adding the directory 277 -- separator only if needed. 278 279 procedure Copy (From, To : File_Descriptor); 280 -- Read data from From and place them into To. In both cases the 281 -- operations uses the current file position. Raises Constraint_Error 282 -- if a problem occurs during the copy. 283 284 procedure Copy_To (To_Name : String); 285 -- Does a straight copy from source to designated destination file 286 287 ---------------- 288 -- Build_Path -- 289 ---------------- 290 291 function Build_Path (Dir : String; File : String) return String is 292 Res : String (1 .. Dir'Length + File'Length + 1); 293 294 Base_File_Ptr : Integer; 295 -- The base file name is File (Base_File_Ptr + 1 .. File'Last) 296 297 function Is_Dirsep (C : Character) return Boolean; 298 pragma Inline (Is_Dirsep); 299 -- Returns True if C is a directory separator. On Windows we 300 -- handle both styles of directory separator. 301 302 --------------- 303 -- Is_Dirsep -- 304 --------------- 305 306 function Is_Dirsep (C : Character) return Boolean is 307 begin 308 return C = Directory_Separator or else C = '/'; 309 end Is_Dirsep; 310 311 begin 312 -- Find base file name 313 314 Base_File_Ptr := File'Last; 315 while Base_File_Ptr >= File'First loop 316 exit when Is_Dirsep (File (Base_File_Ptr)); 317 Base_File_Ptr := Base_File_Ptr - 1; 318 end loop; 319 320 declare 321 Base_File : String renames 322 File (Base_File_Ptr + 1 .. File'Last); 323 324 begin 325 Res (1 .. Dir'Length) := Dir; 326 327 if Is_Dirsep (Dir (Dir'Last)) then 328 Res (Dir'Length + 1 .. Dir'Length + Base_File'Length) := 329 Base_File; 330 return Res (1 .. Dir'Length + Base_File'Length); 331 332 else 333 Res (Dir'Length + 1) := Directory_Separator; 334 Res (Dir'Length + 2 .. Dir'Length + 1 + Base_File'Length) := 335 Base_File; 336 return Res (1 .. Dir'Length + 1 + Base_File'Length); 337 end if; 338 end; 339 end Build_Path; 340 341 ---------- 342 -- Copy -- 343 ---------- 344 345 procedure Copy (From, To : File_Descriptor) is 346 Buf_Size : constant := 200_000; 347 Buffer : array (1 .. Buf_Size) of Character; 348 R : Integer; 349 W : Integer; 350 351 Status_From : Boolean; 352 Status_To : Boolean; 353 -- Statuses for the calls to Close 354 355 begin 356 if From = Invalid_FD or else To = Invalid_FD then 357 raise Copy_Error; 358 end if; 359 360 loop 361 R := Read (From, Buffer (1)'Address, Buf_Size); 362 363 -- For VMS, the buffer may not be full. So, we need to try again 364 -- until there is nothing to read. 365 366 exit when R = 0; 367 368 W := Write (To, Buffer (1)'Address, R); 369 370 if W < R then 371 372 -- Problem writing data, could be a disk full. Close files 373 -- without worrying about status, since we are raising a 374 -- Copy_Error exception in any case. 375 376 Close (From, Status_From); 377 Close (To, Status_To); 378 379 raise Copy_Error; 380 end if; 381 end loop; 382 383 Close (From, Status_From); 384 Close (To, Status_To); 385 386 if not (Status_From and Status_To) then 387 raise Copy_Error; 388 end if; 389 end Copy; 390 391 ------------- 392 -- Copy_To -- 393 ------------- 394 395 procedure Copy_To (To_Name : String) is 396 397 function Copy_Attributes 398 (From, To : System.Address; 399 Mode : Integer) return Integer; 400 pragma Import (C, Copy_Attributes, "__gnat_copy_attribs"); 401 -- Mode = 0 - copy only time stamps. 402 -- Mode = 1 - copy time stamps and read/write/execute attributes 403 404 C_From : String (1 .. Name'Length + 1); 405 C_To : String (1 .. To_Name'Length + 1); 406 407 begin 408 From := Open_Read (Name, Binary); 409 To := Create_File (To_Name, Binary); 410 Copy (From, To); 411 412 -- Copy attributes 413 414 C_From (1 .. Name'Length) := Name; 415 C_From (C_From'Last) := ASCII.Nul; 416 417 C_To (1 .. To_Name'Length) := To_Name; 418 C_To (C_To'Last) := ASCII.Nul; 419 420 case Preserve is 421 422 when Time_Stamps => 423 if Copy_Attributes (C_From'Address, C_To'Address, 0) = -1 then 424 raise Copy_Error; 425 end if; 426 427 when Full => 428 if Copy_Attributes (C_From'Address, C_To'Address, 1) = -1 then 429 raise Copy_Error; 430 end if; 431 432 when None => 433 null; 434 end case; 435 436 end Copy_To; 437 438 -- Start of processing for Copy_File 439 440 begin 441 Success := True; 442 443 -- The source file must exist 444 445 if not Is_Regular_File (Name) then 446 raise Copy_Error; 447 end if; 448 449 -- The source file exists 450 451 case Mode is 452 453 -- Copy case, target file must not exist 454 455 when Copy => 456 457 -- If the target file exists, we have an error 458 459 if Is_Regular_File (Pathname) then 460 raise Copy_Error; 461 462 -- Case of target is a directory 463 464 elsif Is_Directory (Pathname) then 465 declare 466 Dest : constant String := Build_Path (Pathname, Name); 467 468 begin 469 -- If the target file exists, we have an error 470 -- otherwise do the copy. 471 472 if Is_Regular_File (Dest) then 473 raise Copy_Error; 474 else 475 Copy_To (Dest); 476 end if; 477 end; 478 479 -- Case of normal copy to file (destination does not exist) 480 481 else 482 Copy_To (Pathname); 483 end if; 484 485 -- Overwrite case, destination file may or may not exist 486 487 when Overwrite => 488 if Is_Directory (Pathname) then 489 Copy_To (Build_Path (Pathname, Name)); 490 else 491 Copy_To (Pathname); 492 end if; 493 494 -- Appending case, destination file may or may not exist 495 496 when Append => 497 498 -- Appending to existing file 499 500 if Is_Regular_File (Pathname) then 501 502 -- Append mode and destination file exists, append data 503 -- at the end of Pathname. 504 505 From := Open_Read (Name, Binary); 506 To := Open_Read_Write (Pathname, Binary); 507 Lseek (To, 0, Seek_End); 508 509 Copy (From, To); 510 511 -- Appending to directory, not allowed 512 513 elsif Is_Directory (Pathname) then 514 raise Copy_Error; 515 516 -- Appending when target file does not exist 517 518 else 519 Copy_To (Pathname); 520 end if; 521 end case; 522 523 -- All error cases are caught here 524 525 exception 526 when Copy_Error => 527 Success := False; 528 end Copy_File; 529 530 procedure Copy_File 531 (Name : C_File_Name; 532 Pathname : C_File_Name; 533 Success : out Boolean; 534 Mode : Copy_Mode := Copy; 535 Preserve : Attribute := Time_Stamps) 536 is 537 Ada_Name : String_Access := 538 To_Path_String_Access 539 (Name, C_String_Length (Name)); 540 541 Ada_Pathname : String_Access := 542 To_Path_String_Access 543 (Pathname, C_String_Length (Pathname)); 544 545 begin 546 Copy_File (Ada_Name.all, Ada_Pathname.all, Success, Mode, Preserve); 547 Free (Ada_Name); 548 Free (Ada_Pathname); 549 end Copy_File; 550 551 ---------------------- 552 -- Copy_Time_Stamps -- 553 ---------------------- 554 555 procedure Copy_Time_Stamps (Source, Dest : String; Success : out Boolean) is 556 557 function Copy_Attributes 558 (From, To : System.Address; 559 Mode : Integer) return Integer; 560 pragma Import (C, Copy_Attributes, "__gnat_copy_attribs"); 561 -- Mode = 0 - copy only time stamps. 562 -- Mode = 1 - copy time stamps and read/write/execute attributes 563 564 begin 565 if Is_Regular_File (Source) and then Is_Writable_File (Dest) then 566 declare 567 C_Source : String (1 .. Source'Length + 1); 568 C_Dest : String (1 .. Dest'Length + 1); 569 begin 570 C_Source (1 .. C_Source'Length) := Source; 571 C_Source (C_Source'Last) := ASCII.Nul; 572 573 C_Dest (1 .. C_Dest'Length) := Dest; 574 C_Dest (C_Dest'Last) := ASCII.Nul; 575 576 if Copy_Attributes (C_Source'Address, C_Dest'Address, 0) = -1 then 577 Success := False; 578 else 579 Success := True; 580 end if; 581 end; 582 583 else 584 Success := False; 585 end if; 586 end Copy_Time_Stamps; 587 588 procedure Copy_Time_Stamps 589 (Source, Dest : C_File_Name; 590 Success : out Boolean) 591 is 592 Ada_Source : String_Access := 593 To_Path_String_Access 594 (Source, C_String_Length (Source)); 595 596 Ada_Dest : String_Access := 597 To_Path_String_Access 598 (Dest, C_String_Length (Dest)); 599 begin 600 Copy_Time_Stamps (Ada_Source.all, Ada_Dest.all, Success); 601 Free (Ada_Source); 602 Free (Ada_Dest); 603 end Copy_Time_Stamps; 604 605 ----------------- 606 -- Create_File -- 607 ----------------- 608 609 function Create_File 610 (Name : C_File_Name; 611 Fmode : Mode) return File_Descriptor 612 is 613 function C_Create_File 614 (Name : C_File_Name; 615 Fmode : Mode) return File_Descriptor; 616 pragma Import (C, C_Create_File, "__gnat_open_create"); 617 618 begin 619 return C_Create_File (Name, Fmode); 620 end Create_File; 621 622 function Create_File 623 (Name : String; 624 Fmode : Mode) return File_Descriptor 625 is 626 C_Name : String (1 .. Name'Length + 1); 627 628 begin 629 C_Name (1 .. Name'Length) := Name; 630 C_Name (C_Name'Last) := ASCII.NUL; 631 return Create_File (C_Name (C_Name'First)'Address, Fmode); 632 end Create_File; 633 634 --------------------- 635 -- Create_New_File -- 636 --------------------- 637 638 function Create_New_File 639 (Name : C_File_Name; 640 Fmode : Mode) return File_Descriptor 641 is 642 function C_Create_New_File 643 (Name : C_File_Name; 644 Fmode : Mode) return File_Descriptor; 645 pragma Import (C, C_Create_New_File, "__gnat_open_new"); 646 647 begin 648 return C_Create_New_File (Name, Fmode); 649 end Create_New_File; 650 651 function Create_New_File 652 (Name : String; 653 Fmode : Mode) return File_Descriptor 654 is 655 C_Name : String (1 .. Name'Length + 1); 656 657 begin 658 C_Name (1 .. Name'Length) := Name; 659 C_Name (C_Name'Last) := ASCII.NUL; 660 return Create_New_File (C_Name (C_Name'First)'Address, Fmode); 661 end Create_New_File; 662 663 ---------------------- 664 -- Create_Temp_File -- 665 ---------------------- 666 667 procedure Create_Temp_File 668 (FD : out File_Descriptor; 669 Name : out Temp_File_Name) 670 is 671 function Open_New_Temp 672 (Name : System.Address; 673 Fmode : Mode) return File_Descriptor; 674 pragma Import (C, Open_New_Temp, "__gnat_open_new_temp"); 675 676 begin 677 FD := Open_New_Temp (Name'Address, Binary); 678 end Create_Temp_File; 679 680 procedure Create_Temp_File 681 (FD : out File_Descriptor; 682 Name : out String_Access) 683 is 684 Pos : Positive; 685 Attempts : Natural := 0; 686 Current : String (Current_Temp_File_Name'Range); 687 688 begin 689 -- Loop until a new temp file can be created 690 691 File_Loop : loop 692 Locked : begin 693 -- We need to protect global variable Current_Temp_File_Name 694 -- against concurrent access by different tasks. 695 696 SSL.Lock_Task.all; 697 698 -- Start at the last digit 699 700 Pos := Temp_File_Name_Last_Digit; 701 702 Digit_Loop : 703 loop 704 -- Increment the digit by one 705 706 case Current_Temp_File_Name (Pos) is 707 when '0' .. '8' => 708 Current_Temp_File_Name (Pos) := 709 Character'Succ (Current_Temp_File_Name (Pos)); 710 exit Digit_Loop; 711 712 when '9' => 713 714 -- For 9, set the digit to 0 and go to the previous digit 715 716 Current_Temp_File_Name (Pos) := '0'; 717 Pos := Pos - 1; 718 719 when others => 720 721 -- If it is not a digit, then there are no available 722 -- temp file names. Return Invalid_FD. There is almost 723 -- no that this code will be ever be executed, since 724 -- it would mean that there are one million temp files 725 -- in the same directory! 726 727 SSL.Unlock_Task.all; 728 FD := Invalid_FD; 729 Name := null; 730 exit File_Loop; 731 end case; 732 end loop Digit_Loop; 733 734 Current := Current_Temp_File_Name; 735 736 -- We can now release the lock, because we are no longer 737 -- accessing Current_Temp_File_Name. 738 739 SSL.Unlock_Task.all; 740 741 exception 742 when others => 743 SSL.Unlock_Task.all; 744 raise; 745 end Locked; 746 747 -- Attempt to create the file 748 749 FD := Create_New_File (Current, Binary); 750 751 if FD /= Invalid_FD then 752 Name := new String'(Current); 753 exit File_Loop; 754 end if; 755 756 if not Is_Regular_File (Current) then 757 758 -- If the file does not already exist and we are unable to create 759 -- it, we give up after Max_Attempts. Otherwise, we try again with 760 -- the next available file name. 761 762 Attempts := Attempts + 1; 763 764 if Attempts >= Max_Attempts then 765 FD := Invalid_FD; 766 Name := null; 767 exit File_Loop; 768 end if; 769 end if; 770 end loop File_Loop; 771 end Create_Temp_File; 772 773 ----------------- 774 -- Delete_File -- 775 ----------------- 776 777 procedure Delete_File (Name : Address; Success : out Boolean) is 778 R : Integer; 779 780 function unlink (A : Address) return Integer; 781 pragma Import (C, unlink, "unlink"); 782 783 begin 784 R := unlink (Name); 785 Success := (R = 0); 786 end Delete_File; 787 788 procedure Delete_File (Name : String; Success : out Boolean) is 789 C_Name : String (1 .. Name'Length + 1); 790 791 begin 792 C_Name (1 .. Name'Length) := Name; 793 C_Name (C_Name'Last) := ASCII.NUL; 794 795 Delete_File (C_Name'Address, Success); 796 end Delete_File; 797 798 --------------------- 799 -- File_Time_Stamp -- 800 --------------------- 801 802 function File_Time_Stamp (FD : File_Descriptor) return OS_Time is 803 function File_Time (FD : File_Descriptor) return OS_Time; 804 pragma Import (C, File_Time, "__gnat_file_time_fd"); 805 806 begin 807 return File_Time (FD); 808 end File_Time_Stamp; 809 810 function File_Time_Stamp (Name : C_File_Name) return OS_Time is 811 function File_Time (Name : Address) return OS_Time; 812 pragma Import (C, File_Time, "__gnat_file_time_name"); 813 814 begin 815 return File_Time (Name); 816 end File_Time_Stamp; 817 818 function File_Time_Stamp (Name : String) return OS_Time is 819 F_Name : String (1 .. Name'Length + 1); 820 821 begin 822 F_Name (1 .. Name'Length) := Name; 823 F_Name (F_Name'Last) := ASCII.NUL; 824 return File_Time_Stamp (F_Name'Address); 825 end File_Time_Stamp; 826 827 --------------------------- 828 -- Get_Debuggable_Suffix -- 829 --------------------------- 830 831 function Get_Debuggable_Suffix return String_Access is 832 procedure Get_Suffix_Ptr (Length, Ptr : Address); 833 pragma Import (C, Get_Suffix_Ptr, "__gnat_get_debuggable_suffix_ptr"); 834 835 procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer); 836 pragma Import (C, Strncpy, "strncpy"); 837 838 Suffix_Ptr : Address; 839 Suffix_Length : Integer; 840 Result : String_Access; 841 842 begin 843 Get_Suffix_Ptr (Suffix_Length'Address, Suffix_Ptr'Address); 844 845 Result := new String (1 .. Suffix_Length); 846 847 if Suffix_Length > 0 then 848 Strncpy (Result.all'Address, Suffix_Ptr, Suffix_Length); 849 end if; 850 851 return Result; 852 end Get_Debuggable_Suffix; 853 854 --------------------------- 855 -- Get_Executable_Suffix -- 856 --------------------------- 857 858 function Get_Executable_Suffix return String_Access is 859 procedure Get_Suffix_Ptr (Length, Ptr : Address); 860 pragma Import (C, Get_Suffix_Ptr, "__gnat_get_executable_suffix_ptr"); 861 862 procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer); 863 pragma Import (C, Strncpy, "strncpy"); 864 865 Suffix_Ptr : Address; 866 Suffix_Length : Integer; 867 Result : String_Access; 868 869 begin 870 Get_Suffix_Ptr (Suffix_Length'Address, Suffix_Ptr'Address); 871 872 Result := new String (1 .. Suffix_Length); 873 874 if Suffix_Length > 0 then 875 Strncpy (Result.all'Address, Suffix_Ptr, Suffix_Length); 876 end if; 877 878 return Result; 879 end Get_Executable_Suffix; 880 881 ----------------------- 882 -- Get_Object_Suffix -- 883 ----------------------- 884 885 function Get_Object_Suffix return String_Access is 886 procedure Get_Suffix_Ptr (Length, Ptr : Address); 887 pragma Import (C, Get_Suffix_Ptr, "__gnat_get_object_suffix_ptr"); 888 889 procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer); 890 pragma Import (C, Strncpy, "strncpy"); 891 892 Suffix_Ptr : Address; 893 Suffix_Length : Integer; 894 Result : String_Access; 895 896 begin 897 Get_Suffix_Ptr (Suffix_Length'Address, Suffix_Ptr'Address); 898 899 Result := new String (1 .. Suffix_Length); 900 901 if Suffix_Length > 0 then 902 Strncpy (Result.all'Address, Suffix_Ptr, Suffix_Length); 903 end if; 904 905 return Result; 906 end Get_Object_Suffix; 907 908 ------------ 909 -- Getenv -- 910 ------------ 911 912 function Getenv (Name : String) return String_Access is 913 procedure Get_Env_Value_Ptr (Name, Length, Ptr : Address); 914 pragma Import (C, Get_Env_Value_Ptr, "__gnat_get_env_value_ptr"); 915 916 procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer); 917 pragma Import (C, Strncpy, "strncpy"); 918 919 Env_Value_Ptr : aliased Address; 920 Env_Value_Length : aliased Integer; 921 F_Name : aliased String (1 .. Name'Length + 1); 922 Result : String_Access; 923 924 begin 925 F_Name (1 .. Name'Length) := Name; 926 F_Name (F_Name'Last) := ASCII.NUL; 927 928 Get_Env_Value_Ptr 929 (F_Name'Address, Env_Value_Length'Address, Env_Value_Ptr'Address); 930 931 Result := new String (1 .. Env_Value_Length); 932 933 if Env_Value_Length > 0 then 934 Strncpy (Result.all'Address, Env_Value_Ptr, Env_Value_Length); 935 end if; 936 937 return Result; 938 end Getenv; 939 940 ------------ 941 -- GM_Day -- 942 ------------ 943 944 function GM_Day (Date : OS_Time) return Day_Type is 945 Y : Year_Type; 946 Mo : Month_Type; 947 D : Day_Type; 948 H : Hour_Type; 949 Mn : Minute_Type; 950 S : Second_Type; 951 952 begin 953 GM_Split (Date, Y, Mo, D, H, Mn, S); 954 return D; 955 end GM_Day; 956 957 ------------- 958 -- GM_Hour -- 959 ------------- 960 961 function GM_Hour (Date : OS_Time) return Hour_Type is 962 Y : Year_Type; 963 Mo : Month_Type; 964 D : Day_Type; 965 H : Hour_Type; 966 Mn : Minute_Type; 967 S : Second_Type; 968 969 begin 970 GM_Split (Date, Y, Mo, D, H, Mn, S); 971 return H; 972 end GM_Hour; 973 974 --------------- 975 -- GM_Minute -- 976 --------------- 977 978 function GM_Minute (Date : OS_Time) return Minute_Type is 979 Y : Year_Type; 980 Mo : Month_Type; 981 D : Day_Type; 982 H : Hour_Type; 983 Mn : Minute_Type; 984 S : Second_Type; 985 986 begin 987 GM_Split (Date, Y, Mo, D, H, Mn, S); 988 return Mn; 989 end GM_Minute; 990 991 -------------- 992 -- GM_Month -- 993 -------------- 994 995 function GM_Month (Date : OS_Time) return Month_Type is 996 Y : Year_Type; 997 Mo : Month_Type; 998 D : Day_Type; 999 H : Hour_Type; 1000 Mn : Minute_Type; 1001 S : Second_Type; 1002 1003 begin 1004 GM_Split (Date, Y, Mo, D, H, Mn, S); 1005 return Mo; 1006 end GM_Month; 1007 1008 --------------- 1009 -- GM_Second -- 1010 --------------- 1011 1012 function GM_Second (Date : OS_Time) return Second_Type is 1013 Y : Year_Type; 1014 Mo : Month_Type; 1015 D : Day_Type; 1016 H : Hour_Type; 1017 Mn : Minute_Type; 1018 S : Second_Type; 1019 1020 begin 1021 GM_Split (Date, Y, Mo, D, H, Mn, S); 1022 return S; 1023 end GM_Second; 1024 1025 -------------- 1026 -- GM_Split -- 1027 -------------- 1028 1029 procedure GM_Split 1030 (Date : OS_Time; 1031 Year : out Year_Type; 1032 Month : out Month_Type; 1033 Day : out Day_Type; 1034 Hour : out Hour_Type; 1035 Minute : out Minute_Type; 1036 Second : out Second_Type) 1037 is 1038 procedure To_GM_Time 1039 (P_Time_T, P_Year, P_Month, P_Day, P_Hours, P_Mins, P_Secs : Address); 1040 pragma Import (C, To_GM_Time, "__gnat_to_gm_time"); 1041 1042 T : OS_Time := Date; 1043 Y : Integer; 1044 Mo : Integer; 1045 D : Integer; 1046 H : Integer; 1047 Mn : Integer; 1048 S : Integer; 1049 1050 begin 1051 -- Use the global lock because To_GM_Time is not thread safe. 1052 1053 Locked_Processing : begin 1054 SSL.Lock_Task.all; 1055 To_GM_Time 1056 (T'Address, Y'Address, Mo'Address, D'Address, 1057 H'Address, Mn'Address, S'Address); 1058 SSL.Unlock_Task.all; 1059 1060 exception 1061 when others => 1062 SSL.Unlock_Task.all; 1063 raise; 1064 end Locked_Processing; 1065 1066 Year := Y + 1900; 1067 Month := Mo + 1; 1068 Day := D; 1069 Hour := H; 1070 Minute := Mn; 1071 Second := S; 1072 end GM_Split; 1073 1074 ------------- 1075 -- GM_Year -- 1076 ------------- 1077 1078 function GM_Year (Date : OS_Time) return Year_Type is 1079 Y : Year_Type; 1080 Mo : Month_Type; 1081 D : Day_Type; 1082 H : Hour_Type; 1083 Mn : Minute_Type; 1084 S : Second_Type; 1085 1086 begin 1087 GM_Split (Date, Y, Mo, D, H, Mn, S); 1088 return Y; 1089 end GM_Year; 1090 1091 ---------------------- 1092 -- Is_Absolute_Path -- 1093 ---------------------- 1094 1095 function Is_Absolute_Path (Name : String) return Boolean is 1096 function Is_Absolute_Path (Name : Address) return Integer; 1097 pragma Import (C, Is_Absolute_Path, "__gnat_is_absolute_path"); 1098 1099 F_Name : String (1 .. Name'Length + 1); 1100 1101 begin 1102 F_Name (1 .. Name'Length) := Name; 1103 F_Name (F_Name'Last) := ASCII.NUL; 1104 1105 return Is_Absolute_Path (F_Name'Address) /= 0; 1106 end Is_Absolute_Path; 1107 1108 ------------------ 1109 -- Is_Directory -- 1110 ------------------ 1111 1112 function Is_Directory (Name : C_File_Name) return Boolean is 1113 function Is_Directory (Name : Address) return Integer; 1114 pragma Import (C, Is_Directory, "__gnat_is_directory"); 1115 1116 begin 1117 return Is_Directory (Name) /= 0; 1118 end Is_Directory; 1119 1120 function Is_Directory (Name : String) return Boolean is 1121 F_Name : String (1 .. Name'Length + 1); 1122 1123 begin 1124 F_Name (1 .. Name'Length) := Name; 1125 F_Name (F_Name'Last) := ASCII.NUL; 1126 return Is_Directory (F_Name'Address); 1127 end Is_Directory; 1128 1129 --------------------- 1130 -- Is_Regular_File -- 1131 --------------------- 1132 1133 function Is_Regular_File (Name : C_File_Name) return Boolean is 1134 function Is_Regular_File (Name : Address) return Integer; 1135 pragma Import (C, Is_Regular_File, "__gnat_is_regular_file"); 1136 1137 begin 1138 return Is_Regular_File (Name) /= 0; 1139 end Is_Regular_File; 1140 1141 function Is_Regular_File (Name : String) return Boolean is 1142 F_Name : String (1 .. Name'Length + 1); 1143 1144 begin 1145 F_Name (1 .. Name'Length) := Name; 1146 F_Name (F_Name'Last) := ASCII.NUL; 1147 return Is_Regular_File (F_Name'Address); 1148 end Is_Regular_File; 1149 1150 ---------------------- 1151 -- Is_Readable_File -- 1152 ---------------------- 1153 1154 function Is_Readable_File (Name : C_File_Name) return Boolean is 1155 function Is_Readable_File (Name : Address) return Integer; 1156 pragma Import (C, Is_Readable_File, "__gnat_is_readable_file"); 1157 1158 begin 1159 return Is_Readable_File (Name) /= 0; 1160 end Is_Readable_File; 1161 1162 function Is_Readable_File (Name : String) return Boolean is 1163 F_Name : String (1 .. Name'Length + 1); 1164 1165 begin 1166 F_Name (1 .. Name'Length) := Name; 1167 F_Name (F_Name'Last) := ASCII.NUL; 1168 return Is_Readable_File (F_Name'Address); 1169 end Is_Readable_File; 1170 1171 ---------------------- 1172 -- Is_Writable_File -- 1173 ---------------------- 1174 1175 function Is_Writable_File (Name : C_File_Name) return Boolean is 1176 function Is_Writable_File (Name : Address) return Integer; 1177 pragma Import (C, Is_Writable_File, "__gnat_is_writable_file"); 1178 1179 begin 1180 return Is_Writable_File (Name) /= 0; 1181 end Is_Writable_File; 1182 1183 function Is_Writable_File (Name : String) return Boolean is 1184 F_Name : String (1 .. Name'Length + 1); 1185 1186 begin 1187 F_Name (1 .. Name'Length) := Name; 1188 F_Name (F_Name'Last) := ASCII.NUL; 1189 return Is_Writable_File (F_Name'Address); 1190 end Is_Writable_File; 1191 1192 ---------------------- 1193 -- Is_Symbolic_Link -- 1194 ---------------------- 1195 1196 function Is_Symbolic_Link (Name : C_File_Name) return Boolean is 1197 function Is_Symbolic_Link (Name : Address) return Integer; 1198 pragma Import (C, Is_Symbolic_Link, "__gnat_is_symbolic_link"); 1199 1200 begin 1201 return Is_Symbolic_Link (Name) /= 0; 1202 end Is_Symbolic_Link; 1203 1204 function Is_Symbolic_Link (Name : String) return Boolean is 1205 F_Name : String (1 .. Name'Length + 1); 1206 1207 begin 1208 F_Name (1 .. Name'Length) := Name; 1209 F_Name (F_Name'Last) := ASCII.NUL; 1210 return Is_Symbolic_Link (F_Name'Address); 1211 end Is_Symbolic_Link; 1212 1213 ------------------------- 1214 -- Locate_Exec_On_Path -- 1215 ------------------------- 1216 1217 function Locate_Exec_On_Path 1218 (Exec_Name : String) return String_Access 1219 is 1220 function Locate_Exec_On_Path (C_Exec_Name : Address) return Address; 1221 pragma Import (C, Locate_Exec_On_Path, "__gnat_locate_exec_on_path"); 1222 1223 procedure Free (Ptr : System.Address); 1224 pragma Import (C, Free, "free"); 1225 1226 C_Exec_Name : String (1 .. Exec_Name'Length + 1); 1227 Path_Addr : Address; 1228 Path_Len : Integer; 1229 Result : String_Access; 1230 1231 begin 1232 C_Exec_Name (1 .. Exec_Name'Length) := Exec_Name; 1233 C_Exec_Name (C_Exec_Name'Last) := ASCII.NUL; 1234 1235 Path_Addr := Locate_Exec_On_Path (C_Exec_Name'Address); 1236 Path_Len := C_String_Length (Path_Addr); 1237 1238 if Path_Len = 0 then 1239 return null; 1240 1241 else 1242 Result := To_Path_String_Access (Path_Addr, Path_Len); 1243 Free (Path_Addr); 1244 return Result; 1245 end if; 1246 end Locate_Exec_On_Path; 1247 1248 ------------------------- 1249 -- Locate_Regular_File -- 1250 ------------------------- 1251 1252 function Locate_Regular_File 1253 (File_Name : C_File_Name; 1254 Path : C_File_Name) return String_Access 1255 is 1256 function Locate_Regular_File 1257 (C_File_Name, Path_Val : Address) return Address; 1258 pragma Import (C, Locate_Regular_File, "__gnat_locate_regular_file"); 1259 1260 procedure Free (Ptr : System.Address); 1261 pragma Import (C, Free, "free"); 1262 1263 Path_Addr : Address; 1264 Path_Len : Integer; 1265 Result : String_Access; 1266 1267 begin 1268 Path_Addr := Locate_Regular_File (File_Name, Path); 1269 Path_Len := C_String_Length (Path_Addr); 1270 1271 if Path_Len = 0 then 1272 return null; 1273 else 1274 Result := To_Path_String_Access (Path_Addr, Path_Len); 1275 Free (Path_Addr); 1276 return Result; 1277 end if; 1278 end Locate_Regular_File; 1279 1280 function Locate_Regular_File 1281 (File_Name : String; 1282 Path : String) return String_Access 1283 is 1284 C_File_Name : String (1 .. File_Name'Length + 1); 1285 C_Path : String (1 .. Path'Length + 1); 1286 1287 begin 1288 C_File_Name (1 .. File_Name'Length) := File_Name; 1289 C_File_Name (C_File_Name'Last) := ASCII.NUL; 1290 1291 C_Path (1 .. Path'Length) := Path; 1292 C_Path (C_Path'Last) := ASCII.NUL; 1293 1294 return Locate_Regular_File (C_File_Name'Address, C_Path'Address); 1295 end Locate_Regular_File; 1296 1297 ------------------------ 1298 -- Non_Blocking_Spawn -- 1299 ------------------------ 1300 1301 function Non_Blocking_Spawn 1302 (Program_Name : String; 1303 Args : Argument_List) return Process_Id 1304 is 1305 Junk : Integer; 1306 Pid : Process_Id; 1307 1308 begin 1309 Spawn_Internal (Program_Name, Args, Junk, Pid, Blocking => False); 1310 return Pid; 1311 end Non_Blocking_Spawn; 1312 1313 ------------------------- 1314 -- Normalize_Arguments -- 1315 ------------------------- 1316 1317 procedure Normalize_Arguments (Args : in out Argument_List) is 1318 1319 procedure Quote_Argument (Arg : in out String_Access); 1320 -- Add quote around argument if it contains spaces 1321 1322 C_Argument_Needs_Quote : Integer; 1323 pragma Import (C, C_Argument_Needs_Quote, "__gnat_argument_needs_quote"); 1324 Argument_Needs_Quote : constant Boolean := C_Argument_Needs_Quote /= 0; 1325 1326 -------------------- 1327 -- Quote_Argument -- 1328 -------------------- 1329 1330 procedure Quote_Argument (Arg : in out String_Access) is 1331 Res : String (1 .. Arg'Length * 2); 1332 J : Positive := 1; 1333 Quote_Needed : Boolean := False; 1334 1335 begin 1336 if Arg (Arg'First) /= '"' or else Arg (Arg'Last) /= '"' then 1337 1338 -- Starting quote 1339 1340 Res (J) := '"'; 1341 1342 for K in Arg'Range loop 1343 1344 J := J + 1; 1345 1346 if Arg (K) = '"' then 1347 Res (J) := '\'; 1348 J := J + 1; 1349 Res (J) := '"'; 1350 Quote_Needed := True; 1351 1352 elsif Arg (K) = ' ' then 1353 Res (J) := Arg (K); 1354 Quote_Needed := True; 1355 1356 else 1357 Res (J) := Arg (K); 1358 end if; 1359 1360 end loop; 1361 1362 if Quote_Needed then 1363 1364 -- If null terminated string, put the quote before 1365 1366 if Res (J) = ASCII.Nul then 1367 Res (J) := '"'; 1368 J := J + 1; 1369 Res (J) := ASCII.Nul; 1370 1371 -- If argument is terminated by '\', then double it. Otherwise 1372 -- the ending quote will be taken as-is. This is quite strange 1373 -- spawn behavior from Windows, but this is what we see! 1374 1375 else 1376 if Res (J) = '\' then 1377 J := J + 1; 1378 Res (J) := '\'; 1379 end if; 1380 1381 -- Ending quote 1382 1383 J := J + 1; 1384 Res (J) := '"'; 1385 end if; 1386 1387 declare 1388 Old : String_Access := Arg; 1389 1390 begin 1391 Arg := new String'(Res (1 .. J)); 1392 Free (Old); 1393 end; 1394 end if; 1395 1396 end if; 1397 end Quote_Argument; 1398 1399 begin 1400 if Argument_Needs_Quote then 1401 for K in Args'Range loop 1402 if Args (K) /= null and then Args (K)'Length /= 0 then 1403 Quote_Argument (Args (K)); 1404 end if; 1405 end loop; 1406 end if; 1407 end Normalize_Arguments; 1408 1409 ------------------------ 1410 -- Normalize_Pathname -- 1411 ------------------------ 1412 1413 function Normalize_Pathname 1414 (Name : String; 1415 Directory : String := ""; 1416 Resolve_Links : Boolean := True; 1417 Case_Sensitive : Boolean := True) return String 1418 is 1419 Max_Path : Integer; 1420 pragma Import (C, Max_Path, "__gnat_max_path_len"); 1421 -- Maximum length of a path name 1422 1423 procedure Get_Current_Dir 1424 (Dir : System.Address; 1425 Length : System.Address); 1426 pragma Import (C, Get_Current_Dir, "__gnat_get_current_dir"); 1427 1428 function Change_Dir (Dir_Name : String) return Integer; 1429 pragma Import (C, Change_Dir, "chdir"); 1430 1431 Path_Buffer : String (1 .. Max_Path + Max_Path + 2); 1432 End_Path : Natural := 0; 1433 Link_Buffer : String (1 .. Max_Path + 2); 1434 Status : Integer; 1435 Last : Positive; 1436 Start : Natural; 1437 Finish : Positive; 1438 1439 Max_Iterations : constant := 500; 1440 1441 function Get_File_Names_Case_Sensitive return Integer; 1442 pragma Import 1443 (C, Get_File_Names_Case_Sensitive, 1444 "__gnat_get_file_names_case_sensitive"); 1445 1446 Fold_To_Lower_Case : constant Boolean := 1447 not Case_Sensitive 1448 and then Get_File_Names_Case_Sensitive = 0; 1449 1450 function Readlink 1451 (Path : System.Address; 1452 Buf : System.Address; 1453 Bufsiz : Integer) return Integer; 1454 pragma Import (C, Readlink, "__gnat_readlink"); 1455 1456 function To_Canonical_File_Spec 1457 (Host_File : System.Address) return System.Address; 1458 pragma Import 1459 (C, To_Canonical_File_Spec, "__gnat_to_canonical_file_spec"); 1460 1461 The_Name : String (1 .. Name'Length + 1); 1462 Canonical_File_Addr : System.Address; 1463 Canonical_File_Len : Integer; 1464 1465 Need_To_Check_Drive_Letter : Boolean := False; 1466 -- Set to true if Name is an absolute path that starts with "//" 1467 1468 function Strlen (S : System.Address) return Integer; 1469 pragma Import (C, Strlen, "strlen"); 1470 1471 function Get_Directory (Dir : String) return String; 1472 -- If Dir is not empty, return it, adding a directory separator 1473 -- if not already present, otherwise return current working directory 1474 -- with terminating directory separator. 1475 1476 function Final_Value (S : String) return String; 1477 -- Make final adjustment to the returned string. 1478 -- To compensate for non standard path name in Interix, 1479 -- if S is "/x" or starts with "/x", where x is a capital 1480 -- letter 'A' to 'Z', add an additional '/' at the beginning 1481 -- so that the returned value starts with "//x". 1482 1483 ------------------- 1484 -- Get_Directory -- 1485 ------------------- 1486 1487 function Get_Directory (Dir : String) return String is 1488 begin 1489 -- Directory given, add directory separator if needed 1490 1491 if Dir'Length > 0 then 1492 if Dir (Dir'Length) = Directory_Separator then 1493 return Directory; 1494 else 1495 declare 1496 Result : String (1 .. Dir'Length + 1); 1497 1498 begin 1499 Result (1 .. Dir'Length) := Dir; 1500 Result (Result'Length) := Directory_Separator; 1501 return Result; 1502 end; 1503 end if; 1504 1505 -- Directory name not given, get current directory 1506 1507 else 1508 declare 1509 Buffer : String (1 .. Max_Path + 2); 1510 Path_Len : Natural := Max_Path; 1511 1512 begin 1513 Get_Current_Dir (Buffer'Address, Path_Len'Address); 1514 1515 if Buffer (Path_Len) /= Directory_Separator then 1516 Path_Len := Path_Len + 1; 1517 Buffer (Path_Len) := Directory_Separator; 1518 end if; 1519 1520 return Buffer (1 .. Path_Len); 1521 end; 1522 end if; 1523 end Get_Directory; 1524 1525 Reference_Dir : constant String := Get_Directory (Directory); 1526 -- Current directory name specified 1527 1528 ----------------- 1529 -- Final_Value -- 1530 ----------------- 1531 1532 function Final_Value (S : String) return String is 1533 S1 : String := S; 1534 -- We may need to fold S to lower case, so we need a variable 1535 1536 begin 1537 -- Interix has the non standard notion of disk drive 1538 -- indicated by two '/' followed by a capital letter 1539 -- 'A' .. 'Z'. One of the two '/' may have been removed 1540 -- by Normalize_Pathname. It has to be added again. 1541 -- For other OSes, this should not make no difference. 1542 1543 if Need_To_Check_Drive_Letter 1544 and then S'Length >= 2 1545 and then S (S'First) = '/' 1546 and then S (S'First + 1) in 'A' .. 'Z' 1547 and then (S'Length = 2 or else S (S'First + 2) = '/') 1548 then 1549 declare 1550 Result : String (1 .. S'Length + 1); 1551 1552 begin 1553 Result (1) := '/'; 1554 Result (2 .. Result'Last) := S; 1555 1556 if Fold_To_Lower_Case then 1557 System.Case_Util.To_Lower (Result); 1558 end if; 1559 1560 return Result; 1561 1562 end; 1563 1564 else 1565 1566 if Fold_To_Lower_Case then 1567 System.Case_Util.To_Lower (S1); 1568 end if; 1569 1570 return S1; 1571 1572 end if; 1573 1574 end Final_Value; 1575 1576 -- Start of processing for Normalize_Pathname 1577 1578 begin 1579 -- Special case, if name is null, then return null 1580 1581 if Name'Length = 0 then 1582 return ""; 1583 end if; 1584 1585 -- First, convert VMS file spec to Unix file spec. 1586 -- If Name is not in VMS syntax, then this is equivalent 1587 -- to put Name at the begining of Path_Buffer. 1588 1589 VMS_Conversion : begin 1590 The_Name (1 .. Name'Length) := Name; 1591 The_Name (The_Name'Last) := ASCII.NUL; 1592 1593 Canonical_File_Addr := To_Canonical_File_Spec (The_Name'Address); 1594 Canonical_File_Len := Strlen (Canonical_File_Addr); 1595 1596 -- If VMS syntax conversion has failed, return an empty string 1597 -- to indicate the failure. 1598 1599 if Canonical_File_Len = 0 then 1600 return ""; 1601 end if; 1602 1603 declare 1604 subtype Path_String is String (1 .. Canonical_File_Len); 1605 type Path_String_Access is access Path_String; 1606 1607 function Address_To_Access is new 1608 Unchecked_Conversion (Source => Address, 1609 Target => Path_String_Access); 1610 1611 Path_Access : constant Path_String_Access := 1612 Address_To_Access (Canonical_File_Addr); 1613 1614 begin 1615 Path_Buffer (1 .. Canonical_File_Len) := Path_Access.all; 1616 End_Path := Canonical_File_Len; 1617 Last := 1; 1618 end; 1619 end VMS_Conversion; 1620 1621 -- Replace all '/' by Directory Separators (this is for Windows) 1622 1623 if Directory_Separator /= '/' then 1624 for Index in 1 .. End_Path loop 1625 if Path_Buffer (Index) = '/' then 1626 Path_Buffer (Index) := Directory_Separator; 1627 end if; 1628 end loop; 1629 end if; 1630 1631 -- Resolving logical names from VMS. 1632 -- If we have a Unix path on VMS such as /temp/..., and TEMP is a 1633 -- logical name, we need to resolve this logical name. 1634 -- As we have no means to know if we are on VMS, we need to do that 1635 -- for absolute paths starting with '/'. 1636 -- We find the directory, change to it, get the current directory, 1637 -- and change the directory to this value. 1638 1639 if Path_Buffer (1) = '/' then 1640 declare 1641 Cur_Dir : String := Get_Directory (""); 1642 -- Save the current directory, so that we can change dir back to 1643 -- it. It is not a constant, because the last character (a 1644 -- directory separator) is changed to ASCII.NUL to call the C 1645 -- function chdir. 1646 1647 Path : String := Path_Buffer (1 .. End_Path + 1); 1648 -- Copy of the current path. One character is added that may be 1649 -- set to ASCII.NUL to call chdir. 1650 1651 Pos : Positive := End_Path; 1652 -- Position of the last directory separator ('/') 1653 1654 Status : Integer; 1655 -- Value returned by chdir 1656 1657 begin 1658 -- Look for the last '/' 1659 1660 while Path (Pos) /= '/' loop 1661 Pos := Pos - 1; 1662 end loop; 1663 1664 -- Get the previous character that is not a '/' 1665 1666 while Pos > 1 and then Path (Pos) = '/' loop 1667 Pos := Pos - 1; 1668 end loop; 1669 1670 -- If we are at the start of the path, take the full path. 1671 -- It may be a file in the root directory, but it may also be 1672 -- a subdirectory of the root directory. 1673 1674 if Pos = 1 then 1675 Pos := End_Path; 1676 end if; 1677 1678 -- Add the ASCII.NUL to be able to call the C function chdir 1679 Path (Pos + 1) := ASCII.NUL; 1680 1681 Status := Change_Dir (Path (1 .. Pos + 1)); 1682 1683 -- If Status is not zero, then we do nothing: this is a file 1684 -- path or it is not a valid directory path. 1685 1686 if Status = 0 then 1687 declare 1688 New_Dir : constant String := Get_Directory (""); 1689 -- The directory path 1690 1691 New_Path : String (1 .. New_Dir'Length + End_Path - Pos); 1692 -- The new complete path, that is built below 1693 1694 begin 1695 New_Path (1 .. New_Dir'Length) := New_Dir; 1696 New_Path (New_Dir'Length + 1 .. New_Path'Last) := 1697 Path_Buffer (Pos + 1 .. End_Path); 1698 End_Path := New_Path'Length; 1699 Path_Buffer (1 .. End_Path) := New_Path; 1700 end; 1701 1702 -- Back to where we were before 1703 1704 Cur_Dir (Cur_Dir'Last) := ASCII.NUL; 1705 Status := Change_Dir (Cur_Dir); 1706 end if; 1707 end; 1708 end if; 1709 1710 -- Start the conversions 1711 1712 -- If this is not finished after Max_Iterations, give up and 1713 -- return an empty string. 1714 1715 for J in 1 .. Max_Iterations loop 1716 1717 -- If we don't have an absolute pathname, prepend 1718 -- the directory Reference_Dir. 1719 1720 if Last = 1 1721 and then not Is_Absolute_Path (Path_Buffer (1 .. End_Path)) 1722 then 1723 Path_Buffer 1724 (Reference_Dir'Last + 1 .. Reference_Dir'Length + End_Path) := 1725 Path_Buffer (1 .. End_Path); 1726 End_Path := Reference_Dir'Length + End_Path; 1727 Path_Buffer (1 .. Reference_Dir'Length) := Reference_Dir; 1728 Last := Reference_Dir'Length; 1729 end if; 1730 1731 -- If name starts with "//", we may have a drive letter on Interix 1732 1733 if Last = 1 and then End_Path >= 3 then 1734 Need_To_Check_Drive_Letter := (Path_Buffer (1 .. 2)) = "//"; 1735 end if; 1736 1737 Start := Last + 1; 1738 Finish := Last; 1739 1740 -- Ensure that Windows network drives are kept, e.g: \\server\drive-c 1741 1742 if Start = 2 1743 and then Directory_Separator = '\' 1744 and then Path_Buffer (1 .. 2) = "\\" 1745 then 1746 Start := 3; 1747 end if; 1748 1749 -- If we have traversed the full pathname, return it 1750 1751 if Start > End_Path then 1752 return Final_Value (Path_Buffer (1 .. End_Path)); 1753 end if; 1754 1755 -- Remove duplicate directory separators 1756 1757 while Path_Buffer (Start) = Directory_Separator loop 1758 if Start = End_Path then 1759 return Final_Value (Path_Buffer (1 .. End_Path - 1)); 1760 1761 else 1762 Path_Buffer (Start .. End_Path - 1) := 1763 Path_Buffer (Start + 1 .. End_Path); 1764 End_Path := End_Path - 1; 1765 end if; 1766 end loop; 1767 1768 -- Find the end of the current field: last character 1769 -- or the one preceding the next directory separator. 1770 1771 while Finish < End_Path 1772 and then Path_Buffer (Finish + 1) /= Directory_Separator 1773 loop 1774 Finish := Finish + 1; 1775 end loop; 1776 1777 -- Remove "." field 1778 1779 if Start = Finish and then Path_Buffer (Start) = '.' then 1780 if Start = End_Path then 1781 if Last = 1 then 1782 return (1 => Directory_Separator); 1783 else 1784 1785 if Fold_To_Lower_Case then 1786 System.Case_Util.To_Lower (Path_Buffer (1 .. Last - 1)); 1787 end if; 1788 1789 return Path_Buffer (1 .. Last - 1); 1790 1791 end if; 1792 1793 else 1794 Path_Buffer (Last + 1 .. End_Path - 2) := 1795 Path_Buffer (Last + 3 .. End_Path); 1796 End_Path := End_Path - 2; 1797 end if; 1798 1799 -- Remove ".." fields 1800 1801 elsif Finish = Start + 1 1802 and then Path_Buffer (Start .. Finish) = ".." 1803 then 1804 Start := Last; 1805 loop 1806 Start := Start - 1; 1807 exit when Start < 1 or else 1808 Path_Buffer (Start) = Directory_Separator; 1809 end loop; 1810 1811 if Start <= 1 then 1812 if Finish = End_Path then 1813 return (1 => Directory_Separator); 1814 1815 else 1816 Path_Buffer (1 .. End_Path - Finish) := 1817 Path_Buffer (Finish + 1 .. End_Path); 1818 End_Path := End_Path - Finish; 1819 Last := 1; 1820 end if; 1821 1822 else 1823 if Finish = End_Path then 1824 return Final_Value (Path_Buffer (1 .. Start - 1)); 1825 1826 else 1827 Path_Buffer (Start + 1 .. Start + End_Path - Finish - 1) := 1828 Path_Buffer (Finish + 2 .. End_Path); 1829 End_Path := Start + End_Path - Finish - 1; 1830 Last := Start; 1831 end if; 1832 end if; 1833 1834 -- Check if current field is a symbolic link 1835 1836 elsif Resolve_Links then 1837 declare 1838 Saved : constant Character := Path_Buffer (Finish + 1); 1839 1840 begin 1841 Path_Buffer (Finish + 1) := ASCII.NUL; 1842 Status := Readlink (Path_Buffer'Address, 1843 Link_Buffer'Address, 1844 Link_Buffer'Length); 1845 Path_Buffer (Finish + 1) := Saved; 1846 end; 1847 1848 -- Not a symbolic link, move to the next field, if any 1849 1850 if Status <= 0 then 1851 Last := Finish + 1; 1852 1853 -- Replace symbolic link with its value. 1854 1855 else 1856 if Is_Absolute_Path (Link_Buffer (1 .. Status)) then 1857 Path_Buffer (Status + 1 .. End_Path - (Finish - Status)) := 1858 Path_Buffer (Finish + 1 .. End_Path); 1859 End_Path := End_Path - (Finish - Status); 1860 Path_Buffer (1 .. Status) := Link_Buffer (1 .. Status); 1861 Last := 1; 1862 1863 else 1864 Path_Buffer 1865 (Last + Status + 1 .. End_Path - Finish + Last + Status) := 1866 Path_Buffer (Finish + 1 .. End_Path); 1867 End_Path := End_Path - Finish + Last + Status; 1868 Path_Buffer (Last + 1 .. Last + Status) := 1869 Link_Buffer (1 .. Status); 1870 end if; 1871 end if; 1872 1873 else 1874 Last := Finish + 1; 1875 end if; 1876 end loop; 1877 1878 -- Too many iterations: give up 1879 1880 -- This can happen when there is a circularity in the symbolic links: 1881 -- A is a symbolic link for B, which itself is a symbolic link, and 1882 -- the target of B or of another symbolic link target of B is A. 1883 -- In this case, we return an empty string to indicate failure to 1884 -- resolve. 1885 1886 return ""; 1887 end Normalize_Pathname; 1888 1889 --------------- 1890 -- Open_Read -- 1891 --------------- 1892 1893 function Open_Read 1894 (Name : C_File_Name; 1895 Fmode : Mode) return File_Descriptor 1896 is 1897 function C_Open_Read 1898 (Name : C_File_Name; 1899 Fmode : Mode) return File_Descriptor; 1900 pragma Import (C, C_Open_Read, "__gnat_open_read"); 1901 1902 begin 1903 return C_Open_Read (Name, Fmode); 1904 end Open_Read; 1905 1906 function Open_Read 1907 (Name : String; 1908 Fmode : Mode) return File_Descriptor 1909 is 1910 C_Name : String (1 .. Name'Length + 1); 1911 1912 begin 1913 C_Name (1 .. Name'Length) := Name; 1914 C_Name (C_Name'Last) := ASCII.NUL; 1915 return Open_Read (C_Name (C_Name'First)'Address, Fmode); 1916 end Open_Read; 1917 1918 --------------------- 1919 -- Open_Read_Write -- 1920 --------------------- 1921 1922 function Open_Read_Write 1923 (Name : C_File_Name; 1924 Fmode : Mode) return File_Descriptor 1925 is 1926 function C_Open_Read_Write 1927 (Name : C_File_Name; 1928 Fmode : Mode) return File_Descriptor; 1929 pragma Import (C, C_Open_Read_Write, "__gnat_open_rw"); 1930 1931 begin 1932 return C_Open_Read_Write (Name, Fmode); 1933 end Open_Read_Write; 1934 1935 function Open_Read_Write 1936 (Name : String; 1937 Fmode : Mode) return File_Descriptor 1938 is 1939 C_Name : String (1 .. Name'Length + 1); 1940 1941 begin 1942 C_Name (1 .. Name'Length) := Name; 1943 C_Name (C_Name'Last) := ASCII.NUL; 1944 return Open_Read_Write (C_Name (C_Name'First)'Address, Fmode); 1945 end Open_Read_Write; 1946 1947 ---------- 1948 -- Read -- 1949 ---------- 1950 1951 function Read 1952 (FD : File_Descriptor; 1953 A : System.Address; 1954 N : Integer) return Integer 1955 is 1956 begin 1957 return Integer (System.CRTL.read 1958 (System.CRTL.int (FD), System.CRTL.chars (A), System.CRTL.int (N))); 1959 end Read; 1960 1961 ----------------- 1962 -- Rename_File -- 1963 ----------------- 1964 1965 procedure Rename_File 1966 (Old_Name : C_File_Name; 1967 New_Name : C_File_Name; 1968 Success : out Boolean) 1969 is 1970 function rename (From, To : Address) return Integer; 1971 pragma Import (C, rename, "rename"); 1972 1973 R : Integer; 1974 1975 begin 1976 R := rename (Old_Name, New_Name); 1977 Success := (R = 0); 1978 end Rename_File; 1979 1980 procedure Rename_File 1981 (Old_Name : String; 1982 New_Name : String; 1983 Success : out Boolean) 1984 is 1985 C_Old_Name : String (1 .. Old_Name'Length + 1); 1986 C_New_Name : String (1 .. New_Name'Length + 1); 1987 1988 begin 1989 C_Old_Name (1 .. Old_Name'Length) := Old_Name; 1990 C_Old_Name (C_Old_Name'Last) := ASCII.NUL; 1991 1992 C_New_Name (1 .. New_Name'Length) := New_Name; 1993 C_New_Name (C_New_Name'Last) := ASCII.NUL; 1994 1995 Rename_File (C_Old_Name'Address, C_New_Name'Address, Success); 1996 end Rename_File; 1997 1998 ------------ 1999 -- Setenv -- 2000 ------------ 2001 2002 procedure Setenv (Name : String; Value : String) is 2003 F_Name : String (1 .. Name'Length + 1); 2004 F_Value : String (1 .. Value'Length + 1); 2005 2006 procedure Set_Env_Value (Name, Value : System.Address); 2007 pragma Import (C, Set_Env_Value, "__gnat_set_env_value"); 2008 2009 begin 2010 F_Name (1 .. Name'Length) := Name; 2011 F_Name (F_Name'Last) := ASCII.NUL; 2012 2013 F_Value (1 .. Value'Length) := Value; 2014 F_Value (F_Value'Last) := ASCII.NUL; 2015 2016 Set_Env_Value (F_Name'Address, F_Value'Address); 2017 end Setenv; 2018 2019 ----------- 2020 -- Spawn -- 2021 ----------- 2022 2023 function Spawn 2024 (Program_Name : String; 2025 Args : Argument_List) return Integer 2026 is 2027 Junk : Process_Id; 2028 Result : Integer; 2029 2030 begin 2031 Spawn_Internal (Program_Name, Args, Result, Junk, Blocking => True); 2032 return Result; 2033 end Spawn; 2034 2035 procedure Spawn 2036 (Program_Name : String; 2037 Args : Argument_List; 2038 Success : out Boolean) 2039 is 2040 begin 2041 Success := (Spawn (Program_Name, Args) = 0); 2042 end Spawn; 2043 2044 -------------------- 2045 -- Spawn_Internal -- 2046 -------------------- 2047 2048 procedure Spawn_Internal 2049 (Program_Name : String; 2050 Args : Argument_List; 2051 Result : out Integer; 2052 Pid : out Process_Id; 2053 Blocking : Boolean) 2054 is 2055 2056 procedure Spawn (Args : Argument_List); 2057 -- Call Spawn. 2058 2059 N_Args : Argument_List (Args'Range); 2060 -- Normalized arguments 2061 2062 ----------- 2063 -- Spawn -- 2064 ----------- 2065 2066 procedure Spawn (Args : Argument_List) is 2067 type Chars is array (Positive range <>) of aliased Character; 2068 type Char_Ptr is access constant Character; 2069 2070 Command_Len : constant Positive := Program_Name'Length + 1 2071 + Args_Length (Args); 2072 Command_Last : Natural := 0; 2073 Command : aliased Chars (1 .. Command_Len); 2074 -- Command contains all characters of the Program_Name and Args, 2075 -- all terminated by ASCII.NUL characters 2076 2077 Arg_List_Len : constant Positive := Args'Length + 2; 2078 Arg_List_Last : Natural := 0; 2079 Arg_List : aliased array (1 .. Arg_List_Len) of Char_Ptr; 2080 -- List with pointers to NUL-terminated strings of the 2081 -- Program_Name and the Args and terminated with a null pointer. 2082 -- We rely on the default initialization for the last null pointer. 2083 2084 procedure Add_To_Command (S : String); 2085 -- Add S and a NUL character to Command, updating Last 2086 2087 function Portable_Spawn (Args : Address) return Integer; 2088 pragma Import (C, Portable_Spawn, "__gnat_portable_spawn"); 2089 2090 function Portable_No_Block_Spawn (Args : Address) return Process_Id; 2091 pragma Import 2092 (C, Portable_No_Block_Spawn, "__gnat_portable_no_block_spawn"); 2093 2094 -------------------- 2095 -- Add_To_Command -- 2096 -------------------- 2097 2098 procedure Add_To_Command (S : String) is 2099 First : constant Natural := Command_Last + 1; 2100 2101 begin 2102 Command_Last := Command_Last + S'Length; 2103 2104 -- Move characters one at a time, because Command has 2105 -- aliased components. 2106 2107 for J in S'Range loop 2108 Command (First + J - S'First) := S (J); 2109 end loop; 2110 2111 Command_Last := Command_Last + 1; 2112 Command (Command_Last) := ASCII.NUL; 2113 2114 Arg_List_Last := Arg_List_Last + 1; 2115 Arg_List (Arg_List_Last) := Command (First)'Access; 2116 end Add_To_Command; 2117 2118 -- Start of processing for Spawn 2119 2120 begin 2121 Add_To_Command (Program_Name); 2122 2123 for J in Args'Range loop 2124 Add_To_Command (Args (J).all); 2125 end loop; 2126 2127 if Blocking then 2128 Pid := Invalid_Pid; 2129 Result := Portable_Spawn (Arg_List'Address); 2130 else 2131 Pid := Portable_No_Block_Spawn (Arg_List'Address); 2132 Result := Boolean'Pos (Pid /= Invalid_Pid); 2133 end if; 2134 end Spawn; 2135 2136 -- Start of processing for Spawn_Internal 2137 2138 begin 2139 -- Copy arguments into a local structure 2140 2141 for K in N_Args'Range loop 2142 N_Args (K) := new String'(Args (K).all); 2143 end loop; 2144 2145 -- Normalize those arguments 2146 2147 Normalize_Arguments (N_Args); 2148 2149 -- Call spawn using the normalized arguments 2150 2151 Spawn (N_Args); 2152 2153 -- Free arguments list 2154 2155 for K in N_Args'Range loop 2156 Free (N_Args (K)); 2157 end loop; 2158 end Spawn_Internal; 2159 2160 --------------------------- 2161 -- To_Path_String_Access -- 2162 --------------------------- 2163 2164 function To_Path_String_Access 2165 (Path_Addr : Address; 2166 Path_Len : Integer) return String_Access 2167 is 2168 subtype Path_String is String (1 .. Path_Len); 2169 type Path_String_Access is access Path_String; 2170 2171 function Address_To_Access is new 2172 Unchecked_Conversion (Source => Address, 2173 Target => Path_String_Access); 2174 2175 Path_Access : constant Path_String_Access := 2176 Address_To_Access (Path_Addr); 2177 2178 Return_Val : String_Access; 2179 2180 begin 2181 Return_Val := new String (1 .. Path_Len); 2182 2183 for J in 1 .. Path_Len loop 2184 Return_Val (J) := Path_Access (J); 2185 end loop; 2186 2187 return Return_Val; 2188 end To_Path_String_Access; 2189 2190 ------------------ 2191 -- Wait_Process -- 2192 ------------------ 2193 2194 procedure Wait_Process (Pid : out Process_Id; Success : out Boolean) is 2195 Status : Integer; 2196 2197 function Portable_Wait (S : Address) return Process_Id; 2198 pragma Import (C, Portable_Wait, "__gnat_portable_wait"); 2199 2200 begin 2201 Pid := Portable_Wait (Status'Address); 2202 Success := (Status = 0); 2203 end Wait_Process; 2204 2205 ----------- 2206 -- Write -- 2207 ----------- 2208 2209 function Write 2210 (FD : File_Descriptor; 2211 A : System.Address; 2212 N : Integer) return Integer 2213 is 2214 begin 2215 return Integer (System.CRTL.write 2216 (System.CRTL.int (FD), System.CRTL.chars (A), System.CRTL.int (N))); 2217 end Write; 2218 2219end GNAT.OS_Lib; 2220