gcc/ada/g-os_lib.adb

   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
  34 with System.Case_Util;
  35 with System.CRTL;
  36 with System.Soft_Links;
  37 with Unchecked_Conversion;
  38 with System; use System;
  39
  40 package 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
2219 end GNAT.OS_Lib;