| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT COMPILER COMPONENTS -- |
| -- -- |
| -- S Y S T E M . O S _ L I B -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 1995-2010, AdaCore -- |
| -- -- |
| -- GNAT is free software; you can redistribute it and/or modify it under -- |
| -- terms of the GNU General Public License as published by the Free Soft- -- |
| -- ware Foundation; either version 3, or (at your option) any later ver- -- |
| -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- |
| -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- |
| -- or FITNESS FOR A PARTICULAR PURPOSE. -- |
| -- -- |
| -- As a special exception under Section 7 of GPL version 3, you are granted -- |
| -- additional permissions described in the GCC Runtime Library Exception, -- |
| -- version 3.1, as published by the Free Software Foundation. -- |
| -- -- |
| -- You should have received a copy of the GNU General Public License and -- |
| -- a copy of the GCC Runtime Library Exception along with this program; -- |
| -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- |
| -- <http://www.gnu.org/licenses/>. -- |
| -- -- |
| -- GNAT was originally developed by the GNAT team at New York University. -- |
| -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
| -- -- |
| ------------------------------------------------------------------------------ |
| |
| pragma Compiler_Unit; |
| |
| with System.Case_Util; |
| with System.CRTL; |
| with System.Soft_Links; |
| with Ada.Unchecked_Conversion; |
| with Ada.Unchecked_Deallocation; |
| with System; use System; |
| |
| package body System.OS_Lib is |
| |
| -- Imported procedures Dup and Dup2 are used in procedures Spawn and |
| -- Non_Blocking_Spawn. |
| |
| function Dup (Fd : File_Descriptor) return File_Descriptor; |
| pragma Import (C, Dup, "__gnat_dup"); |
| |
| procedure Dup2 (Old_Fd, New_Fd : File_Descriptor); |
| pragma Import (C, Dup2, "__gnat_dup2"); |
| |
| On_Windows : constant Boolean := Directory_Separator = '\'; |
| -- An indication that we are on Windows. Used in Normalize_Pathname, to |
| -- deal with drive letters in the beginning of absolute paths. |
| |
| package SSL renames System.Soft_Links; |
| |
| -- The following are used by Create_Temp_File |
| |
| First_Temp_File_Name : constant String := "GNAT-TEMP-000000.TMP"; |
| -- Used to initialize Current_Temp_File_Name and Temp_File_Name_Last_Digit |
| |
| Current_Temp_File_Name : String := First_Temp_File_Name; |
| -- Name of the temp file last created |
| |
| Temp_File_Name_Last_Digit : constant Positive := |
| First_Temp_File_Name'Last - 4; |
| -- Position of the last digit in Current_Temp_File_Name |
| |
| Max_Attempts : constant := 100; |
| -- The maximum number of attempts to create a new temp file |
| |
| ----------------------- |
| -- Local Subprograms -- |
| ----------------------- |
| |
| function Args_Length (Args : Argument_List) return Natural; |
| -- Returns total number of characters needed to create a string of all Args |
| -- terminated by ASCII.NUL characters. |
| |
| procedure Create_Temp_File_Internal |
| (FD : out File_Descriptor; |
| Name : out String_Access; |
| Stdout : Boolean); |
| -- Internal routine to implement two Create_Temp_File routines. If Stdout |
| -- is set to True the created descriptor is stdout-compatible, otherwise |
| -- it might not be depending on the OS (VMS is one example). The first two |
| -- parameters are as in Create_Temp_File. |
| |
| function C_String_Length (S : Address) return Integer; |
| -- Returns the length of a C string. Does check for null address |
| -- (returns 0). |
| |
| procedure Spawn_Internal |
| (Program_Name : String; |
| Args : Argument_List; |
| Result : out Integer; |
| Pid : out Process_Id; |
| Blocking : Boolean); |
| -- Internal routine to implement the two Spawn (blocking/non blocking) |
| -- routines. If Blocking is set to True then the spawn is blocking |
| -- otherwise it is non blocking. In this latter case the Pid contains the |
| -- process id number. The first three parameters are as in Spawn. Note that |
| -- Spawn_Internal normalizes the argument list before calling the low level |
| -- system spawn routines (see Normalize_Arguments). |
| -- |
| -- Note: Normalize_Arguments is designed to do nothing if it is called more |
| -- than once, so calling Normalize_Arguments before calling one of the |
| -- spawn routines is fine. |
| |
| function To_Path_String_Access |
| (Path_Addr : Address; |
| Path_Len : Integer) return String_Access; |
| -- Converts a C String to an Ada String. We could do this making use of |
| -- Interfaces.C.Strings but we prefer not to import that entire package |
| |
| --------- |
| -- "<" -- |
| --------- |
| |
| function "<" (X, Y : OS_Time) return Boolean is |
| begin |
| return Long_Integer (X) < Long_Integer (Y); |
| end "<"; |
| |
| ---------- |
| -- "<=" -- |
| ---------- |
| |
| function "<=" (X, Y : OS_Time) return Boolean is |
| begin |
| return Long_Integer (X) <= Long_Integer (Y); |
| end "<="; |
| |
| --------- |
| -- ">" -- |
| --------- |
| |
| function ">" (X, Y : OS_Time) return Boolean is |
| begin |
| return Long_Integer (X) > Long_Integer (Y); |
| end ">"; |
| |
| ---------- |
| -- ">=" -- |
| ---------- |
| |
| function ">=" (X, Y : OS_Time) return Boolean is |
| begin |
| return Long_Integer (X) >= Long_Integer (Y); |
| end ">="; |
| |
| ----------------- |
| -- Args_Length -- |
| ----------------- |
| |
| function Args_Length (Args : Argument_List) return Natural is |
| Len : Natural := 0; |
| |
| begin |
| for J in Args'Range loop |
| Len := Len + Args (J)'Length + 1; -- One extra for ASCII.NUL |
| end loop; |
| |
| return Len; |
| end Args_Length; |
| |
| ----------------------------- |
| -- Argument_String_To_List -- |
| ----------------------------- |
| |
| function Argument_String_To_List |
| (Arg_String : String) return Argument_List_Access |
| is |
| Max_Args : constant Integer := Arg_String'Length; |
| New_Argv : Argument_List (1 .. Max_Args); |
| New_Argc : Natural := 0; |
| Idx : Integer; |
| |
| begin |
| Idx := Arg_String'First; |
| |
| loop |
| exit when Idx > Arg_String'Last; |
| |
| declare |
| Quoted : Boolean := False; |
| Backqd : Boolean := False; |
| Old_Idx : Integer; |
| |
| begin |
| Old_Idx := Idx; |
| |
| loop |
| -- An unquoted space is the end of an argument |
| |
| if not (Backqd or Quoted) |
| and then Arg_String (Idx) = ' ' |
| then |
| exit; |
| |
| -- Start of a quoted string |
| |
| elsif not (Backqd or Quoted) |
| and then Arg_String (Idx) = '"' |
| then |
| Quoted := True; |
| |
| -- End of a quoted string and end of an argument |
| |
| elsif (Quoted and not Backqd) |
| and then Arg_String (Idx) = '"' |
| then |
| Idx := Idx + 1; |
| exit; |
| |
| -- Following character is backquoted |
| |
| elsif Arg_String (Idx) = '\' then |
| Backqd := True; |
| |
| -- Turn off backquoting after advancing one character |
| |
| elsif Backqd then |
| Backqd := False; |
| |
| end if; |
| |
| Idx := Idx + 1; |
| exit when Idx > Arg_String'Last; |
| end loop; |
| |
| -- Found an argument |
| |
| New_Argc := New_Argc + 1; |
| New_Argv (New_Argc) := |
| new String'(Arg_String (Old_Idx .. Idx - 1)); |
| |
| -- Skip extraneous spaces |
| |
| while Idx <= Arg_String'Last and then Arg_String (Idx) = ' ' loop |
| Idx := Idx + 1; |
| end loop; |
| end; |
| end loop; |
| |
| return new Argument_List'(New_Argv (1 .. New_Argc)); |
| end Argument_String_To_List; |
| |
| --------------------- |
| -- C_String_Length -- |
| --------------------- |
| |
| function C_String_Length (S : Address) return Integer is |
| function Strlen (S : Address) return Integer; |
| pragma Import (C, Strlen, "strlen"); |
| begin |
| if S = Null_Address then |
| return 0; |
| else |
| return Strlen (S); |
| end if; |
| end C_String_Length; |
| |
| ----------- |
| -- Close -- |
| ----------- |
| |
| procedure Close (FD : File_Descriptor) is |
| procedure C_Close (FD : File_Descriptor); |
| pragma Import (C, C_Close, "close"); |
| begin |
| C_Close (FD); |
| end Close; |
| |
| procedure Close (FD : File_Descriptor; Status : out Boolean) is |
| function C_Close (FD : File_Descriptor) return Integer; |
| pragma Import (C, C_Close, "close"); |
| begin |
| Status := (C_Close (FD) = 0); |
| end Close; |
| |
| --------------- |
| -- Copy_File -- |
| --------------- |
| |
| procedure Copy_File |
| (Name : String; |
| Pathname : String; |
| Success : out Boolean; |
| Mode : Copy_Mode := Copy; |
| Preserve : Attribute := Time_Stamps) |
| is |
| From : File_Descriptor; |
| To : File_Descriptor; |
| |
| Copy_Error : exception; |
| -- Internal exception raised to signal error in copy |
| |
| function Build_Path (Dir : String; File : String) return String; |
| -- Returns pathname Dir concatenated with File adding the directory |
| -- separator only if needed. |
| |
| procedure Copy (From, To : File_Descriptor); |
| -- Read data from From and place them into To. In both cases the |
| -- operations uses the current file position. Raises Constraint_Error |
| -- if a problem occurs during the copy. |
| |
| procedure Copy_To (To_Name : String); |
| -- Does a straight copy from source to designated destination file |
| |
| ---------------- |
| -- Build_Path -- |
| ---------------- |
| |
| function Build_Path (Dir : String; File : String) return String is |
| Res : String (1 .. Dir'Length + File'Length + 1); |
| |
| Base_File_Ptr : Integer; |
| -- The base file name is File (Base_File_Ptr + 1 .. File'Last) |
| |
| function Is_Dirsep (C : Character) return Boolean; |
| pragma Inline (Is_Dirsep); |
| -- Returns True if C is a directory separator. On Windows we |
| -- handle both styles of directory separator. |
| |
| --------------- |
| -- Is_Dirsep -- |
| --------------- |
| |
| function Is_Dirsep (C : Character) return Boolean is |
| begin |
| return C = Directory_Separator or else C = '/'; |
| end Is_Dirsep; |
| |
| -- Start of processing for Build_Path |
| |
| begin |
| -- Find base file name |
| |
| Base_File_Ptr := File'Last; |
| while Base_File_Ptr >= File'First loop |
| exit when Is_Dirsep (File (Base_File_Ptr)); |
| Base_File_Ptr := Base_File_Ptr - 1; |
| end loop; |
| |
| declare |
| Base_File : String renames |
| File (Base_File_Ptr + 1 .. File'Last); |
| |
| begin |
| Res (1 .. Dir'Length) := Dir; |
| |
| if Is_Dirsep (Dir (Dir'Last)) then |
| Res (Dir'Length + 1 .. Dir'Length + Base_File'Length) := |
| Base_File; |
| return Res (1 .. Dir'Length + Base_File'Length); |
| |
| else |
| Res (Dir'Length + 1) := Directory_Separator; |
| Res (Dir'Length + 2 .. Dir'Length + 1 + Base_File'Length) := |
| Base_File; |
| return Res (1 .. Dir'Length + 1 + Base_File'Length); |
| end if; |
| end; |
| end Build_Path; |
| |
| ---------- |
| -- Copy -- |
| ---------- |
| |
| procedure Copy (From, To : File_Descriptor) is |
| Buf_Size : constant := 200_000; |
| type Buf is array (1 .. Buf_Size) of Character; |
| type Buf_Ptr is access Buf; |
| |
| Buffer : Buf_Ptr; |
| R : Integer; |
| W : Integer; |
| |
| Status_From : Boolean; |
| Status_To : Boolean; |
| -- Statuses for the calls to Close |
| |
| procedure Free is new Ada.Unchecked_Deallocation (Buf, Buf_Ptr); |
| |
| begin |
| -- Check for invalid descriptors, making sure that we do not |
| -- accidentally leave an open file descriptor around. |
| |
| if From = Invalid_FD then |
| if To /= Invalid_FD then |
| Close (To, Status_To); |
| end if; |
| |
| raise Copy_Error; |
| |
| elsif To = Invalid_FD then |
| Close (From, Status_From); |
| raise Copy_Error; |
| end if; |
| |
| -- Allocate the buffer on the heap |
| |
| Buffer := new Buf; |
| |
| loop |
| R := Read (From, Buffer (1)'Address, Buf_Size); |
| |
| -- For VMS, the buffer may not be full. So, we need to try again |
| -- until there is nothing to read. |
| |
| exit when R = 0; |
| |
| W := Write (To, Buffer (1)'Address, R); |
| |
| if W < R then |
| |
| -- Problem writing data, could be a disk full. Close files |
| -- without worrying about status, since we are raising a |
| -- Copy_Error exception in any case. |
| |
| Close (From, Status_From); |
| Close (To, Status_To); |
| |
| Free (Buffer); |
| |
| raise Copy_Error; |
| end if; |
| end loop; |
| |
| Close (From, Status_From); |
| Close (To, Status_To); |
| |
| Free (Buffer); |
| |
| if not (Status_From and Status_To) then |
| raise Copy_Error; |
| end if; |
| end Copy; |
| |
| ------------- |
| -- Copy_To -- |
| ------------- |
| |
| procedure Copy_To (To_Name : String) is |
| |
| function Copy_Attributes |
| (From, To : System.Address; |
| Mode : Integer) return Integer; |
| pragma Import (C, Copy_Attributes, "__gnat_copy_attribs"); |
| -- Mode = 0 - copy only time stamps. |
| -- Mode = 1 - copy time stamps and read/write/execute attributes |
| |
| C_From : String (1 .. Name'Length + 1); |
| C_To : String (1 .. To_Name'Length + 1); |
| |
| begin |
| From := Open_Read (Name, Binary); |
| |
| -- Do not clobber destination file if source file could not be opened |
| |
| if From /= Invalid_FD then |
| To := Create_File (To_Name, Binary); |
| end if; |
| |
| Copy (From, To); |
| |
| -- Copy attributes |
| |
| C_From (1 .. Name'Length) := Name; |
| C_From (C_From'Last) := ASCII.NUL; |
| |
| C_To (1 .. To_Name'Length) := To_Name; |
| C_To (C_To'Last) := ASCII.NUL; |
| |
| case Preserve is |
| |
| when Time_Stamps => |
| if Copy_Attributes (C_From'Address, C_To'Address, 0) = -1 then |
| raise Copy_Error; |
| end if; |
| |
| when Full => |
| if Copy_Attributes (C_From'Address, C_To'Address, 1) = -1 then |
| raise Copy_Error; |
| end if; |
| |
| when None => |
| null; |
| end case; |
| |
| end Copy_To; |
| |
| -- Start of processing for Copy_File |
| |
| begin |
| Success := True; |
| |
| -- The source file must exist |
| |
| if not Is_Regular_File (Name) then |
| raise Copy_Error; |
| end if; |
| |
| -- The source file exists |
| |
| case Mode is |
| |
| -- Copy case, target file must not exist |
| |
| when Copy => |
| |
| -- If the target file exists, we have an error |
| |
| if Is_Regular_File (Pathname) then |
| raise Copy_Error; |
| |
| -- Case of target is a directory |
| |
| elsif Is_Directory (Pathname) then |
| declare |
| Dest : constant String := Build_Path (Pathname, Name); |
| |
| begin |
| -- If target file exists, we have an error, else do copy |
| |
| if Is_Regular_File (Dest) then |
| raise Copy_Error; |
| else |
| Copy_To (Dest); |
| end if; |
| end; |
| |
| -- Case of normal copy to file (destination does not exist) |
| |
| else |
| Copy_To (Pathname); |
| end if; |
| |
| -- Overwrite case (destination file may or may not exist) |
| |
| when Overwrite => |
| if Is_Directory (Pathname) then |
| Copy_To (Build_Path (Pathname, Name)); |
| else |
| Copy_To (Pathname); |
| end if; |
| |
| -- Append case (destination file may or may not exist) |
| |
| when Append => |
| |
| -- Appending to existing file |
| |
| if Is_Regular_File (Pathname) then |
| |
| -- Append mode and destination file exists, append data at the |
| -- end of Pathname. But if we fail to open source file, do not |
| -- touch destination file at all. |
| |
| From := Open_Read (Name, Binary); |
| if From /= Invalid_FD then |
| To := Open_Read_Write (Pathname, Binary); |
| end if; |
| |
| Lseek (To, 0, Seek_End); |
| |
| Copy (From, To); |
| |
| -- Appending to directory, not allowed |
| |
| elsif Is_Directory (Pathname) then |
| raise Copy_Error; |
| |
| -- Appending when target file does not exist |
| |
| else |
| Copy_To (Pathname); |
| end if; |
| end case; |
| |
| -- All error cases are caught here |
| |
| exception |
| when Copy_Error => |
| Success := False; |
| end Copy_File; |
| |
| procedure Copy_File |
| (Name : C_File_Name; |
| Pathname : C_File_Name; |
| Success : out Boolean; |
| Mode : Copy_Mode := Copy; |
| Preserve : Attribute := Time_Stamps) |
| is |
| Ada_Name : String_Access := |
| To_Path_String_Access |
| (Name, C_String_Length (Name)); |
| Ada_Pathname : String_Access := |
| To_Path_String_Access |
| (Pathname, C_String_Length (Pathname)); |
| begin |
| Copy_File (Ada_Name.all, Ada_Pathname.all, Success, Mode, Preserve); |
| Free (Ada_Name); |
| Free (Ada_Pathname); |
| end Copy_File; |
| |
| ---------------------- |
| -- Copy_Time_Stamps -- |
| ---------------------- |
| |
| procedure Copy_Time_Stamps (Source, Dest : String; Success : out Boolean) is |
| |
| function Copy_Attributes |
| (From, To : System.Address; |
| Mode : Integer) return Integer; |
| pragma Import (C, Copy_Attributes, "__gnat_copy_attribs"); |
| -- Mode = 0 - copy only time stamps. |
| -- Mode = 1 - copy time stamps and read/write/execute attributes |
| |
| begin |
| if Is_Regular_File (Source) and then Is_Writable_File (Dest) then |
| declare |
| C_Source : String (1 .. Source'Length + 1); |
| C_Dest : String (1 .. Dest'Length + 1); |
| |
| begin |
| C_Source (1 .. Source'Length) := Source; |
| C_Source (C_Source'Last) := ASCII.NUL; |
| |
| C_Dest (1 .. Dest'Length) := Dest; |
| C_Dest (C_Dest'Last) := ASCII.NUL; |
| |
| if Copy_Attributes (C_Source'Address, C_Dest'Address, 0) = -1 then |
| Success := False; |
| else |
| Success := True; |
| end if; |
| end; |
| |
| else |
| Success := False; |
| end if; |
| end Copy_Time_Stamps; |
| |
| procedure Copy_Time_Stamps |
| (Source, Dest : C_File_Name; |
| Success : out Boolean) |
| is |
| Ada_Source : String_Access := |
| To_Path_String_Access |
| (Source, C_String_Length (Source)); |
| Ada_Dest : String_Access := |
| To_Path_String_Access |
| (Dest, C_String_Length (Dest)); |
| begin |
| Copy_Time_Stamps (Ada_Source.all, Ada_Dest.all, Success); |
| Free (Ada_Source); |
| Free (Ada_Dest); |
| end Copy_Time_Stamps; |
| |
| ----------------- |
| -- Create_File -- |
| ----------------- |
| |
| function Create_File |
| (Name : C_File_Name; |
| Fmode : Mode) return File_Descriptor |
| is |
| function C_Create_File |
| (Name : C_File_Name; |
| Fmode : Mode) return File_Descriptor; |
| pragma Import (C, C_Create_File, "__gnat_open_create"); |
| |
| begin |
| return C_Create_File (Name, Fmode); |
| end Create_File; |
| |
| function Create_File |
| (Name : String; |
| Fmode : Mode) return File_Descriptor |
| is |
| C_Name : String (1 .. Name'Length + 1); |
| |
| begin |
| C_Name (1 .. Name'Length) := Name; |
| C_Name (C_Name'Last) := ASCII.NUL; |
| return Create_File (C_Name (C_Name'First)'Address, Fmode); |
| end Create_File; |
| |
| --------------------- |
| -- Create_New_File -- |
| --------------------- |
| |
| function Create_New_File |
| (Name : C_File_Name; |
| Fmode : Mode) return File_Descriptor |
| is |
| function C_Create_New_File |
| (Name : C_File_Name; |
| Fmode : Mode) return File_Descriptor; |
| pragma Import (C, C_Create_New_File, "__gnat_open_new"); |
| |
| begin |
| return C_Create_New_File (Name, Fmode); |
| end Create_New_File; |
| |
| function Create_New_File |
| (Name : String; |
| Fmode : Mode) return File_Descriptor |
| is |
| C_Name : String (1 .. Name'Length + 1); |
| |
| begin |
| C_Name (1 .. Name'Length) := Name; |
| C_Name (C_Name'Last) := ASCII.NUL; |
| return Create_New_File (C_Name (C_Name'First)'Address, Fmode); |
| end Create_New_File; |
| |
| ----------------------------- |
| -- Create_Output_Text_File -- |
| ----------------------------- |
| |
| function Create_Output_Text_File (Name : String) return File_Descriptor is |
| function C_Create_File |
| (Name : C_File_Name) return File_Descriptor; |
| pragma Import (C, C_Create_File, "__gnat_create_output_file"); |
| |
| C_Name : String (1 .. Name'Length + 1); |
| |
| begin |
| C_Name (1 .. Name'Length) := Name; |
| C_Name (C_Name'Last) := ASCII.NUL; |
| return C_Create_File (C_Name (C_Name'First)'Address); |
| end Create_Output_Text_File; |
| |
| ---------------------- |
| -- Create_Temp_File -- |
| ---------------------- |
| |
| procedure Create_Temp_File |
| (FD : out File_Descriptor; |
| Name : out Temp_File_Name) |
| is |
| function Open_New_Temp |
| (Name : System.Address; |
| Fmode : Mode) return File_Descriptor; |
| pragma Import (C, Open_New_Temp, "__gnat_open_new_temp"); |
| |
| begin |
| FD := Open_New_Temp (Name'Address, Binary); |
| end Create_Temp_File; |
| |
| procedure Create_Temp_File |
| (FD : out File_Descriptor; |
| Name : out String_Access) |
| is |
| begin |
| Create_Temp_File_Internal (FD, Name, Stdout => False); |
| end Create_Temp_File; |
| |
| procedure Create_Temp_Output_File |
| (FD : out File_Descriptor; |
| Name : out String_Access) |
| is |
| begin |
| Create_Temp_File_Internal (FD, Name, Stdout => True); |
| end Create_Temp_Output_File; |
| |
| ------------------------------- |
| -- Create_Temp_File_Internal -- |
| ------------------------------- |
| |
| procedure Create_Temp_File_Internal |
| (FD : out File_Descriptor; |
| Name : out String_Access; |
| Stdout : Boolean) |
| is |
| Pos : Positive; |
| Attempts : Natural := 0; |
| Current : String (Current_Temp_File_Name'Range); |
| |
| --------------------------------- |
| -- Create_New_Output_Text_File -- |
| --------------------------------- |
| |
| function Create_New_Output_Text_File |
| (Name : String) return File_Descriptor; |
| -- Similar to Create_Output_Text_File, except it fails if the file |
| -- already exists. We need this behavior to ensure we don't accidentally |
| -- open a temp file that has just been created by a concurrently running |
| -- process. There is no point exposing this function, as it's generally |
| -- not particularly useful. |
| |
| function Create_New_Output_Text_File |
| (Name : String) return File_Descriptor is |
| function C_Create_File |
| (Name : C_File_Name) return File_Descriptor; |
| pragma Import (C, C_Create_File, "__gnat_create_output_file_new"); |
| |
| C_Name : String (1 .. Name'Length + 1); |
| |
| begin |
| C_Name (1 .. Name'Length) := Name; |
| C_Name (C_Name'Last) := ASCII.NUL; |
| return C_Create_File (C_Name (C_Name'First)'Address); |
| end Create_New_Output_Text_File; |
| |
| begin |
| -- Loop until a new temp file can be created |
| |
| File_Loop : loop |
| Locked : begin |
| -- We need to protect global variable Current_Temp_File_Name |
| -- against concurrent access by different tasks. |
| |
| SSL.Lock_Task.all; |
| |
| -- Start at the last digit |
| |
| Pos := Temp_File_Name_Last_Digit; |
| |
| Digit_Loop : |
| loop |
| -- Increment the digit by one |
| |
| case Current_Temp_File_Name (Pos) is |
| when '0' .. '8' => |
| Current_Temp_File_Name (Pos) := |
| Character'Succ (Current_Temp_File_Name (Pos)); |
| exit Digit_Loop; |
| |
| when '9' => |
| |
| -- For 9, set the digit to 0 and go to the previous digit |
| |
| Current_Temp_File_Name (Pos) := '0'; |
| Pos := Pos - 1; |
| |
| when others => |
| |
| -- If it is not a digit, then there are no available |
| -- temp file names. Return Invalid_FD. There is almost |
| -- no chance that this code will be ever be executed, |
| -- since it would mean that there are one million temp |
| -- files in the same directory! |
| |
| SSL.Unlock_Task.all; |
| FD := Invalid_FD; |
| Name := null; |
| exit File_Loop; |
| end case; |
| end loop Digit_Loop; |
| |
| Current := Current_Temp_File_Name; |
| |
| -- We can now release the lock, because we are no longer |
| -- accessing Current_Temp_File_Name. |
| |
| SSL.Unlock_Task.all; |
| |
| exception |
| when others => |
| SSL.Unlock_Task.all; |
| raise; |
| end Locked; |
| |
| -- Attempt to create the file |
| |
| if Stdout then |
| FD := Create_New_Output_Text_File (Current); |
| else |
| FD := Create_New_File (Current, Binary); |
| end if; |
| |
| if FD /= Invalid_FD then |
| Name := new String'(Current); |
| exit File_Loop; |
| end if; |
| |
| if not Is_Regular_File (Current) then |
| |
| -- If the file does not already exist and we are unable to create |
| -- it, we give up after Max_Attempts. Otherwise, we try again with |
| -- the next available file name. |
| |
| Attempts := Attempts + 1; |
| |
| if Attempts >= Max_Attempts then |
| FD := Invalid_FD; |
| Name := null; |
| exit File_Loop; |
| end if; |
| end if; |
| end loop File_Loop; |
| end Create_Temp_File_Internal; |
| |
| ----------------- |
| -- Delete_File -- |
| ----------------- |
| |
| procedure Delete_File (Name : Address; Success : out Boolean) is |
| R : Integer; |
| begin |
| R := System.CRTL.unlink (Name); |
| Success := (R = 0); |
| end Delete_File; |
| |
| procedure Delete_File (Name : String; Success : out Boolean) is |
| C_Name : String (1 .. Name'Length + 1); |
| |
| begin |
| C_Name (1 .. Name'Length) := Name; |
| C_Name (C_Name'Last) := ASCII.NUL; |
| |
| Delete_File (C_Name'Address, Success); |
| end Delete_File; |
| |
| --------------------- |
| -- File_Time_Stamp -- |
| --------------------- |
| |
| function File_Time_Stamp (FD : File_Descriptor) return OS_Time is |
| function File_Time (FD : File_Descriptor) return OS_Time; |
| pragma Import (C, File_Time, "__gnat_file_time_fd"); |
| begin |
| return File_Time (FD); |
| end File_Time_Stamp; |
| |
| function File_Time_Stamp (Name : C_File_Name) return OS_Time is |
| function File_Time (Name : Address) return OS_Time; |
| pragma Import (C, File_Time, "__gnat_file_time_name"); |
| begin |
| return File_Time (Name); |
| end File_Time_Stamp; |
| |
| function File_Time_Stamp (Name : String) return OS_Time is |
| F_Name : String (1 .. Name'Length + 1); |
| begin |
| F_Name (1 .. Name'Length) := Name; |
| F_Name (F_Name'Last) := ASCII.NUL; |
| return File_Time_Stamp (F_Name'Address); |
| end File_Time_Stamp; |
| |
| --------------------------- |
| -- Get_Debuggable_Suffix -- |
| --------------------------- |
| |
| function Get_Debuggable_Suffix return String_Access is |
| procedure Get_Suffix_Ptr (Length, Ptr : Address); |
| pragma Import (C, Get_Suffix_Ptr, "__gnat_get_debuggable_suffix_ptr"); |
| |
| procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer); |
| pragma Import (C, Strncpy, "strncpy"); |
| |
| Suffix_Ptr : Address; |
| Suffix_Length : Integer; |
| Result : String_Access; |
| |
| begin |
| Get_Suffix_Ptr (Suffix_Length'Address, Suffix_Ptr'Address); |
| |
| Result := new String (1 .. Suffix_Length); |
| |
| if Suffix_Length > 0 then |
| Strncpy (Result.all'Address, Suffix_Ptr, Suffix_Length); |
| end if; |
| |
| return Result; |
| end Get_Debuggable_Suffix; |
| |
| --------------------------- |
| -- Get_Executable_Suffix -- |
| --------------------------- |
| |
| function Get_Executable_Suffix return String_Access is |
| procedure Get_Suffix_Ptr (Length, Ptr : Address); |
| pragma Import (C, Get_Suffix_Ptr, "__gnat_get_executable_suffix_ptr"); |
| |
| procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer); |
| pragma Import (C, Strncpy, "strncpy"); |
| |
| Suffix_Ptr : Address; |
| Suffix_Length : Integer; |
| Result : String_Access; |
| |
| begin |
| Get_Suffix_Ptr (Suffix_Length'Address, Suffix_Ptr'Address); |
| |
| Result := new String (1 .. Suffix_Length); |
| |
| if Suffix_Length > 0 then |
| Strncpy (Result.all'Address, Suffix_Ptr, Suffix_Length); |
| end if; |
| |
| return Result; |
| end Get_Executable_Suffix; |
| |
| ----------------------- |
| -- Get_Object_Suffix -- |
| ----------------------- |
| |
| function Get_Object_Suffix return String_Access is |
| procedure Get_Suffix_Ptr (Length, Ptr : Address); |
| pragma Import (C, Get_Suffix_Ptr, "__gnat_get_object_suffix_ptr"); |
| |
| procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer); |
| pragma Import (C, Strncpy, "strncpy"); |
| |
| Suffix_Ptr : Address; |
| Suffix_Length : Integer; |
| Result : String_Access; |
| |
| begin |
| Get_Suffix_Ptr (Suffix_Length'Address, Suffix_Ptr'Address); |
| |
| Result := new String (1 .. Suffix_Length); |
| |
| if Suffix_Length > 0 then |
| Strncpy (Result.all'Address, Suffix_Ptr, Suffix_Length); |
| end if; |
| |
| return Result; |
| end Get_Object_Suffix; |
| |
| ---------------------------------- |
| -- Get_Target_Debuggable_Suffix -- |
| ---------------------------------- |
| |
| function Get_Target_Debuggable_Suffix return String_Access is |
| Target_Exec_Ext_Ptr : Address; |
| pragma Import |
| (C, Target_Exec_Ext_Ptr, "__gnat_target_debuggable_extension"); |
| |
| procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer); |
| pragma Import (C, Strncpy, "strncpy"); |
| |
| function Strlen (Cstring : Address) return Integer; |
| pragma Import (C, Strlen, "strlen"); |
| |
| Suffix_Length : Integer; |
| Result : String_Access; |
| |
| begin |
| Suffix_Length := Strlen (Target_Exec_Ext_Ptr); |
| |
| Result := new String (1 .. Suffix_Length); |
| |
| if Suffix_Length > 0 then |
| Strncpy (Result.all'Address, Target_Exec_Ext_Ptr, Suffix_Length); |
| end if; |
| |
| return Result; |
| end Get_Target_Debuggable_Suffix; |
| |
| ---------------------------------- |
| -- Get_Target_Executable_Suffix -- |
| ---------------------------------- |
| |
| function Get_Target_Executable_Suffix return String_Access is |
| Target_Exec_Ext_Ptr : Address; |
| pragma Import |
| (C, Target_Exec_Ext_Ptr, "__gnat_target_executable_extension"); |
| |
| procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer); |
| pragma Import (C, Strncpy, "strncpy"); |
| |
| function Strlen (Cstring : Address) return Integer; |
| pragma Import (C, Strlen, "strlen"); |
| |
| Suffix_Length : Integer; |
| Result : String_Access; |
| |
| begin |
| Suffix_Length := Strlen (Target_Exec_Ext_Ptr); |
| |
| Result := new String (1 .. Suffix_Length); |
| |
| if Suffix_Length > 0 then |
| Strncpy (Result.all'Address, Target_Exec_Ext_Ptr, Suffix_Length); |
| end if; |
| |
| return Result; |
| end Get_Target_Executable_Suffix; |
| |
| ------------------------------ |
| -- Get_Target_Object_Suffix -- |
| ------------------------------ |
| |
| function Get_Target_Object_Suffix return String_Access is |
| Target_Object_Ext_Ptr : Address; |
| pragma Import |
| (C, Target_Object_Ext_Ptr, "__gnat_target_object_extension"); |
| |
| procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer); |
| pragma Import (C, Strncpy, "strncpy"); |
| |
| function Strlen (Cstring : Address) return Integer; |
| pragma Import (C, Strlen, "strlen"); |
| |
| Suffix_Length : Integer; |
| Result : String_Access; |
| |
| begin |
| Suffix_Length := Strlen (Target_Object_Ext_Ptr); |
| |
| Result := new String (1 .. Suffix_Length); |
| |
| if Suffix_Length > 0 then |
| Strncpy (Result.all'Address, Target_Object_Ext_Ptr, Suffix_Length); |
| end if; |
| |
| return Result; |
| end Get_Target_Object_Suffix; |
| |
| ------------ |
| -- Getenv -- |
| ------------ |
| |
| function Getenv (Name : String) return String_Access is |
| procedure Get_Env_Value_Ptr (Name, Length, Ptr : Address); |
| pragma Import (C, Get_Env_Value_Ptr, "__gnat_getenv"); |
| |
| procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer); |
| pragma Import (C, Strncpy, "strncpy"); |
| |
| Env_Value_Ptr : aliased Address; |
| Env_Value_Length : aliased Integer; |
| F_Name : aliased String (1 .. Name'Length + 1); |
| Result : String_Access; |
| |
| begin |
| F_Name (1 .. Name'Length) := Name; |
| F_Name (F_Name'Last) := ASCII.NUL; |
| |
| Get_Env_Value_Ptr |
| (F_Name'Address, Env_Value_Length'Address, Env_Value_Ptr'Address); |
| |
| Result := new String (1 .. Env_Value_Length); |
| |
| if Env_Value_Length > 0 then |
| Strncpy (Result.all'Address, Env_Value_Ptr, Env_Value_Length); |
| end if; |
| |
| return Result; |
| end Getenv; |
| |
| ------------ |
| -- GM_Day -- |
| ------------ |
| |
| function GM_Day (Date : OS_Time) return Day_Type is |
| D : Day_Type; |
| |
| pragma Warnings (Off); |
| Y : Year_Type; |
| Mo : Month_Type; |
| H : Hour_Type; |
| Mn : Minute_Type; |
| S : Second_Type; |
| pragma Warnings (On); |
| |
| begin |
| GM_Split (Date, Y, Mo, D, H, Mn, S); |
| return D; |
| end GM_Day; |
| |
| ------------- |
| -- GM_Hour -- |
| ------------- |
| |
| function GM_Hour (Date : OS_Time) return Hour_Type is |
| H : Hour_Type; |
| |
| pragma Warnings (Off); |
| Y : Year_Type; |
| Mo : Month_Type; |
| D : Day_Type; |
| Mn : Minute_Type; |
| S : Second_Type; |
| pragma Warnings (On); |
| |
| begin |
| GM_Split (Date, Y, Mo, D, H, Mn, S); |
| return H; |
| end GM_Hour; |
| |
| --------------- |
| -- GM_Minute -- |
| --------------- |
| |
| function GM_Minute (Date : OS_Time) return Minute_Type is |
| Mn : Minute_Type; |
| |
| pragma Warnings (Off); |
| Y : Year_Type; |
| Mo : Month_Type; |
| D : Day_Type; |
| H : Hour_Type; |
| S : Second_Type; |
| pragma Warnings (On); |
| |
| begin |
| GM_Split (Date, Y, Mo, D, H, Mn, S); |
| return Mn; |
| end GM_Minute; |
| |
| -------------- |
| -- GM_Month -- |
| -------------- |
| |
| function GM_Month (Date : OS_Time) return Month_Type is |
| Mo : Month_Type; |
| |
| pragma Warnings (Off); |
| Y : Year_Type; |
| D : Day_Type; |
| H : Hour_Type; |
| Mn : Minute_Type; |
| S : Second_Type; |
| pragma Warnings (On); |
| |
| begin |
| GM_Split (Date, Y, Mo, D, H, Mn, S); |
| return Mo; |
| end GM_Month; |
| |
| --------------- |
| -- GM_Second -- |
| --------------- |
| |
| function GM_Second (Date : OS_Time) return Second_Type is |
| S : Second_Type; |
| |
| pragma Warnings (Off); |
| Y : Year_Type; |
| Mo : Month_Type; |
| D : Day_Type; |
| H : Hour_Type; |
| Mn : Minute_Type; |
| pragma Warnings (On); |
| |
| begin |
| GM_Split (Date, Y, Mo, D, H, Mn, S); |
| return S; |
| end GM_Second; |
| |
| -------------- |
| -- GM_Split -- |
| -------------- |
| |
| procedure GM_Split |
| (Date : OS_Time; |
| Year : out Year_Type; |
| Month : out Month_Type; |
| Day : out Day_Type; |
| Hour : out Hour_Type; |
| Minute : out Minute_Type; |
| Second : out Second_Type) |
| is |
| procedure To_GM_Time |
| (P_Time_T, P_Year, P_Month, P_Day, P_Hours, P_Mins, P_Secs : Address); |
| pragma Import (C, To_GM_Time, "__gnat_to_gm_time"); |
| |
| T : OS_Time := Date; |
| Y : Integer; |
| Mo : Integer; |
| D : Integer; |
| H : Integer; |
| Mn : Integer; |
| S : Integer; |
| |
| begin |
| -- Use the global lock because To_GM_Time is not thread safe |
| |
| Locked_Processing : begin |
| SSL.Lock_Task.all; |
| To_GM_Time |
| (T'Address, Y'Address, Mo'Address, D'Address, |
| H'Address, Mn'Address, S'Address); |
| SSL.Unlock_Task.all; |
| |
| exception |
| when others => |
| SSL.Unlock_Task.all; |
| raise; |
| end Locked_Processing; |
| |
| Year := Y + 1900; |
| Month := Mo + 1; |
| Day := D; |
| Hour := H; |
| Minute := Mn; |
| Second := S; |
| end GM_Split; |
| |
| ------------- |
| -- GM_Year -- |
| ------------- |
| |
| function GM_Year (Date : OS_Time) return Year_Type is |
| Y : Year_Type; |
| |
| pragma Warnings (Off); |
| Mo : Month_Type; |
| D : Day_Type; |
| H : Hour_Type; |
| Mn : Minute_Type; |
| S : Second_Type; |
| pragma Warnings (On); |
| |
| begin |
| GM_Split (Date, Y, Mo, D, H, Mn, S); |
| return Y; |
| end GM_Year; |
| |
| ---------------------- |
| -- Is_Absolute_Path -- |
| ---------------------- |
| |
| function Is_Absolute_Path (Name : String) return Boolean is |
| function Is_Absolute_Path |
| (Name : Address; |
| Length : Integer) return Integer; |
| pragma Import (C, Is_Absolute_Path, "__gnat_is_absolute_path"); |
| begin |
| return Is_Absolute_Path (Name'Address, Name'Length) /= 0; |
| end Is_Absolute_Path; |
| |
| ------------------ |
| -- Is_Directory -- |
| ------------------ |
| |
| function Is_Directory (Name : C_File_Name) return Boolean is |
| function Is_Directory (Name : Address) return Integer; |
| pragma Import (C, Is_Directory, "__gnat_is_directory"); |
| begin |
| return Is_Directory (Name) /= 0; |
| end Is_Directory; |
| |
| function Is_Directory (Name : String) return Boolean is |
| F_Name : String (1 .. Name'Length + 1); |
| begin |
| F_Name (1 .. Name'Length) := Name; |
| F_Name (F_Name'Last) := ASCII.NUL; |
| return Is_Directory (F_Name'Address); |
| end Is_Directory; |
| |
| ---------------------- |
| -- Is_Readable_File -- |
| ---------------------- |
| |
| function Is_Readable_File (Name : C_File_Name) return Boolean is |
| function Is_Readable_File (Name : Address) return Integer; |
| pragma Import (C, Is_Readable_File, "__gnat_is_readable_file"); |
| begin |
| return Is_Readable_File (Name) /= 0; |
| end Is_Readable_File; |
| |
| function Is_Readable_File (Name : String) return Boolean is |
| F_Name : String (1 .. Name'Length + 1); |
| begin |
| F_Name (1 .. Name'Length) := Name; |
| F_Name (F_Name'Last) := ASCII.NUL; |
| return Is_Readable_File (F_Name'Address); |
| end Is_Readable_File; |
| |
| ------------------------ |
| -- Is_Executable_File -- |
| ------------------------ |
| |
| function Is_Executable_File (Name : C_File_Name) return Boolean is |
| function Is_Executable_File (Name : Address) return Integer; |
| pragma Import (C, Is_Executable_File, "__gnat_is_executable_file"); |
| begin |
| return Is_Executable_File (Name) /= 0; |
| end Is_Executable_File; |
| |
| function Is_Executable_File (Name : String) return Boolean is |
| F_Name : String (1 .. Name'Length + 1); |
| begin |
| F_Name (1 .. Name'Length) := Name; |
| F_Name (F_Name'Last) := ASCII.NUL; |
| return Is_Executable_File (F_Name'Address); |
| end Is_Executable_File; |
| |
| --------------------- |
| -- Is_Regular_File -- |
| --------------------- |
| |
| function Is_Regular_File (Name : C_File_Name) return Boolean is |
| function Is_Regular_File (Name : Address) return Integer; |
| pragma Import (C, Is_Regular_File, "__gnat_is_regular_file"); |
| begin |
| return Is_Regular_File (Name) /= 0; |
| end Is_Regular_File; |
| |
| function Is_Regular_File (Name : String) return Boolean is |
| F_Name : String (1 .. Name'Length + 1); |
| begin |
| F_Name (1 .. Name'Length) := Name; |
| F_Name (F_Name'Last) := ASCII.NUL; |
| return Is_Regular_File (F_Name'Address); |
| end Is_Regular_File; |
| |
| ---------------------- |
| -- Is_Symbolic_Link -- |
| ---------------------- |
| |
| function Is_Symbolic_Link (Name : C_File_Name) return Boolean is |
| function Is_Symbolic_Link (Name : Address) return Integer; |
| pragma Import (C, Is_Symbolic_Link, "__gnat_is_symbolic_link"); |
| begin |
| return Is_Symbolic_Link (Name) /= 0; |
| end Is_Symbolic_Link; |
| |
| function Is_Symbolic_Link (Name : String) return Boolean is |
| F_Name : String (1 .. Name'Length + 1); |
| begin |
| F_Name (1 .. Name'Length) := Name; |
| F_Name (F_Name'Last) := ASCII.NUL; |
| return Is_Symbolic_Link (F_Name'Address); |
| end Is_Symbolic_Link; |
| |
| ---------------------- |
| -- Is_Writable_File -- |
| ---------------------- |
| |
| function Is_Writable_File (Name : C_File_Name) return Boolean is |
| function Is_Writable_File (Name : Address) return Integer; |
| pragma Import (C, Is_Writable_File, "__gnat_is_writable_file"); |
| begin |
| return Is_Writable_File (Name) /= 0; |
| end Is_Writable_File; |
| |
| function Is_Writable_File (Name : String) return Boolean is |
| F_Name : String (1 .. Name'Length + 1); |
| begin |
| F_Name (1 .. Name'Length) := Name; |
| F_Name (F_Name'Last) := ASCII.NUL; |
| return Is_Writable_File (F_Name'Address); |
| end Is_Writable_File; |
| |
| ------------------------- |
| -- Locate_Exec_On_Path -- |
| ------------------------- |
| |
| function Locate_Exec_On_Path |
| (Exec_Name : String) return String_Access |
| is |
| function Locate_Exec_On_Path (C_Exec_Name : Address) return Address; |
| pragma Import (C, Locate_Exec_On_Path, "__gnat_locate_exec_on_path"); |
| |
| procedure Free (Ptr : System.Address); |
| pragma Import (C, Free, "free"); |
| |
| C_Exec_Name : String (1 .. Exec_Name'Length + 1); |
| Path_Addr : Address; |
| Path_Len : Integer; |
| Result : String_Access; |
| |
| begin |
| C_Exec_Name (1 .. Exec_Name'Length) := Exec_Name; |
| C_Exec_Name (C_Exec_Name'Last) := ASCII.NUL; |
| |
| Path_Addr := Locate_Exec_On_Path (C_Exec_Name'Address); |
| Path_Len := C_String_Length (Path_Addr); |
| |
| if Path_Len = 0 then |
| return null; |
| |
| else |
| Result := To_Path_String_Access (Path_Addr, Path_Len); |
| Free (Path_Addr); |
| |
| -- Always return an absolute path name |
| |
| if not Is_Absolute_Path (Result.all) then |
| declare |
| Absolute_Path : constant String := |
| Normalize_Pathname (Result.all); |
| begin |
| Free (Result); |
| Result := new String'(Absolute_Path); |
| end; |
| end if; |
| |
| return Result; |
| end if; |
| end Locate_Exec_On_Path; |
| |
| ------------------------- |
| -- Locate_Regular_File -- |
| ------------------------- |
| |
| function Locate_Regular_File |
| (File_Name : C_File_Name; |
| Path : C_File_Name) return String_Access |
| is |
| function Locate_Regular_File |
| (C_File_Name, Path_Val : Address) return Address; |
| pragma Import (C, Locate_Regular_File, "__gnat_locate_regular_file"); |
| |
| procedure Free (Ptr : System.Address); |
| pragma Import (C, Free, "free"); |
| |
| Path_Addr : Address; |
| Path_Len : Integer; |
| Result : String_Access; |
| |
| begin |
| Path_Addr := Locate_Regular_File (File_Name, Path); |
| Path_Len := C_String_Length (Path_Addr); |
| |
| if Path_Len = 0 then |
| return null; |
| |
| else |
| Result := To_Path_String_Access (Path_Addr, Path_Len); |
| Free (Path_Addr); |
| return Result; |
| end if; |
| end Locate_Regular_File; |
| |
| function Locate_Regular_File |
| (File_Name : String; |
| Path : String) return String_Access |
| is |
| C_File_Name : String (1 .. File_Name'Length + 1); |
| C_Path : String (1 .. Path'Length + 1); |
| Result : String_Access; |
| |
| begin |
| C_File_Name (1 .. File_Name'Length) := File_Name; |
| C_File_Name (C_File_Name'Last) := ASCII.NUL; |
| |
| C_Path (1 .. Path'Length) := Path; |
| C_Path (C_Path'Last) := ASCII.NUL; |
| |
| Result := Locate_Regular_File (C_File_Name'Address, C_Path'Address); |
| |
| -- Always return an absolute path name |
| |
| if Result /= null and then not Is_Absolute_Path (Result.all) then |
| declare |
| Absolute_Path : constant String := Normalize_Pathname (Result.all); |
| begin |
| Free (Result); |
| Result := new String'(Absolute_Path); |
| end; |
| end if; |
| |
| return Result; |
| end Locate_Regular_File; |
| |
| ------------------------ |
| -- Non_Blocking_Spawn -- |
| ------------------------ |
| |
| function Non_Blocking_Spawn |
| (Program_Name : String; |
| Args : Argument_List) return Process_Id |
| is |
| Pid : Process_Id; |
| Junk : Integer; |
| pragma Warnings (Off, Junk); |
| begin |
| Spawn_Internal (Program_Name, Args, Junk, Pid, Blocking => False); |
| return Pid; |
| end Non_Blocking_Spawn; |
| |
| function Non_Blocking_Spawn |
| (Program_Name : String; |
| Args : Argument_List; |
| Output_File_Descriptor : File_Descriptor; |
| Err_To_Out : Boolean := True) return Process_Id |
| is |
| Saved_Output : File_Descriptor; |
| Saved_Error : File_Descriptor := Invalid_FD; -- prevent warning |
| Pid : Process_Id; |
| |
| begin |
| if Output_File_Descriptor = Invalid_FD then |
| return Invalid_Pid; |
| end if; |
| |
| -- Set standard output and, if specified, error to the temporary file |
| |
| Saved_Output := Dup (Standout); |
| Dup2 (Output_File_Descriptor, Standout); |
| |
| if Err_To_Out then |
| Saved_Error := Dup (Standerr); |
| Dup2 (Output_File_Descriptor, Standerr); |
| end if; |
| |
| -- Spawn the program |
| |
| Pid := Non_Blocking_Spawn (Program_Name, Args); |
| |
| -- Restore the standard output and error |
| |
| Dup2 (Saved_Output, Standout); |
| |
| if Err_To_Out then |
| Dup2 (Saved_Error, Standerr); |
| end if; |
| |
| -- And close the saved standard output and error file descriptors |
| |
| Close (Saved_Output); |
| |
| if Err_To_Out then |
| Close (Saved_Error); |
| end if; |
| |
| return Pid; |
| end Non_Blocking_Spawn; |
| |
| function Non_Blocking_Spawn |
| (Program_Name : String; |
| Args : Argument_List; |
| Output_File : String; |
| Err_To_Out : Boolean := True) return Process_Id |
| is |
| Output_File_Descriptor : constant File_Descriptor := |
| Create_Output_Text_File (Output_File); |
| Result : Process_Id; |
| |
| begin |
| -- Do not attempt to spawn if the output file could not be created |
| |
| if Output_File_Descriptor = Invalid_FD then |
| return Invalid_Pid; |
| |
| else |
| Result := Non_Blocking_Spawn |
| (Program_Name, Args, Output_File_Descriptor, Err_To_Out); |
| |
| -- Close the file just created for the output, as the file descriptor |
| -- cannot be used anywhere, being a local value. It is safe to do |
| -- that, as the file descriptor has been duplicated to form |
| -- standard output and error of the spawned process. |
| |
| Close (Output_File_Descriptor); |
| |
| return Result; |
| end if; |
| end Non_Blocking_Spawn; |
| |
| ------------------------- |
| -- Normalize_Arguments -- |
| ------------------------- |
| |
| procedure Normalize_Arguments (Args : in out Argument_List) is |
| |
| procedure Quote_Argument (Arg : in out String_Access); |
| -- Add quote around argument if it contains spaces |
| |
| C_Argument_Needs_Quote : Integer; |
| pragma Import (C, C_Argument_Needs_Quote, "__gnat_argument_needs_quote"); |
| Argument_Needs_Quote : constant Boolean := C_Argument_Needs_Quote /= 0; |
| |
| -------------------- |
| -- Quote_Argument -- |
| -------------------- |
| |
| procedure Quote_Argument (Arg : in out String_Access) is |
| Res : String (1 .. Arg'Length * 2); |
| J : Positive := 1; |
| Quote_Needed : Boolean := False; |
| |
| begin |
| if Arg (Arg'First) /= '"' or else Arg (Arg'Last) /= '"' then |
| |
| -- Starting quote |
| |
| Res (J) := '"'; |
| |
| for K in Arg'Range loop |
| |
| J := J + 1; |
| |
| if Arg (K) = '"' then |
| Res (J) := '\'; |
| J := J + 1; |
| Res (J) := '"'; |
| Quote_Needed := True; |
| |
| elsif Arg (K) = ' ' then |
| Res (J) := Arg (K); |
| Quote_Needed := True; |
| |
| else |
| Res (J) := Arg (K); |
| end if; |
| |
| end loop; |
| |
| if Quote_Needed then |
| |
| -- If null terminated string, put the quote before |
| |
| if Res (J) = ASCII.NUL then |
| Res (J) := '"'; |
| J := J + 1; |
| Res (J) := ASCII.NUL; |
| |
| -- If argument is terminated by '\', then double it. Otherwise |
| -- the ending quote will be taken as-is. This is quite strange |
| -- spawn behavior from Windows, but this is what we see! |
| |
| else |
| if Res (J) = '\' then |
| J := J + 1; |
| Res (J) := '\'; |
| end if; |
| |
| -- Ending quote |
| |
| J := J + 1; |
| Res (J) := '"'; |
| end if; |
| |
| declare |
| Old : String_Access := Arg; |
| |
| begin |
| Arg := new String'(Res (1 .. J)); |
| Free (Old); |
| end; |
| end if; |
| |
| end if; |
| end Quote_Argument; |
| |
| -- Start of processing for Normalize_Arguments |
| |
| begin |
| if Argument_Needs_Quote then |
| for K in Args'Range loop |
| if Args (K) /= null and then Args (K)'Length /= 0 then |
| Quote_Argument (Args (K)); |
| end if; |
| end loop; |
| end if; |
| end Normalize_Arguments; |
| |
| ------------------------ |
| -- Normalize_Pathname -- |
| ------------------------ |
| |
| function Normalize_Pathname |
| (Name : String; |
| Directory : String := ""; |
| Resolve_Links : Boolean := True; |
| Case_Sensitive : Boolean := True) return String |
| is |
| Max_Path : Integer; |
| pragma Import (C, Max_Path, "__gnat_max_path_len"); |
| -- Maximum length of a path name |
| |
| procedure Get_Current_Dir |
| (Dir : System.Address; |
| Length : System.Address); |
| pragma Import (C, Get_Current_Dir, "__gnat_get_current_dir"); |
| |
| Path_Buffer : String (1 .. Max_Path + Max_Path + 2); |
| End_Path : Natural := 0; |
| Link_Buffer : String (1 .. Max_Path + 2); |
| Status : Integer; |
| Last : Positive; |
| Start : Natural; |
| Finish : Positive; |
| |
| Max_Iterations : constant := 500; |
| |
| function Get_File_Names_Case_Sensitive return Integer; |
| pragma Import |
| (C, Get_File_Names_Case_Sensitive, |
| "__gnat_get_file_names_case_sensitive"); |
| |
| Fold_To_Lower_Case : constant Boolean := |
| not Case_Sensitive |
| and then Get_File_Names_Case_Sensitive = 0; |
| |
| function Readlink |
| (Path : System.Address; |
| Buf : System.Address; |
| Bufsiz : Integer) return Integer; |
| pragma Import (C, Readlink, "__gnat_readlink"); |
| |
| function To_Canonical_File_Spec |
| (Host_File : System.Address) return System.Address; |
| pragma Import |
| (C, To_Canonical_File_Spec, "__gnat_to_canonical_file_spec"); |
| |
| The_Name : String (1 .. Name'Length + 1); |
| Canonical_File_Addr : System.Address; |
| Canonical_File_Len : Integer; |
| |
| function Strlen (S : System.Address) return Integer; |
| pragma Import (C, Strlen, "strlen"); |
| |
| function Final_Value (S : String) return String; |
| -- Make final adjustment to the returned string. This function strips |
| -- trailing directory separators, and folds returned string to lower |
| -- case if required. |
| |
| function Get_Directory (Dir : String) return String; |
| -- If Dir is not empty, return it, adding a directory separator |
| -- if not already present, otherwise return current working directory |
| -- with terminating directory separator. |
| |
| ----------------- |
| -- Final_Value -- |
| ----------------- |
| |
| function Final_Value (S : String) return String is |
| S1 : String := S; |
| -- We may need to fold S to lower case, so we need a variable |
| |
| Last : Natural; |
| |
| begin |
| if Fold_To_Lower_Case then |
| System.Case_Util.To_Lower (S1); |
| end if; |
| |
| -- Remove trailing directory separator, if any |
| |
| Last := S1'Last; |
| |
| if Last > 1 |
| and then (S1 (Last) = '/' |
| or else |
| S1 (Last) = Directory_Separator) |
| then |
| -- Special case for Windows: C:\ |
| |
| if Last = 3 |
| and then S1 (1) /= Directory_Separator |
| and then S1 (2) = ':' |
| then |
| null; |
| |
| else |
| Last := Last - 1; |
| end if; |
| end if; |
| |
| return S1 (1 .. Last); |
| end Final_Value; |
| |
| ------------------- |
| -- Get_Directory -- |
| ------------------- |
| |
| function Get_Directory (Dir : String) return String is |
| Result : String (1 .. Dir'Length + 1); |
| Length : constant Natural := Dir'Length; |
| |
| begin |
| -- Directory given, add directory separator if needed |
| |
| if Length > 0 then |
| Result (1 .. Length) := Dir; |
| |
| -- On Windows, change all '/' to '\' |
| |
| if On_Windows then |
| for J in 1 .. Length loop |
| if Result (J) = '/' then |
| Result (J) := Directory_Separator; |
| end if; |
| end loop; |
| end if; |
| |
| -- Add directory separator, if needed |
| |
| if Result (Length) = Directory_Separator then |
| return Result (1 .. Length); |
| else |
| Result (Result'Length) := Directory_Separator; |
| return Result; |
| end if; |
| |
| -- Directory name not given, get current directory |
| |
| else |
| declare |
| Buffer : String (1 .. Max_Path + 2); |
| Path_Len : Natural := Max_Path; |
| |
| begin |
| Get_Current_Dir (Buffer'Address, Path_Len'Address); |
| |
| if Buffer (Path_Len) /= Directory_Separator then |
| Path_Len := Path_Len + 1; |
| Buffer (Path_Len) := Directory_Separator; |
| end if; |
| |
| -- By default, the drive letter on Windows is in upper case |
| |
| if On_Windows |
| and then Path_Len >= 2 |
| and then Buffer (2) = ':' |
| then |
| System.Case_Util.To_Upper (Buffer (1 .. 1)); |
| end if; |
| |
| return Buffer (1 .. Path_Len); |
| end; |
| end if; |
| end Get_Directory; |
| |
| -- Start of processing for Normalize_Pathname |
| |
| begin |
| -- Special case, if name is null, then return null |
| |
| if Name'Length = 0 then |
| return ""; |
| end if; |
| |
| -- First, convert VMS file spec to Unix file spec. |
| -- If Name is not in VMS syntax, then this is equivalent |
| -- to put Name at the beginning of Path_Buffer. |
| |
| VMS_Conversion : begin |
| The_Name (1 .. Name'Length) := Name; |
| The_Name (The_Name'Last) := ASCII.NUL; |
| |
| Canonical_File_Addr := To_Canonical_File_Spec (The_Name'Address); |
| Canonical_File_Len := Strlen (Canonical_File_Addr); |
| |
| -- If VMS syntax conversion has failed, return an empty string |
| -- to indicate the failure. |
| |
| if Canonical_File_Len = 0 then |
| return ""; |
| end if; |
| |
| declare |
| subtype Path_String is String (1 .. Canonical_File_Len); |
| type Path_String_Access is access Path_String; |
| |
| function Address_To_Access is new |
| Ada.Unchecked_Conversion (Source => Address, |
| Target => Path_String_Access); |
| |
| Path_Access : constant Path_String_Access := |
| Address_To_Access (Canonical_File_Addr); |
| |
| begin |
| Path_Buffer (1 .. Canonical_File_Len) := Path_Access.all; |
| End_Path := Canonical_File_Len; |
| Last := 1; |
| end; |
| end VMS_Conversion; |
| |
| -- Replace all '/' by Directory Separators (this is for Windows) |
| |
| if Directory_Separator /= '/' then |
| for Index in 1 .. End_Path loop |
| if Path_Buffer (Index) = '/' then |
| Path_Buffer (Index) := Directory_Separator; |
| end if; |
| end loop; |
| end if; |
| |
| -- Resolve directory names for Windows (formerly also VMS) |
| |
| -- On VMS, if we have a Unix path such as /temp/..., and TEMP is a |
| -- logical name, we must not try to resolve this logical name, because |
| -- it may have multiple equivalences and if resolved we will only |
| -- get the first one. |
| |
| if On_Windows then |
| |
| -- On Windows, if we have an absolute path starting with a directory |
| -- separator, we need to have the drive letter appended in front. |
| |
| -- On Windows, Get_Current_Dir will return a suitable directory name |
| -- (path starting with a drive letter on Windows). So we take this |
| -- drive letter and prepend it to the current path. |
| |
| if Path_Buffer (1) = Directory_Separator |
| and then Path_Buffer (2) /= Directory_Separator |
| then |
| declare |
| Cur_Dir : constant String := Get_Directory (""); |
| -- Get the current directory to get the drive letter |
| |
| begin |
| if Cur_Dir'Length > 2 |
| and then Cur_Dir (Cur_Dir'First + 1) = ':' |
| then |
| Path_Buffer (3 .. End_Path + 2) := |
| Path_Buffer (1 .. End_Path); |
| Path_Buffer (1 .. 2) := |
| Cur_Dir (Cur_Dir'First .. Cur_Dir'First + 1); |
| End_Path := End_Path + 2; |
| end if; |
| end; |
| |
| -- We have a drive letter, ensure it is upper-case |
| |
| elsif Path_Buffer (1) in 'a' .. 'z' |
| and then Path_Buffer (2) = ':' |
| then |
| System.Case_Util.To_Upper (Path_Buffer (1 .. 1)); |
| end if; |
| end if; |
| |
| -- On Windows, remove all double-quotes that are possibly part of the |
| -- path but can cause problems with other methods. |
| |
| if On_Windows then |
| declare |
| Index : Natural; |
| |
| begin |
| Index := Path_Buffer'First; |
| for Current in Path_Buffer'First .. End_Path loop |
| if Path_Buffer (Current) /= '"' then |
| Path_Buffer (Index) := Path_Buffer (Current); |
| Index := Index + 1; |
| end if; |
| end loop; |
| |
| End_Path := Index - 1; |
| end; |
| end if; |
| |
| -- Start the conversions |
| |
| -- If this is not finished after Max_Iterations, give up and return an |
| -- empty string. |
| |
| for J in 1 .. Max_Iterations loop |
| |
| -- If we don't have an absolute pathname, prepend the directory |
| -- Reference_Dir. |
| |
| if Last = 1 |
| and then not Is_Absolute_Path (Path_Buffer (1 .. End_Path)) |
| then |
| declare |
| Reference_Dir : constant String := Get_Directory (Directory); |
| Ref_Dir_Len : constant Natural := Reference_Dir'Length; |
| -- Current directory name specified and its length |
| |
| begin |
| Path_Buffer (Ref_Dir_Len + 1 .. Ref_Dir_Len + End_Path) := |
| Path_Buffer (1 .. End_Path); |
| End_Path := Ref_Dir_Len + End_Path; |
| Path_Buffer (1 .. Ref_Dir_Len) := Reference_Dir; |
| Last := Ref_Dir_Len; |
| end; |
| end if; |
| |
| Start := Last + 1; |
| Finish := Last; |
| |
| -- Ensure that Windows network drives are kept, e.g: \\server\drive-c |
| |
| if Start = 2 |
| and then Directory_Separator = '\' |
| and then Path_Buffer (1 .. 2) = "\\" |
| then |
| Start := 3; |
| end if; |
| |
| -- If we have traversed the full pathname, return it |
| |
| if Start > End_Path then |
| return Final_Value (Path_Buffer (1 .. End_Path)); |
| end if; |
| |
| -- Remove duplicate directory separators |
| |
| while Path_Buffer (Start) = Directory_Separator loop |
| if Start = End_Path then |
| return Final_Value (Path_Buffer (1 .. End_Path - 1)); |
| |
| else |
| Path_Buffer (Start .. End_Path - 1) := |
| Path_Buffer (Start + 1 .. End_Path); |
| End_Path := End_Path - 1; |
| end if; |
| end loop; |
| |
| -- Find the end of the current field: last character or the one |
| -- preceding the next directory separator. |
| |
| while Finish < End_Path |
| and then Path_Buffer (Finish + 1) /= Directory_Separator |
| loop |
| Finish := Finish + 1; |
| end loop; |
| |
| -- Remove "." field |
| |
| if Start = Finish and then Path_Buffer (Start) = '.' then |
| if Start = End_Path then |
| if Last = 1 then |
| return (1 => Directory_Separator); |
| else |
| |
| if Fold_To_Lower_Case then |
| System.Case_Util.To_Lower (Path_Buffer (1 .. Last - 1)); |
| end if; |
| |
| return Path_Buffer (1 .. Last - 1); |
| |
| end if; |
| |
| else |
| Path_Buffer (Last + 1 .. End_Path - 2) := |
| Path_Buffer (Last + 3 .. End_Path); |
| End_Path := End_Path - 2; |
| end if; |
| |
| -- Remove ".." fields |
| |
| elsif Finish = Start + 1 |
| and then Path_Buffer (Start .. Finish) = ".." |
| then |
| Start := Last; |
| loop |
| Start := Start - 1; |
| exit when Start < 1 or else |
| Path_Buffer (Start) = Directory_Separator; |
| end loop; |
| |
| if Start <= 1 then |
| if Finish = End_Path then |
| return (1 => Directory_Separator); |
| |
| else |
| Path_Buffer (1 .. End_Path - Finish) := |
| Path_Buffer (Finish + 1 .. End_Path); |
| End_Path := End_Path - Finish; |
| Last := 1; |
| end if; |
| |
| else |
| if Finish = End_Path then |
| return Final_Value (Path_Buffer (1 .. Start - 1)); |
| |
| else |
| Path_Buffer (Start + 1 .. Start + End_Path - Finish - 1) := |
| Path_Buffer (Finish + 2 .. End_Path); |
| End_Path := Start + End_Path - Finish - 1; |
| Last := Start; |
| end if; |
| end if; |
| |
| -- Check if current field is a symbolic link |
| |
| elsif Resolve_Links then |
| declare |
| Saved : constant Character := Path_Buffer (Finish + 1); |
| |
| begin |
| Path_Buffer (Finish + 1) := ASCII.NUL; |
| Status := Readlink (Path_Buffer'Address, |
| Link_Buffer'Address, |
| Link_Buffer'Length); |
| Path_Buffer (Finish + 1) := Saved; |
| end; |
| |
| -- Not a symbolic link, move to the next field, if any |
| |
| if Status <= 0 then |
| Last := Finish + 1; |
| |
| -- Replace symbolic link with its value |
| |
| else |
| if Is_Absolute_Path (Link_Buffer (1 .. Status)) then |
| Path_Buffer (Status + 1 .. End_Path - (Finish - Status)) := |
| Path_Buffer (Finish + 1 .. End_Path); |
| End_Path := End_Path - (Finish - Status); |
| Path_Buffer (1 .. Status) := Link_Buffer (1 .. Status); |
| Last := 1; |
| |
| else |
| Path_Buffer |
| (Last + Status + 1 .. End_Path - Finish + Last + Status) := |
| Path_Buffer (Finish + 1 .. End_Path); |
| End_Path := End_Path - Finish + Last + Status; |
| Path_Buffer (Last + 1 .. Last + Status) := |
| Link_Buffer (1 .. Status); |
| end if; |
| end if; |
| |
| else |
| Last := Finish + 1; |
| end if; |
| end loop; |
| |
| -- Too many iterations: give up |
| |
| -- This can happen when there is a circularity in the symbolic links: A |
| -- is a symbolic link for B, which itself is a symbolic link, and the |
| -- target of B or of another symbolic link target of B is A. In this |
| -- case, we return an empty string to indicate failure to resolve. |
| |
| return ""; |
| end Normalize_Pathname; |
| |
| --------------- |
| -- Open_Read -- |
| --------------- |
| |
| function Open_Read |
| (Name : C_File_Name; |
| Fmode : Mode) return File_Descriptor |
| is |
| function C_Open_Read |
| (Name : C_File_Name; |
| Fmode : Mode) return File_Descriptor; |
| pragma Import (C, C_Open_Read, "__gnat_open_read"); |
| begin |
| return C_Open_Read (Name, Fmode); |
| end Open_Read; |
| |
| function Open_Read |
| (Name : String; |
| Fmode : Mode) return File_Descriptor |
| is |
| C_Name : String (1 .. Name'Length + 1); |
| begin |
| C_Name (1 .. Name'Length) := Name; |
| C_Name (C_Name'Last) := ASCII.NUL; |
| return Open_Read (C_Name (C_Name'First)'Address, Fmode); |
| end Open_Read; |
| |
| --------------------- |
| -- Open_Read_Write -- |
| --------------------- |
| |
| function Open_Read_Write |
| (Name : C_File_Name; |
| Fmode : Mode) return File_Descriptor |
| is |
| function C_Open_Read_Write |
| (Name : C_File_Name; |
| Fmode : Mode) return File_Descriptor; |
| pragma Import (C, C_Open_Read_Write, "__gnat_open_rw"); |
| begin |
| return C_Open_Read_Write (Name, Fmode); |
| end Open_Read_Write; |
| |
| function Open_Read_Write |
| (Name : String; |
| Fmode : Mode) return File_Descriptor |
| is |
| C_Name : String (1 .. Name'Length + 1); |
| begin |
| C_Name (1 .. Name'Length) := Name; |
| C_Name (C_Name'Last) := ASCII.NUL; |
| return Open_Read_Write (C_Name (C_Name'First)'Address, Fmode); |
| end Open_Read_Write; |
| |
| ------------- |
| -- OS_Exit -- |
| ------------- |
| |
| procedure OS_Exit (Status : Integer) is |
| begin |
| OS_Exit_Ptr (Status); |
| raise Program_Error; |
| end OS_Exit; |
| |
| --------------------- |
| -- OS_Exit_Default -- |
| --------------------- |
| |
| procedure OS_Exit_Default (Status : Integer) is |
| procedure GNAT_OS_Exit (Status : Integer); |
| pragma Import (C, GNAT_OS_Exit, "__gnat_os_exit"); |
| pragma No_Return (GNAT_OS_Exit); |
| begin |
| GNAT_OS_Exit (Status); |
| end OS_Exit_Default; |
| |
| -------------------- |
| -- Pid_To_Integer -- |
| -------------------- |
| |
| function Pid_To_Integer (Pid : Process_Id) return Integer is |
| begin |
| return Integer (Pid); |
| end Pid_To_Integer; |
| |
| ---------- |
| -- Read -- |
| ---------- |
| |
| function Read |
| (FD : File_Descriptor; |
| A : System.Address; |
| N : Integer) return Integer |
| is |
| begin |
| return |
| Integer (System.CRTL.read |
| (System.CRTL.int (FD), |
| System.CRTL.chars (A), |
| System.CRTL.size_t (N))); |
| end Read; |
| |
| ----------------- |
| -- Rename_File -- |
| ----------------- |
| |
| procedure Rename_File |
| (Old_Name : C_File_Name; |
| New_Name : C_File_Name; |
| Success : out Boolean) |
| is |
| function rename (From, To : Address) return Integer; |
| pragma Import (C, rename, "__gnat_rename"); |
| R : Integer; |
| begin |
| R := rename (Old_Name, New_Name); |
| Success := (R = 0); |
| end Rename_File; |
| |
| procedure Rename_File |
| (Old_Name : String; |
| New_Name : String; |
| Success : out Boolean) |
| is |
| C_Old_Name : String (1 .. Old_Name'Length + 1); |
| C_New_Name : String (1 .. New_Name'Length + 1); |
| begin |
| C_Old_Name (1 .. Old_Name'Length) := Old_Name; |
| C_Old_Name (C_Old_Name'Last) := ASCII.NUL; |
| C_New_Name (1 .. New_Name'Length) := New_Name; |
| C_New_Name (C_New_Name'Last) := ASCII.NUL; |
| Rename_File (C_Old_Name'Address, C_New_Name'Address, Success); |
| end Rename_File; |
| |
| ----------------------- |
| -- Set_Close_On_Exec -- |
| ----------------------- |
| |
| procedure Set_Close_On_Exec |
| (FD : File_Descriptor; |
| Close_On_Exec : Boolean; |
| Status : out Boolean) |
| is |
| function C_Set_Close_On_Exec |
| (FD : File_Descriptor; Close_On_Exec : System.CRTL.int) |
| return System.CRTL.int; |
| pragma Import (C, C_Set_Close_On_Exec, "__gnat_set_close_on_exec"); |
| begin |
| Status := C_Set_Close_On_Exec (FD, Boolean'Pos (Close_On_Exec)) = 0; |
| end Set_Close_On_Exec; |
| |
| -------------------- |
| -- Set_Executable -- |
| -------------------- |
| |
| procedure Set_Executable (Name : String) is |
| procedure C_Set_Executable (Name : C_File_Name); |
| pragma Import (C, C_Set_Executable, "__gnat_set_executable"); |
| C_Name : aliased String (Name'First .. Name'Last + 1); |
| begin |
| C_Name (Name'Range) := Name; |
| C_Name (C_Name'Last) := ASCII.NUL; |
| C_Set_Executable (C_Name (C_Name'First)'Address); |
| end Set_Executable; |
| |
| ---------------------- |
| -- Set_Non_Readable -- |
| ---------------------- |
| |
| procedure Set_Non_Readable (Name : String) is |
| procedure C_Set_Non_Readable (Name : C_File_Name); |
| pragma Import (C, C_Set_Non_Readable, "__gnat_set_non_readable"); |
| C_Name : aliased String (Name'First .. Name'Last + 1); |
| begin |
| C_Name (Name'Range) := Name; |
| C_Name (C_Name'Last) := ASCII.NUL; |
| C_Set_Non_Readable (C_Name (C_Name'First)'Address); |
| end Set_Non_Readable; |
| |
| ---------------------- |
| -- Set_Non_Writable -- |
| ---------------------- |
| |
| procedure Set_Non_Writable (Name : String) is |
| procedure C_Set_Non_Writable (Name : C_File_Name); |
| pragma Import (C, C_Set_Non_Writable, "__gnat_set_non_writable"); |
| C_Name : aliased String (Name'First .. Name'Last + 1); |
| begin |
| C_Name (Name'Range) := Name; |
| C_Name (C_Name'Last) := ASCII.NUL; |
| C_Set_Non_Writable (C_Name (C_Name'First)'Address); |
| end Set_Non_Writable; |
| |
| ------------------ |
| -- Set_Readable -- |
| ------------------ |
| |
| procedure Set_Readable (Name : String) is |
| procedure C_Set_Readable (Name : C_File_Name); |
| pragma Import (C, C_Set_Readable, "__gnat_set_readable"); |
| C_Name : aliased String (Name'First .. Name'Last + 1); |
| begin |
| C_Name (Name'Range) := Name; |
| C_Name (C_Name'Last) := ASCII.NUL; |
| C_Set_Readable (C_Name (C_Name'First)'Address); |
| end Set_Readable; |
| |
| -------------------- |
| -- Set_Writable -- |
| -------------------- |
| |
| procedure Set_Writable (Name : String) is |
| procedure C_Set_Writable (Name : C_File_Name); |
| pragma Import (C, C_Set_Writable, "__gnat_set_writable"); |
| C_Name : aliased String (Name'First .. Name'Last + 1); |
| begin |
| C_Name (Name'Range) := Name; |
| C_Name (C_Name'Last) := ASCII.NUL; |
| C_Set_Writable (C_Name (C_Name'First)'Address); |
| end Set_Writable; |
| |
| ------------ |
| -- Setenv -- |
| ------------ |
| |
| procedure Setenv (Name : String; Value : String) is |
| F_Name : String (1 .. Name'Length + 1); |
| F_Value : String (1 .. Value'Length + 1); |
| |
| procedure Set_Env_Value (Name, Value : System.Address); |
| pragma Import (C, Set_Env_Value, "__gnat_setenv"); |
| |
| begin |
| F_Name (1 .. Name'Length) := Name; |
| F_Name (F_Name'Last) := ASCII.NUL; |
| |
| F_Value (1 .. Value'Length) := Value; |
| F_Value (F_Value'Last) := ASCII.NUL; |
| |
| Set_Env_Value (F_Name'Address, F_Value'Address); |
| end Setenv; |
| |
| ----------- |
| -- Spawn -- |
| ----------- |
| |
| function Spawn |
| (Program_Name : String; |
| Args : Argument_List) return Integer |
| is |
| Result : Integer; |
| Junk : Process_Id; |
| pragma Warnings (Off, Junk); |
| begin |
| Spawn_Internal (Program_Name, Args, Result, Junk, Blocking => True); |
| return Result; |
| end Spawn; |
| |
| procedure Spawn |
| (Program_Name : String; |
| Args : Argument_List; |
| Success : out Boolean) |
| is |
| begin |
| Success := (Spawn (Program_Name, Args) = 0); |
| end Spawn; |
| |
| procedure Spawn |
| (Program_Name : String; |
| Args : Argument_List; |
| Output_File_Descriptor : File_Descriptor; |
| Return_Code : out Integer; |
| Err_To_Out : Boolean := True) |
| is |
| Saved_Output : File_Descriptor; |
| Saved_Error : File_Descriptor := Invalid_FD; -- prevent compiler warning |
| |
| begin |
| -- Set standard output and error to the temporary file |
| |
| Saved_Output := Dup (Standout); |
| Dup2 (Output_File_Descriptor, Standout); |
| |
| if Err_To_Out then |
| Saved_Error := Dup (Standerr); |
| Dup2 (Output_File_Descriptor, Standerr); |
| end if; |
| |
| -- Spawn the program |
| |
| Return_Code := Spawn (Program_Name, Args); |
| |
| -- Restore the standard output and error |
| |
| Dup2 (Saved_Output, Standout); |
| |
| if Err_To_Out then |
| Dup2 (Saved_Error, Standerr); |
| end if; |
| |
| -- And close the saved standard output and error file descriptors |
| |
| Close (Saved_Output); |
| |
| if Err_To_Out then |
| Close (Saved_Error); |
| end if; |
| end Spawn; |
| |
| procedure Spawn |
| (Program_Name : String; |
| Args : Argument_List; |
| Output_File : String; |
| Success : out Boolean; |
| Return_Code : out Integer; |
| Err_To_Out : Boolean := True) |
| is |
| FD : File_Descriptor; |
| |
| begin |
| Success := True; |
| Return_Code := 0; |
| |
| FD := Create_Output_Text_File (Output_File); |
| |
| if FD = Invalid_FD then |
| Success := False; |
| return; |
| end if; |
| |
| Spawn (Program_Name, Args, FD, Return_Code, Err_To_Out); |
| |
| Close (FD, Success); |
| end Spawn; |
| |
| -------------------- |
| -- Spawn_Internal -- |
| -------------------- |
| |
| procedure Spawn_Internal |
| (Program_Name : String; |
| Args : Argument_List; |
| Result : out Integer; |
| Pid : out Process_Id; |
| Blocking : Boolean) |
| is |
| |
| procedure Spawn (Args : Argument_List); |
| -- Call Spawn with given argument list |
| |
| N_Args : Argument_List (Args'Range); |
| -- Normalized arguments |
| |
| ----------- |
| -- Spawn -- |
| ----------- |
| |
| procedure Spawn (Args : Argument_List) is |
| type Chars is array (Positive range <>) of aliased Character; |
| type Char_Ptr is access constant Character; |
| |
| Command_Len : constant Positive := Program_Name'Length + 1 |
| + Args_Length (Args); |
| Command_Last : Natural := 0; |
| Command : aliased Chars (1 .. Command_Len); |
| -- Command contains all characters of the Program_Name and Args, all |
| -- terminated by ASCII.NUL characters. |
| |
| Arg_List_Len : constant Positive := Args'Length + 2; |
| Arg_List_Last : Natural := 0; |
| Arg_List : aliased array (1 .. Arg_List_Len) of Char_Ptr; |
| -- List with pointers to NUL-terminated strings of the Program_Name |
| -- and the Args and terminated with a null pointer. We rely on the |
| -- default initialization for the last null pointer. |
| |
| procedure Add_To_Command (S : String); |
| -- Add S and a NUL character to Command, updating Last |
| |
| function Portable_Spawn (Args : Address) return Integer; |
| pragma Import (C, Portable_Spawn, "__gnat_portable_spawn"); |
| |
| function Portable_No_Block_Spawn (Args : Address) return Process_Id; |
| pragma Import |
| (C, Portable_No_Block_Spawn, "__gnat_portable_no_block_spawn"); |
| |
| -------------------- |
| -- Add_To_Command -- |
| -------------------- |
| |
| procedure Add_To_Command (S : String) is |
| First : constant Natural := Command_Last + 1; |
| |
| begin |
| Command_Last := Command_Last + S'Length; |
| |
| -- Move characters one at a time, because Command has aliased |
| -- components. |
| |
| -- But not volatile, so why is this necessary ??? |
| |
| for J in S'Range loop |
| Command (First + J - S'First) := S (J); |
| end loop; |
| |
| Command_Last := Command_Last + 1; |
| Command (Command_Last) := ASCII.NUL; |
| |
| Arg_List_Last := Arg_List_Last + 1; |
| Arg_List (Arg_List_Last) := Command (First)'Access; |
| end Add_To_Command; |
| |
| -- Start of processing for Spawn |
| |
| begin |
| Add_To_Command (Program_Name); |
| |
| for J in Args'Range loop |
| Add_To_Command (Args (J).all); |
| end loop; |
| |
| if Blocking then |
| Pid := Invalid_Pid; |
| Result := Portable_Spawn (Arg_List'Address); |
| else |
| Pid := Portable_No_Block_Spawn (Arg_List'Address); |
| Result := Boolean'Pos (Pid /= Invalid_Pid); |
| end if; |
| end Spawn; |
| |
| -- Start of processing for Spawn_Internal |
| |
| begin |
| -- Copy arguments into a local structure |
| |
| for K in N_Args'Range loop |
| N_Args (K) := new String'(Args (K).all); |
| end loop; |
| |
| -- Normalize those arguments |
| |
| Normalize_Arguments (N_Args); |
| |
| -- Call spawn using the normalized arguments |
| |
| Spawn (N_Args); |
| |
| -- Free arguments list |
| |
| for K in N_Args'Range loop |
| Free (N_Args (K)); |
| end loop; |
| end Spawn_Internal; |
| |
| --------------------------- |
| -- To_Path_String_Access -- |
| --------------------------- |
| |
| function To_Path_String_Access |
| (Path_Addr : Address; |
| Path_Len : Integer) return String_Access |
| is |
| subtype Path_String is String (1 .. Path_Len); |
| type Path_String_Access is access Path_String; |
| |
| function Address_To_Access is new Ada.Unchecked_Conversion |
| (Source => Address, Target => Path_String_Access); |
| |
| Path_Access : constant Path_String_Access := |
| Address_To_Access (Path_Addr); |
| |
| Return_Val : String_Access; |
| |
| begin |
| Return_Val := new String (1 .. Path_Len); |
| |
| for J in 1 .. Path_Len loop |
| Return_Val (J) := Path_Access (J); |
| end loop; |
| |
| return Return_Val; |
| end To_Path_String_Access; |
| |
| ------------------ |
| -- Wait_Process -- |
| ------------------ |
| |
| procedure Wait_Process (Pid : out Process_Id; Success : out Boolean) is |
| Status : Integer; |
| |
| function Portable_Wait (S : Address) return Process_Id; |
| pragma Import (C, Portable_Wait, "__gnat_portable_wait"); |
| |
| begin |
| Pid := Portable_Wait (Status'Address); |
| Success := (Status = 0); |
| end Wait_Process; |
| |
| ----------- |
| -- Write -- |
| ----------- |
| |
| function Write |
| (FD : File_Descriptor; |
| A : System.Address; |
| N : Integer) return Integer |
| is |
| begin |
| return |
| Integer (System.CRTL.write |
| (System.CRTL.int (FD), |
| System.CRTL.chars (A), |
| System.CRTL.size_t (N))); |
| end Write; |
| |
| end System.OS_Lib; |
