-- --
-- B o d y --
-- --
--- Copyright (C) 1995-2007, AdaCore --
+-- Copyright (C) 1995-2009, 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- --
-- --
------------------------------------------------------------------------------
-pragma Warnings (Off);
pragma Compiler_Unit;
-pragma Warnings (On);
with System.Case_Util;
with System.CRTL;
-----------------------
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
+ -- 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
-- Internal exception raised to signal error in copy
function Build_Path (Dir : String; File : String) return String;
- -- Returns pathname Dir catenated with File adding the directory
+ -- Returns pathname Dir concatenated with File adding the directory
-- separator only if needed.
procedure Copy (From, To : File_Descriptor);
begin
From := Open_Read (Name, Binary);
- To := Create_File (To_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_From (C_From'Last) := ASCII.NUL;
C_To (1 .. To_Name'Length) := To_Name;
- C_To (C_To'Last) := ASCII.Nul;
+ C_To (C_To'Last) := ASCII.NUL;
case Preserve is
if Is_Regular_File (Pathname) then
-- Append mode and destination file exists, append data at the
- -- end of Pathname.
+ -- end of Pathname. But if we fail to open source file, do not
+ -- touch destination file at all.
From := Open_Read (Name, Binary);
- To := Open_Read_Write (Pathname, Binary);
+ if From /= Invalid_FD then
+ To := Open_Read_Write (Pathname, Binary);
+ end if;
+
Lseek (To, 0, Seek_End);
Copy (From, To);
Mode : Copy_Mode := Copy;
Preserve : Attribute := Time_Stamps)
is
- Ada_Name : String_Access :=
- To_Path_String_Access
- (Name, C_String_Length (Name));
-
+ 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);
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;
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));
+ 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);
(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
-- If it is not a digit, then there are no available
-- temp file names. Return Invalid_FD. There is almost
- -- no that this code will be ever be executed, since
- -- it would mean that there are one million temp files
- -- in the same directory!
+ -- 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;
-- Attempt to create the file
- FD := Create_New_File (Current, Binary);
+ 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);
end if;
end if;
end loop File_Loop;
- end Create_Temp_File;
+ end Create_Temp_File_Internal;
-----------------
-- Delete_File --
procedure Delete_File (Name : Address; Success : out Boolean) is
R : Integer;
-
- function unlink (A : Address) return Integer;
- pragma Import (C, unlink, "unlink");
-
begin
- R := unlink (Name);
+ R := System.CRTL.unlink (Name);
Success := (R = 0);
end Delete_File;
---------------------
function File_Time_Stamp (FD : File_Descriptor) return OS_Time is
- function File_Time (FD : File_Descriptor) return OS_Time;
+ function File_Time (FD : File_Descriptor) return OS_Time;
pragma Import (C, File_Time, "__gnat_file_time_fd");
begin
return File_Time (FD);
------------
function GM_Day (Date : OS_Time) return Day_Type is
+ D : Day_Type;
+
+ pragma Warnings (Off);
Y : Year_Type;
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);
-------------
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;
- H : Hour_Type;
Mn : Minute_Type;
S : Second_Type;
+ pragma Warnings (On);
begin
GM_Split (Date, Y, Mo, D, H, Mn, S);
---------------
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;
- Mn : Minute_Type;
S : Second_Type;
+ pragma Warnings (On);
begin
GM_Split (Date, Y, Mo, D, H, Mn, S);
--------------
function GM_Month (Date : OS_Time) return Month_Type is
- Y : Year_Type;
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);
---------------
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;
- S : Second_Type;
+ pragma Warnings (On);
begin
GM_Split (Date, Y, Mo, D, H, Mn, S);
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 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 --
---------------------
if Path_Len = 0 then
return null;
+
else
Result := To_Path_String_Access (Path_Addr, Path_Len);
Free (Path_Addr);
(Program_Name : String;
Args : Argument_List) return Process_Id
is
- Junk : Integer;
Pid : Process_Id;
-
+ Junk : Integer;
+ pragma Warnings (Off, Junk);
begin
Spawn_Internal (Program_Name, Args, Junk, Pid, Blocking => False);
return Pid;
-- If null terminated string, put the quote before
- if Res (J) = ASCII.Nul then
+ if Res (J) = ASCII.NUL then
Res (J) := '"';
J := J + 1;
- Res (J) := ASCII.Nul;
+ 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
-------------------
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 Dir'Length > 0 then
- if Dir (Dir'Last) = Directory_Separator then
- return Dir;
+ 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
- declare
- Result : String (1 .. Dir'Length + 1);
- begin
- Result (1 .. Dir'Length) := Dir;
- Result (Result'Length) := Directory_Separator;
- return Result;
- end;
+ Result (Result'Length) := Directory_Separator;
+ return Result;
end if;
-- Directory name not given, get current directory
-- By default, the drive letter on Windows is in upper case
- if On_Windows and then Path_Len >= 2 and then
- Buffer (2) = ':'
+ if On_Windows
+ and then Path_Len >= 2
+ and then Buffer (2) = ':'
then
System.Case_Util.To_Upper (Buffer (1 .. 1));
end if;
end if;
end Get_Directory;
- Reference_Dir : constant String := Get_Directory (Directory);
- -- Current directory name specified
-
-- Start of processing for Normalize_Pathname
begin
-- 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 begining of Path_Buffer.
+ -- to put Name at the beginning of Path_Buffer.
VMS_Conversion : begin
The_Name (1 .. Name'Length) := Name;
-- it may have multiple equivalences and if resolved we will only
-- get the first one.
- -- On Windows, if we have an absolute path starting with a directory
- -- separator, we need to have the drive letter appended in front.
+ if On_Windows then
- -- 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.
+ -- 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
- if On_Windows
- and then Path_Buffer (1) = Directory_Separator
- and then Path_Buffer (2) /= Directory_Separator
- then
+ 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
- Cur_Dir : String := Get_Directory ("");
- -- Get the current directory to get the drive letter
+ Index : Natural;
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;
+ 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;
if Last = 1
and then not Is_Absolute_Path (Path_Buffer (1 .. End_Path))
then
- Path_Buffer
- (Reference_Dir'Length + 1 .. Reference_Dir'Length + End_Path) :=
+ 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 := Reference_Dir'Length + End_Path;
- Path_Buffer (1 .. Reference_Dir'Length) := Reference_Dir;
- Last := Reference_Dir'Length;
+ 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;
Success : out Boolean)
is
function rename (From, To : Address) return Integer;
- pragma Import (C, rename, "rename");
+ pragma Import (C, rename, "__gnat_rename");
R : Integer;
begin
R := rename (Old_Name, New_Name);
C_Set_Executable (C_Name (C_Name'First)'Address);
end Set_Executable;
- --------------------
- -- Set_Read_Only --
- --------------------
+ ----------------------
+ -- 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_Read_Only (Name : String) is
- procedure C_Set_Read_Only (Name : C_File_Name);
- pragma Import (C, C_Set_Read_Only, "__gnat_set_readonly");
+ 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_Read_Only (C_Name (C_Name'First)'Address);
- end Set_Read_Only;
+ 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 --
(Program_Name : String;
Args : Argument_List) return Integer
is
- Junk : Process_Id;
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;
- Output_File : String;
- Success : out Boolean;
- Return_Code : out Integer;
- Err_To_Out : Boolean := True)
+ (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;
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_Len : constant Positive := Program_Name'Length + 1
+ + Args_Length (Args);
Command_Last : Natural := 0;
- Command : aliased Chars (1 .. Command_Len);
+ Command : aliased Chars (1 .. Command_Len);
-- Command contains all characters of the Program_Name and Args, all
- -- terminated by ASCII.NUL characters
+ -- terminated by ASCII.NUL characters.
- Arg_List_Len : constant Positive := Args'Length + 2;
+ Arg_List_Len : constant Positive := Args'Length + 2;
Arg_List_Last : Natural := 0;
- Arg_List : aliased array (1 .. Arg_List_Len) of Char_Ptr;
+ 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.
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);
+ 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);
OSDN Git Service
