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