1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
5 -- S Y S T E M . O S _ L I B --
9 -- Copyright (C) 1995-2014, AdaCore --
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 3, 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. --
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
19 -- additional permissions described in the GCC Runtime Library Exception, --
20 -- version 3.1, as published by the Free Software Foundation. --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
30 ------------------------------------------------------------------------------
32 pragma Compiler_Unit_Warning
;
34 with Ada
.Unchecked_Conversion
;
35 with Ada
.Unchecked_Deallocation
;
36 with System
; use System
;
37 with System
.Case_Util
;
39 with System
.Soft_Links
;
41 package body System
.OS_Lib
is
43 subtype size_t
is CRTL
.size_t
;
45 procedure Strncpy
(dest
, src
: System
.Address
; n
: size_t
)
48 -- Imported procedures Dup and Dup2 are used in procedures Spawn and
49 -- Non_Blocking_Spawn.
51 function Dup
(Fd
: File_Descriptor
) return File_Descriptor
;
52 pragma Import
(C
, Dup
, "__gnat_dup");
54 procedure Dup2
(Old_Fd
, New_Fd
: File_Descriptor
);
55 pragma Import
(C
, Dup2
, "__gnat_dup2");
57 function Copy_Attributes
58 (From
, To
: System
.Address
;
59 Mode
: Integer) return Integer;
60 pragma Import
(C
, Copy_Attributes
, "__gnat_copy_attribs");
61 -- Mode = 0 - copy only time stamps.
62 -- Mode = 1 - copy time stamps and read/write/execute attributes
64 On_Windows
: constant Boolean := Directory_Separator
= '\';
65 -- An indication that we are on Windows. Used in Normalize_Pathname, to
66 -- deal with drive letters in the beginning of absolute paths.
68 package SSL
renames System
.Soft_Links
;
70 -- The following are used by Create_Temp_File
72 First_Temp_File_Name
: constant String := "GNAT-TEMP-000000.TMP";
73 -- Used to initialize Current_Temp_File_Name and Temp_File_Name_Last_Digit
75 Current_Temp_File_Name
: String := First_Temp_File_Name
;
76 -- Name of the temp file last created
78 Temp_File_Name_Last_Digit
: constant Positive :=
79 First_Temp_File_Name
'Last - 4;
80 -- Position of the last digit in Current_Temp_File_Name
82 Max_Attempts
: constant := 100;
83 -- The maximum number of attempts to create a new temp file
85 -----------------------
86 -- Local Subprograms --
87 -----------------------
89 function Args_Length
(Args
: Argument_List
) return Natural;
90 -- Returns total number of characters needed to create a string of all Args
91 -- terminated by ASCII.NUL characters.
93 procedure Create_Temp_File_Internal
94 (FD
: out File_Descriptor
;
95 Name
: out String_Access
;
97 -- Internal routine to implement two Create_Temp_File routines. If Stdout
98 -- is set to True the created descriptor is stdout-compatible, otherwise
99 -- it might not be depending on the OS. The first two parameters are as
100 -- in Create_Temp_File.
102 function C_String_Length
(S
: Address
) return Integer;
103 -- Returns the length of C (null-terminated) string at S, or 0 for
106 procedure Spawn_Internal
107 (Program_Name
: String;
108 Args
: Argument_List
;
109 Result
: out Integer;
110 Pid
: out Process_Id
;
112 -- Internal routine to implement the two Spawn (blocking/non blocking)
113 -- routines. If Blocking is set to True then the spawn is blocking
114 -- otherwise it is non blocking. In this latter case the Pid contains the
115 -- process id number. The first three parameters are as in Spawn. Note that
116 -- Spawn_Internal normalizes the argument list before calling the low level
117 -- system spawn routines (see Normalize_Arguments).
119 -- Note: Normalize_Arguments is designed to do nothing if it is called more
120 -- than once, so calling Normalize_Arguments before calling one of the
121 -- spawn routines is fine.
123 function To_Path_String_Access
124 (Path_Addr
: Address
;
125 Path_Len
: Integer) return String_Access
;
126 -- Converts a C String to an Ada String. We could do this making use of
127 -- Interfaces.C.Strings but we prefer not to import that entire package
133 function "<" (X
, Y
: OS_Time
) return Boolean is
135 return Long_Integer (X
) < Long_Integer (Y
);
142 function "<=" (X
, Y
: OS_Time
) return Boolean is
144 return Long_Integer (X
) <= Long_Integer (Y
);
151 function ">" (X
, Y
: OS_Time
) return Boolean is
153 return Long_Integer (X
) > Long_Integer (Y
);
160 function ">=" (X
, Y
: OS_Time
) return Boolean is
162 return Long_Integer (X
) >= Long_Integer (Y
);
169 function Args_Length
(Args
: Argument_List
) return Natural is
173 for J
in Args
'Range loop
174 Len
:= Len
+ Args
(J
)'Length + 1; -- One extra for ASCII.NUL
180 -----------------------------
181 -- Argument_String_To_List --
182 -----------------------------
184 function Argument_String_To_List
185 (Arg_String
: String) return Argument_List_Access
187 Max_Args
: constant Integer := Arg_String
'Length;
188 New_Argv
: Argument_List
(1 .. Max_Args
);
189 New_Argc
: Natural := 0;
193 Idx
:= Arg_String
'First;
196 exit when Idx
> Arg_String
'Last;
199 Quoted
: Boolean := False;
200 Backqd
: Boolean := False;
207 -- An unquoted space is the end of an argument
209 if not (Backqd
or Quoted
)
210 and then Arg_String
(Idx
) = ' '
214 -- Start of a quoted string
216 elsif not (Backqd
or Quoted
)
217 and then Arg_String
(Idx
) = '"'
221 -- End of a quoted string and end of an argument
223 elsif (Quoted
and not Backqd
)
224 and then Arg_String
(Idx
) = '"'
229 -- Following character is backquoted
231 elsif Arg_String
(Idx
) = '\' then
234 -- Turn off backquoting after advancing one character
242 exit when Idx
> Arg_String
'Last;
247 New_Argc
:= New_Argc
+ 1;
248 New_Argv
(New_Argc
) :=
249 new String'(Arg_String (Old_Idx .. Idx - 1));
251 -- Skip extraneous spaces
253 while Idx <= Arg_String'Last and then Arg_String (Idx) = ' ' loop
259 return new Argument_List'(New_Argv
(1 .. New_Argc
));
260 end Argument_String_To_List
;
262 ---------------------
263 -- C_String_Length --
264 ---------------------
266 function C_String_Length
(S
: Address
) return Integer is
268 if S
= Null_Address
then
271 return Integer (CRTL
.strlen
(S
));
279 procedure Close
(FD
: File_Descriptor
) is
281 Discard
: constant int
:= close
(int
(FD
));
286 procedure Close
(FD
: File_Descriptor
; Status
: out Boolean) is
289 Status
:= (close
(int
(FD
)) = 0);
299 Success
: out Boolean;
300 Mode
: Copy_Mode
:= Copy
;
301 Preserve
: Attribute
:= Time_Stamps
)
303 From
: File_Descriptor
;
304 To
: File_Descriptor
;
306 Copy_Error
: exception;
307 -- Internal exception raised to signal error in copy
309 function Build_Path
(Dir
: String; File
: String) return String;
310 -- Returns pathname Dir concatenated with File adding the directory
311 -- separator only if needed.
313 procedure Copy
(From
, To
: File_Descriptor
);
314 -- Read data from From and place them into To. In both cases the
315 -- operations uses the current file position. Raises Constraint_Error
316 -- if a problem occurs during the copy.
318 procedure Copy_To
(To_Name
: String);
319 -- Does a straight copy from source to designated destination file
325 function Build_Path
(Dir
: String; File
: String) return String is
326 Res
: String (1 .. Dir
'Length + File
'Length + 1);
328 Base_File_Ptr
: Integer;
329 -- The base file name is File (Base_File_Ptr + 1 .. File'Last)
331 function Is_Dirsep
(C
: Character) return Boolean;
332 pragma Inline
(Is_Dirsep
);
333 -- Returns True if C is a directory separator. On Windows we
334 -- handle both styles of directory separator.
340 function Is_Dirsep
(C
: Character) return Boolean is
342 return C
= Directory_Separator
or else C
= '/';
345 -- Start of processing for Build_Path
348 -- Find base file name
350 Base_File_Ptr
:= File
'Last;
351 while Base_File_Ptr
>= File
'First loop
352 exit when Is_Dirsep
(File
(Base_File_Ptr
));
353 Base_File_Ptr
:= Base_File_Ptr
- 1;
357 Base_File
: String renames
358 File
(Base_File_Ptr
+ 1 .. File
'Last);
361 Res
(1 .. Dir
'Length) := Dir
;
363 if Is_Dirsep
(Dir
(Dir
'Last)) then
364 Res
(Dir
'Length + 1 .. Dir
'Length + Base_File
'Length) :=
366 return Res
(1 .. Dir
'Length + Base_File
'Length);
369 Res
(Dir
'Length + 1) := Directory_Separator
;
370 Res
(Dir
'Length + 2 .. Dir
'Length + 1 + Base_File
'Length) :=
372 return Res
(1 .. Dir
'Length + 1 + Base_File
'Length);
381 procedure Copy
(From
, To
: File_Descriptor
) is
382 Buf_Size
: constant := 200_000
;
383 type Buf
is array (1 .. Buf_Size
) of Character;
384 type Buf_Ptr
is access Buf
;
390 Status_From
: Boolean;
392 -- Statuses for the calls to Close
394 procedure Free
is new Ada
.Unchecked_Deallocation
(Buf
, Buf_Ptr
);
397 -- Check for invalid descriptors, making sure that we do not
398 -- accidentally leave an open file descriptor around.
400 if From
= Invalid_FD
then
401 if To
/= Invalid_FD
then
402 Close
(To
, Status_To
);
407 elsif To
= Invalid_FD
then
408 Close
(From
, Status_From
);
412 -- Allocate the buffer on the heap
417 R
:= Read
(From
, Buffer
(1)'Address, Buf_Size
);
419 -- On some systems, the buffer may not be full. So, we need to try
420 -- again until there is nothing to read.
424 W
:= Write
(To
, Buffer
(1)'Address, R
);
428 -- Problem writing data, could be a disk full. Close files
429 -- without worrying about status, since we are raising a
430 -- Copy_Error exception in any case.
432 Close
(From
, Status_From
);
433 Close
(To
, Status_To
);
441 Close
(From
, Status_From
);
442 Close
(To
, Status_To
);
446 if not (Status_From
and Status_To
) then
455 procedure Copy_To
(To_Name
: String) is
456 C_From
: String (1 .. Name
'Length + 1);
457 C_To
: String (1 .. To_Name
'Length + 1);
460 From
:= Open_Read
(Name
, Binary
);
462 -- Do not clobber destination file if source file could not be opened
464 if From
/= Invalid_FD
then
465 To
:= Create_File
(To_Name
, Binary
);
472 C_From
(1 .. Name
'Length) := Name
;
473 C_From
(C_From
'Last) := ASCII
.NUL
;
475 C_To
(1 .. To_Name
'Length) := To_Name
;
476 C_To
(C_To
'Last) := ASCII
.NUL
;
481 if Copy_Attributes
(C_From
'Address, C_To
'Address, 0) = -1 then
486 if Copy_Attributes
(C_From
'Address, C_To
'Address, 1) = -1 then
496 -- Start of processing for Copy_File
501 -- The source file must exist
503 if not Is_Regular_File
(Name
) then
507 -- The source file exists
511 -- Copy case, target file must not exist
515 -- If the target file exists, we have an error
517 if Is_Regular_File
(Pathname
) then
520 -- Case of target is a directory
522 elsif Is_Directory
(Pathname
) then
524 Dest
: constant String := Build_Path
(Pathname
, Name
);
527 -- If target file exists, we have an error, else do copy
529 if Is_Regular_File
(Dest
) then
536 -- Case of normal copy to file (destination does not exist)
542 -- Overwrite case (destination file may or may not exist)
545 if Is_Directory
(Pathname
) then
546 Copy_To
(Build_Path
(Pathname
, Name
));
551 -- Append case (destination file may or may not exist)
555 -- Appending to existing file
557 if Is_Regular_File
(Pathname
) then
559 -- Append mode and destination file exists, append data at the
560 -- end of Pathname. But if we fail to open source file, do not
561 -- touch destination file at all.
563 From
:= Open_Read
(Name
, Binary
);
564 if From
/= Invalid_FD
then
565 To
:= Open_Read_Write
(Pathname
, Binary
);
568 Lseek
(To
, 0, Seek_End
);
572 -- Appending to directory, not allowed
574 elsif Is_Directory
(Pathname
) then
577 -- Appending when target file does not exist
584 -- All error cases are caught here
593 Pathname
: C_File_Name
;
594 Success
: out Boolean;
595 Mode
: Copy_Mode
:= Copy
;
596 Preserve
: Attribute
:= Time_Stamps
)
598 Ada_Name
: String_Access
:=
599 To_Path_String_Access
600 (Name
, C_String_Length
(Name
));
601 Ada_Pathname
: String_Access
:=
602 To_Path_String_Access
603 (Pathname
, C_String_Length
(Pathname
));
605 Copy_File
(Ada_Name
.all, Ada_Pathname
.all, Success
, Mode
, Preserve
);
610 ----------------------
611 -- Copy_Time_Stamps --
612 ----------------------
614 procedure Copy_Time_Stamps
(Source
, Dest
: String; Success
: out Boolean) is
616 if Is_Regular_File
(Source
) and then Is_Writable_File
(Dest
) then
618 C_Source
: String (1 .. Source
'Length + 1);
619 C_Dest
: String (1 .. Dest
'Length + 1);
622 C_Source
(1 .. Source
'Length) := Source
;
623 C_Source
(C_Source
'Last) := ASCII
.NUL
;
625 C_Dest
(1 .. Dest
'Length) := Dest
;
626 C_Dest
(C_Dest
'Last) := ASCII
.NUL
;
628 if Copy_Attributes
(C_Source
'Address, C_Dest
'Address, 0) = -1 then
638 end Copy_Time_Stamps
;
640 procedure Copy_Time_Stamps
641 (Source
, Dest
: C_File_Name
;
642 Success
: out Boolean)
644 Ada_Source
: String_Access
:=
645 To_Path_String_Access
646 (Source
, C_String_Length
(Source
));
647 Ada_Dest
: String_Access
:=
648 To_Path_String_Access
649 (Dest
, C_String_Length
(Dest
));
651 Copy_Time_Stamps
(Ada_Source
.all, Ada_Dest
.all, Success
);
654 end Copy_Time_Stamps
;
662 Fmode
: Mode
) return File_Descriptor
664 function C_Create_File
666 Fmode
: Mode
) return File_Descriptor
;
667 pragma Import
(C
, C_Create_File
, "__gnat_open_create");
669 return C_Create_File
(Name
, Fmode
);
674 Fmode
: Mode
) return File_Descriptor
676 C_Name
: String (1 .. Name
'Length + 1);
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
);
683 ---------------------
684 -- Create_New_File --
685 ---------------------
687 function Create_New_File
689 Fmode
: Mode
) return File_Descriptor
691 function C_Create_New_File
693 Fmode
: Mode
) return File_Descriptor
;
694 pragma Import
(C
, C_Create_New_File
, "__gnat_open_new");
696 return C_Create_New_File
(Name
, Fmode
);
699 function Create_New_File
701 Fmode
: Mode
) return File_Descriptor
703 C_Name
: String (1 .. Name
'Length + 1);
705 C_Name
(1 .. Name
'Length) := Name
;
706 C_Name
(C_Name
'Last) := ASCII
.NUL
;
707 return Create_New_File
(C_Name
(C_Name
'First)'Address, Fmode
);
710 -----------------------------
711 -- Create_Output_Text_File --
712 -----------------------------
714 function Create_Output_Text_File
(Name
: String) return File_Descriptor
is
715 function C_Create_File
716 (Name
: C_File_Name
) return File_Descriptor
;
717 pragma Import
(C
, C_Create_File
, "__gnat_create_output_file");
718 C_Name
: String (1 .. Name
'Length + 1);
720 C_Name
(1 .. Name
'Length) := Name
;
721 C_Name
(C_Name
'Last) := ASCII
.NUL
;
722 return C_Create_File
(C_Name
(C_Name
'First)'Address);
723 end Create_Output_Text_File
;
725 ----------------------
726 -- Create_Temp_File --
727 ----------------------
729 procedure Create_Temp_File
730 (FD
: out File_Descriptor
;
731 Name
: out Temp_File_Name
)
733 function Open_New_Temp
734 (Name
: System
.Address
;
735 Fmode
: Mode
) return File_Descriptor
;
736 pragma Import
(C
, Open_New_Temp
, "__gnat_open_new_temp");
739 FD
:= Open_New_Temp
(Name
'Address, Binary
);
740 end Create_Temp_File
;
742 procedure Create_Temp_File
743 (FD
: out File_Descriptor
;
744 Name
: out String_Access
)
747 Create_Temp_File_Internal
(FD
, Name
, Stdout
=> False);
748 end Create_Temp_File
;
750 -----------------------------
751 -- Create_Temp_Output_File --
752 -----------------------------
754 procedure Create_Temp_Output_File
755 (FD
: out File_Descriptor
;
756 Name
: out String_Access
)
759 Create_Temp_File_Internal
(FD
, Name
, Stdout
=> True);
760 end Create_Temp_Output_File
;
762 -------------------------------
763 -- Create_Temp_File_Internal --
764 -------------------------------
766 procedure Create_Temp_File_Internal
767 (FD
: out File_Descriptor
;
768 Name
: out String_Access
;
772 Attempts
: Natural := 0;
773 Current
: String (Current_Temp_File_Name
'Range);
775 function Create_New_Output_Text_File
776 (Name
: String) return File_Descriptor
;
777 -- Similar to Create_Output_Text_File, except it fails if the file
778 -- already exists. We need this behavior to ensure we don't accidentally
779 -- open a temp file that has just been created by a concurrently running
780 -- process. There is no point exposing this function, as it's generally
781 -- not particularly useful.
783 ---------------------------------
784 -- Create_New_Output_Text_File --
785 ---------------------------------
787 function Create_New_Output_Text_File
788 (Name
: String) return File_Descriptor
790 function C_Create_File
791 (Name
: C_File_Name
) return File_Descriptor
;
792 pragma Import
(C
, C_Create_File
, "__gnat_create_output_file_new");
793 C_Name
: String (1 .. Name
'Length + 1);
795 C_Name
(1 .. Name
'Length) := Name
;
796 C_Name
(C_Name
'Last) := ASCII
.NUL
;
797 return C_Create_File
(C_Name
(C_Name
'First)'Address);
798 end Create_New_Output_Text_File
;
801 -- Loop until a new temp file can be created
806 -- We need to protect global variable Current_Temp_File_Name
807 -- against concurrent access by different tasks.
811 -- Start at the last digit
813 Pos
:= Temp_File_Name_Last_Digit
;
817 -- Increment the digit by one
819 case Current_Temp_File_Name
(Pos
) is
821 Current_Temp_File_Name
(Pos
) :=
822 Character'Succ (Current_Temp_File_Name
(Pos
));
827 -- For 9, set the digit to 0 and go to the previous digit
829 Current_Temp_File_Name
(Pos
) := '0';
834 -- If it is not a digit, then there are no available
835 -- temp file names. Return Invalid_FD. There is almost no
836 -- chance that this code will be ever be executed, since
837 -- it would mean that there are one million temp files in
838 -- the same directory.
847 Current
:= Current_Temp_File_Name
;
849 -- We can now release the lock, because we are no longer accessing
850 -- Current_Temp_File_Name.
860 -- Attempt to create the file
863 FD
:= Create_New_Output_Text_File
(Current
);
865 FD
:= Create_New_File
(Current
, Binary
);
868 if FD
/= Invalid_FD
then
869 Name
:= new String'(Current);
873 if not Is_Regular_File (Current) then
875 -- If the file does not already exist and we are unable to create
876 -- it, we give up after Max_Attempts. Otherwise, we try again with
877 -- the next available file name.
879 Attempts := Attempts + 1;
881 if Attempts >= Max_Attempts then
888 end Create_Temp_File_Internal;
890 -------------------------
891 -- Current_Time_String --
892 -------------------------
894 function Current_Time_String return String is
895 subtype S23 is String (1 .. 23);
896 -- Holds current time in ISO 8601 format YYYY-MM-DD HH:MM:SS.SS + NUL
898 procedure Current_Time_String (Time : System.Address);
899 pragma Import (C, Current_Time_String, "__gnat_current_time_string");
900 -- Puts current time into Time in above ISO 8601 format
902 Result23 : aliased S23;
903 -- Current time in ISO 8601 format
906 Current_Time_String (Result23'Address);
907 return Result23 (1 .. 19);
908 end Current_Time_String;
914 procedure Delete_File (Name : Address; Success : out Boolean) is
917 R := System.CRTL.unlink (Name);
921 procedure Delete_File (Name : String; Success : out Boolean) is
922 C_Name : String (1 .. Name'Length + 1);
924 C_Name (1 .. Name'Length) := Name;
925 C_Name (C_Name'Last) := ASCII.NUL;
926 Delete_File (C_Name'Address, Success);
933 function Errno_Message
934 (Err : Integer := Errno;
935 Default : String := "") return String
937 function strerror (errnum : Integer) return System.Address;
938 pragma Import (C, strerror, "strerror");
940 C_Msg : constant System.Address := strerror (Err);
943 if C_Msg = Null_Address then
944 if Default /= "" then
948 -- Note: for bootstrap reasons, it is impractical
949 -- to use Integer'Image here.
955 Buf : String (1 .. 20);
956 -- Buffer large enough to hold image of largest Integer values
963 Character'Val (Character'Pos ('0') + Val mod 10);
974 return "errno = " & Buf (First .. Buf'Last);
980 Msg : String (1 .. Integer (CRTL.strlen (C_Msg)));
981 for Msg'Address use C_Msg;
982 pragma Import (Ada, Msg);
989 ---------------------
990 -- File_Time_Stamp --
991 ---------------------
993 function File_Time_Stamp (FD : File_Descriptor) return OS_Time is
994 function File_Time (FD : File_Descriptor) return OS_Time;
995 pragma Import (C, File_Time, "__gnat_file_time_fd");
997 return File_Time (FD);
1000 function File_Time_Stamp (Name : C_File_Name) return OS_Time is
1001 function File_Time (Name : Address) return OS_Time;
1002 pragma Import (C, File_Time, "__gnat_file_time_name");
1004 return File_Time (Name);
1005 end File_Time_Stamp;
1007 function File_Time_Stamp (Name : String) return OS_Time is
1008 F_Name : String (1 .. Name'Length + 1);
1010 F_Name (1 .. Name'Length) := Name;
1011 F_Name (F_Name'Last) := ASCII.NUL;
1012 return File_Time_Stamp (F_Name'Address);
1013 end File_Time_Stamp;
1015 ---------------------------
1016 -- Get_Debuggable_Suffix --
1017 ---------------------------
1019 function Get_Debuggable_Suffix return String_Access is
1020 procedure Get_Suffix_Ptr (Length, Ptr : Address);
1021 pragma Import (C, Get_Suffix_Ptr, "__gnat_get_debuggable_suffix_ptr");
1023 Suffix_Ptr : Address;
1024 Suffix_Length : Integer;
1025 Result : String_Access;
1028 Get_Suffix_Ptr (Suffix_Length'Address, Suffix_Ptr'Address);
1029 Result := new String (1 .. Suffix_Length);
1031 if Suffix_Length > 0 then
1032 Strncpy (Result.all'Address, Suffix_Ptr, size_t (Suffix_Length));
1036 end Get_Debuggable_Suffix;
1038 ---------------------------
1039 -- Get_Executable_Suffix --
1040 ---------------------------
1042 function Get_Executable_Suffix return String_Access is
1043 procedure Get_Suffix_Ptr (Length, Ptr : Address);
1044 pragma Import (C, Get_Suffix_Ptr, "__gnat_get_executable_suffix_ptr");
1046 Suffix_Ptr : Address;
1047 Suffix_Length : Integer;
1048 Result : String_Access;
1051 Get_Suffix_Ptr (Suffix_Length'Address, Suffix_Ptr'Address);
1052 Result := new String (1 .. Suffix_Length);
1054 if Suffix_Length > 0 then
1055 Strncpy (Result.all'Address, Suffix_Ptr, size_t (Suffix_Length));
1059 end Get_Executable_Suffix;
1061 -----------------------
1062 -- Get_Object_Suffix --
1063 -----------------------
1065 function Get_Object_Suffix return String_Access is
1066 procedure Get_Suffix_Ptr (Length, Ptr : Address);
1067 pragma Import (C, Get_Suffix_Ptr, "__gnat_get_object_suffix_ptr");
1069 Suffix_Ptr : Address;
1070 Suffix_Length : Integer;
1071 Result : String_Access;
1074 Get_Suffix_Ptr (Suffix_Length'Address, Suffix_Ptr'Address);
1075 Result := new String (1 .. Suffix_Length);
1077 if Suffix_Length > 0 then
1078 Strncpy (Result.all'Address, Suffix_Ptr, size_t (Suffix_Length));
1082 end Get_Object_Suffix;
1084 ----------------------------------
1085 -- Get_Target_Debuggable_Suffix --
1086 ----------------------------------
1088 function Get_Target_Debuggable_Suffix return String_Access is
1089 Target_Exec_Ext_Ptr : Address;
1091 (C, Target_Exec_Ext_Ptr, "__gnat_target_debuggable_extension");
1093 Suffix_Length : Integer;
1094 Result : String_Access;
1097 Suffix_Length := Integer (CRTL.strlen (Target_Exec_Ext_Ptr));
1098 Result := new String (1 .. Suffix_Length);
1100 if Suffix_Length > 0 then
1102 (Result.all'Address, Target_Exec_Ext_Ptr, size_t (Suffix_Length));
1106 end Get_Target_Debuggable_Suffix;
1108 ----------------------------------
1109 -- Get_Target_Executable_Suffix --
1110 ----------------------------------
1112 function Get_Target_Executable_Suffix return String_Access is
1113 Target_Exec_Ext_Ptr : Address;
1115 (C, Target_Exec_Ext_Ptr, "__gnat_target_executable_extension");
1117 Suffix_Length : Integer;
1118 Result : String_Access;
1121 Suffix_Length := Integer (CRTL.strlen (Target_Exec_Ext_Ptr));
1122 Result := new String (1 .. Suffix_Length);
1124 if Suffix_Length > 0 then
1126 (Result.all'Address, Target_Exec_Ext_Ptr, size_t (Suffix_Length));
1130 end Get_Target_Executable_Suffix;
1132 ------------------------------
1133 -- Get_Target_Object_Suffix --
1134 ------------------------------
1136 function Get_Target_Object_Suffix return String_Access is
1137 Target_Object_Ext_Ptr : Address;
1139 (C, Target_Object_Ext_Ptr, "__gnat_target_object_extension");
1141 Suffix_Length : Integer;
1142 Result : String_Access;
1145 Suffix_Length := Integer (CRTL.strlen (Target_Object_Ext_Ptr));
1146 Result := new String (1 .. Suffix_Length);
1148 if Suffix_Length > 0 then
1150 (Result.all'Address, Target_Object_Ext_Ptr, size_t (Suffix_Length));
1154 end Get_Target_Object_Suffix;
1160 function Getenv (Name : String) return String_Access is
1161 procedure Get_Env_Value_Ptr (Name, Length, Ptr : Address);
1162 pragma Import (C, Get_Env_Value_Ptr, "__gnat_getenv");
1164 Env_Value_Ptr : aliased Address;
1165 Env_Value_Length : aliased Integer;
1166 F_Name : aliased String (1 .. Name'Length + 1);
1167 Result : String_Access;
1170 F_Name (1 .. Name'Length) := Name;
1171 F_Name (F_Name'Last) := ASCII.NUL;
1174 (F_Name'Address, Env_Value_Length'Address, Env_Value_Ptr'Address);
1176 Result := new String (1 .. Env_Value_Length);
1178 if Env_Value_Length > 0 then
1180 (Result.all'Address, Env_Value_Ptr, size_t (Env_Value_Length));
1190 function GM_Day (Date : OS_Time) return Day_Type is
1198 pragma Unreferenced (Y, Mo, H, Mn, S);
1201 GM_Split (Date, Y, Mo, D, H, Mn, S);
1209 function GM_Hour (Date : OS_Time) return Hour_Type is
1217 pragma Unreferenced (Y, Mo, D, Mn, S);
1220 GM_Split (Date, Y, Mo, D, H, Mn, S);
1228 function GM_Minute (Date : OS_Time) return Minute_Type is
1236 pragma Unreferenced (Y, Mo, D, H, S);
1239 GM_Split (Date, Y, Mo, D, H, Mn, S);
1247 function GM_Month (Date : OS_Time) return Month_Type is
1255 pragma Unreferenced (Y, D, H, Mn, S);
1258 GM_Split (Date, Y, Mo, D, H, Mn, S);
1266 function GM_Second (Date : OS_Time) return Second_Type is
1274 pragma Unreferenced (Y, Mo, D, H, Mn);
1277 GM_Split (Date, Y, Mo, D, H, Mn, S);
1287 Year : out Year_Type;
1288 Month : out Month_Type;
1290 Hour : out Hour_Type;
1291 Minute : out Minute_Type;
1292 Second : out Second_Type)
1294 procedure To_GM_Time
1295 (P_Time_T, P_Year, P_Month, P_Day, P_Hours, P_Mins, P_Secs : Address);
1296 pragma Import (C, To_GM_Time, "__gnat_to_gm_time");
1298 T : OS_Time := Date;
1307 -- Use the global lock because To_GM_Time is not thread safe
1309 Locked_Processing : begin
1312 (T'Address, Y'Address, Mo'Address, D'Address,
1313 H'Address, Mn'Address, S'Address);
1314 SSL.Unlock_Task.all;
1318 SSL.Unlock_Task.all;
1320 end Locked_Processing;
1339 Minute : Minute_Type;
1340 Second : Second_Type) return OS_Time
1342 procedure To_OS_Time
1343 (P_Time_T : Address; Year, Month, Day, Hours, Mins, Secs : Integer);
1344 pragma Import (C, To_OS_Time, "__gnat_to_os_time");
1348 (Result'Address, Year - 1900, Month - 1, Day, Hour, Minute, Second);
1356 function GM_Year (Date : OS_Time) return Year_Type is
1364 pragma Unreferenced (Mo, D, H, Mn, S);
1367 GM_Split (Date, Y, Mo, D, H, Mn, S);
1371 ----------------------
1372 -- Is_Absolute_Path --
1373 ----------------------
1375 function Is_Absolute_Path (Name : String) return Boolean is
1376 function Is_Absolute_Path
1378 Length : Integer) return Integer;
1379 pragma Import (C, Is_Absolute_Path, "__gnat_is_absolute_path");
1381 return Is_Absolute_Path (Name'Address, Name'Length) /= 0;
1382 end Is_Absolute_Path;
1388 function Is_Directory (Name : C_File_Name) return Boolean is
1389 function Is_Directory (Name : Address) return Integer;
1390 pragma Import (C, Is_Directory, "__gnat_is_directory");
1392 return Is_Directory (Name) /= 0;
1395 function Is_Directory (Name : String) return Boolean is
1396 F_Name : String (1 .. Name'Length + 1);
1398 F_Name (1 .. Name'Length) := Name;
1399 F_Name (F_Name'Last) := ASCII.NUL;
1400 return Is_Directory (F_Name'Address);
1403 ----------------------
1404 -- Is_Readable_File --
1405 ----------------------
1407 function Is_Readable_File (Name : C_File_Name) return Boolean is
1408 function Is_Readable_File (Name : Address) return Integer;
1409 pragma Import (C, Is_Readable_File, "__gnat_is_readable_file");
1411 return Is_Readable_File (Name) /= 0;
1412 end Is_Readable_File;
1414 function Is_Readable_File (Name : String) return Boolean is
1415 F_Name : String (1 .. Name'Length + 1);
1417 F_Name (1 .. Name'Length) := Name;
1418 F_Name (F_Name'Last) := ASCII.NUL;
1419 return Is_Readable_File (F_Name'Address);
1420 end Is_Readable_File;
1422 ------------------------
1423 -- Is_Executable_File --
1424 ------------------------
1426 function Is_Executable_File (Name : C_File_Name) return Boolean is
1427 function Is_Executable_File (Name : Address) return Integer;
1428 pragma Import (C, Is_Executable_File, "__gnat_is_executable_file");
1430 return Is_Executable_File (Name) /= 0;
1431 end Is_Executable_File;
1433 function Is_Executable_File (Name : String) return Boolean is
1434 F_Name : String (1 .. Name'Length + 1);
1436 F_Name (1 .. Name'Length) := Name;
1437 F_Name (F_Name'Last) := ASCII.NUL;
1438 return Is_Executable_File (F_Name'Address);
1439 end Is_Executable_File;
1441 ---------------------
1442 -- Is_Regular_File --
1443 ---------------------
1445 function Is_Regular_File (Name : C_File_Name) return Boolean is
1446 function Is_Regular_File (Name : Address) return Integer;
1447 pragma Import (C, Is_Regular_File, "__gnat_is_regular_file");
1449 return Is_Regular_File (Name) /= 0;
1450 end Is_Regular_File;
1452 function Is_Regular_File (Name : String) return Boolean is
1453 F_Name : String (1 .. Name'Length + 1);
1455 F_Name (1 .. Name'Length) := Name;
1456 F_Name (F_Name'Last) := ASCII.NUL;
1457 return Is_Regular_File (F_Name'Address);
1458 end Is_Regular_File;
1460 ----------------------
1461 -- Is_Symbolic_Link --
1462 ----------------------
1464 function Is_Symbolic_Link (Name : C_File_Name) return Boolean is
1465 function Is_Symbolic_Link (Name : Address) return Integer;
1466 pragma Import (C, Is_Symbolic_Link, "__gnat_is_symbolic_link");
1468 return Is_Symbolic_Link (Name) /= 0;
1469 end Is_Symbolic_Link;
1471 function Is_Symbolic_Link (Name : String) return Boolean is
1472 F_Name : String (1 .. Name'Length + 1);
1474 F_Name (1 .. Name'Length) := Name;
1475 F_Name (F_Name'Last) := ASCII.NUL;
1476 return Is_Symbolic_Link (F_Name'Address);
1477 end Is_Symbolic_Link;
1479 ----------------------
1480 -- Is_Writable_File --
1481 ----------------------
1483 function Is_Writable_File (Name : C_File_Name) return Boolean is
1484 function Is_Writable_File (Name : Address) return Integer;
1485 pragma Import (C, Is_Writable_File, "__gnat_is_writable_file");
1487 return Is_Writable_File (Name) /= 0;
1488 end Is_Writable_File;
1490 function Is_Writable_File (Name : String) return Boolean is
1491 F_Name : String (1 .. Name'Length + 1);
1493 F_Name (1 .. Name'Length) := Name;
1494 F_Name (F_Name'Last) := ASCII.NUL;
1495 return Is_Writable_File (F_Name'Address);
1496 end Is_Writable_File;
1498 -------------------------
1499 -- Locate_Exec_On_Path --
1500 -------------------------
1502 function Locate_Exec_On_Path
1503 (Exec_Name : String) return String_Access
1505 function Locate_Exec_On_Path (C_Exec_Name : Address) return Address;
1506 pragma Import (C, Locate_Exec_On_Path, "__gnat_locate_exec_on_path");
1508 C_Exec_Name : String (1 .. Exec_Name'Length + 1);
1509 Path_Addr : Address;
1511 Result : String_Access;
1514 C_Exec_Name (1 .. Exec_Name'Length) := Exec_Name;
1515 C_Exec_Name (C_Exec_Name'Last) := ASCII.NUL;
1517 Path_Addr := Locate_Exec_On_Path (C_Exec_Name'Address);
1518 Path_Len := C_String_Length (Path_Addr);
1520 if Path_Len = 0 then
1524 Result := To_Path_String_Access (Path_Addr, Path_Len);
1525 CRTL.free (Path_Addr);
1527 -- Always return an absolute path name
1529 if not Is_Absolute_Path (Result.all) then
1531 Absolute_Path : constant String :=
1532 Normalize_Pathname (Result.all, Resolve_Links => False);
1535 Result := new String'(Absolute_Path
);
1541 end Locate_Exec_On_Path
;
1543 -------------------------
1544 -- Locate_Regular_File --
1545 -------------------------
1547 function Locate_Regular_File
1548 (File_Name
: C_File_Name
;
1549 Path
: C_File_Name
) return String_Access
1551 function Locate_Regular_File
1552 (C_File_Name
, Path_Val
: Address
) return Address
;
1553 pragma Import
(C
, Locate_Regular_File
, "__gnat_locate_regular_file");
1555 Path_Addr
: Address
;
1557 Result
: String_Access
;
1560 Path_Addr
:= Locate_Regular_File
(File_Name
, Path
);
1561 Path_Len
:= C_String_Length
(Path_Addr
);
1563 if Path_Len
= 0 then
1567 Result
:= To_Path_String_Access
(Path_Addr
, Path_Len
);
1568 CRTL
.free
(Path_Addr
);
1571 end Locate_Regular_File
;
1573 function Locate_Regular_File
1574 (File_Name
: String;
1575 Path
: String) return String_Access
1577 C_File_Name
: String (1 .. File_Name
'Length + 1);
1578 C_Path
: String (1 .. Path
'Length + 1);
1579 Result
: String_Access
;
1582 C_File_Name
(1 .. File_Name
'Length) := File_Name
;
1583 C_File_Name
(C_File_Name
'Last) := ASCII
.NUL
;
1585 C_Path
(1 .. Path
'Length) := Path
;
1586 C_Path
(C_Path
'Last) := ASCII
.NUL
;
1588 Result
:= Locate_Regular_File
(C_File_Name
'Address, C_Path
'Address);
1590 -- Always return an absolute path name
1592 if Result
/= null and then not Is_Absolute_Path
(Result
.all) then
1594 Absolute_Path
: constant String := Normalize_Pathname
(Result
.all);
1597 Result
:= new String'(Absolute_Path);
1602 end Locate_Regular_File;
1604 ------------------------
1605 -- Non_Blocking_Spawn --
1606 ------------------------
1608 function Non_Blocking_Spawn
1609 (Program_Name : String;
1610 Args : Argument_List) return Process_Id
1614 pragma Warnings (Off, Junk);
1616 Spawn_Internal (Program_Name, Args, Junk, Pid, Blocking => False);
1618 end Non_Blocking_Spawn;
1620 function Non_Blocking_Spawn
1621 (Program_Name : String;
1622 Args : Argument_List;
1623 Output_File_Descriptor : File_Descriptor;
1624 Err_To_Out : Boolean := True) return Process_Id
1626 Saved_Output : File_Descriptor;
1627 Saved_Error : File_Descriptor := Invalid_FD; -- prevent warning
1631 if Output_File_Descriptor = Invalid_FD then
1635 -- Set standard output and, if specified, error to the temporary file
1637 Saved_Output := Dup (Standout);
1638 Dup2 (Output_File_Descriptor, Standout);
1641 Saved_Error := Dup (Standerr);
1642 Dup2 (Output_File_Descriptor, Standerr);
1645 -- Spawn the program
1647 Pid := Non_Blocking_Spawn (Program_Name, Args);
1649 -- Restore the standard output and error
1651 Dup2 (Saved_Output, Standout);
1654 Dup2 (Saved_Error, Standerr);
1657 -- And close the saved standard output and error file descriptors
1659 Close (Saved_Output);
1662 Close (Saved_Error);
1666 end Non_Blocking_Spawn;
1668 function Non_Blocking_Spawn
1669 (Program_Name : String;
1670 Args : Argument_List;
1671 Output_File : String;
1672 Err_To_Out : Boolean := True) return Process_Id
1674 Output_File_Descriptor : constant File_Descriptor :=
1675 Create_Output_Text_File (Output_File);
1676 Result : Process_Id;
1679 -- Do not attempt to spawn if the output file could not be created
1681 if Output_File_Descriptor = Invalid_FD then
1685 Result := Non_Blocking_Spawn
1686 (Program_Name, Args, Output_File_Descriptor, Err_To_Out);
1688 -- Close the file just created for the output, as the file descriptor
1689 -- cannot be used anywhere, being a local value. It is safe to do
1690 -- that, as the file descriptor has been duplicated to form
1691 -- standard output and error of the spawned process.
1693 Close (Output_File_Descriptor);
1697 end Non_Blocking_Spawn;
1699 -------------------------
1700 -- Normalize_Arguments --
1701 -------------------------
1703 procedure Normalize_Arguments (Args : in out Argument_List) is
1705 procedure Quote_Argument (Arg : in out String_Access);
1706 -- Add quote around argument if it contains spaces (or HT characters)
1708 C_Argument_Needs_Quote : Integer;
1709 pragma Import (C, C_Argument_Needs_Quote, "__gnat_argument_needs_quote");
1710 Argument_Needs_Quote : constant Boolean := C_Argument_Needs_Quote /= 0;
1712 --------------------
1713 -- Quote_Argument --
1714 --------------------
1716 procedure Quote_Argument (Arg : in out String_Access) is
1717 Res : String (1 .. Arg'Length * 2);
1719 Quote_Needed : Boolean := False;
1722 if Arg (Arg'First) /= '"' or else Arg (Arg'Last) /= '"' then
1728 for K in Arg'Range loop
1732 if Arg (K) = '"' then
1736 Quote_Needed := True;
1738 elsif Arg (K) = ' ' or else Arg (K) = ASCII.HT then
1740 Quote_Needed := True;
1747 if Quote_Needed then
1749 -- Case of null terminated string
1751 if Res (J) = ASCII.NUL then
1753 -- If the string ends with \, double it
1755 if Res (J - 1) = '\' then
1760 -- Put a quote just before the null at the end
1764 Res (J) := ASCII.NUL;
1766 -- If argument is terminated by '\
', then double it. Otherwise
1767 -- the ending quote will be taken as-is. This is quite strange
1768 -- spawn behavior from Windows, but this is what we see.
1771 if Res (J) = '\
' then
1783 Old : String_Access := Arg;
1786 Arg := new String'(Res (1 .. J));
1794 -- Start of processing for Normalize_Arguments
1797 if Argument_Needs_Quote then
1798 for K in Args'Range loop
1799 if Args (K) /= null and then Args (K)'Length /= 0 then
1800 Quote_Argument (Args (K));
1804 end Normalize_Arguments;
1806 ------------------------
1807 -- Normalize_Pathname --
1808 ------------------------
1810 function Normalize_Pathname
1812 Directory : String := "";
1813 Resolve_Links : Boolean := True;
1814 Case_Sensitive : Boolean := True) return String
1817 pragma Import (C, Max_Path, "__gnat_max_path_len
");
1818 -- Maximum length of a path name
1820 procedure Get_Current_Dir
1821 (Dir : System.Address;
1822 Length : System.Address);
1823 pragma Import (C, Get_Current_Dir, "__gnat_get_current_dir
");
1825 Path_Buffer : String (1 .. Max_Path + Max_Path + 2);
1826 End_Path : Natural := 0;
1827 Link_Buffer : String (1 .. Max_Path + 2);
1833 Max_Iterations : constant := 500;
1835 function Get_File_Names_Case_Sensitive return Integer;
1837 (C, Get_File_Names_Case_Sensitive,
1838 "__gnat_get_file_names_case_sensitive
");
1840 Fold_To_Lower_Case : constant Boolean :=
1842 and then Get_File_Names_Case_Sensitive = 0;
1845 (Path : System.Address;
1846 Buf : System.Address;
1847 Bufsiz : Integer) return Integer;
1848 pragma Import (C, Readlink, "__gnat_readlink
");
1850 function To_Canonical_File_Spec
1851 (Host_File : System.Address) return System.Address;
1853 (C, To_Canonical_File_Spec, "__gnat_to_canonical_file_spec
");
1855 The_Name : String (1 .. Name'Length + 1);
1856 Canonical_File_Addr : System.Address;
1857 Canonical_File_Len : Integer;
1859 function Final_Value (S : String) return String;
1860 -- Make final adjustment to the returned string. This function strips
1861 -- trailing directory separators, and folds returned string to lower
1862 -- case if required.
1864 function Get_Directory (Dir : String) return String;
1865 -- If Dir is not empty, return it, adding a directory separator
1866 -- if not already present, otherwise return current working directory
1867 -- with terminating directory separator.
1873 function Final_Value (S : String) return String is
1875 -- We may need to fold S to lower case, so we need a variable
1880 if Fold_To_Lower_Case then
1881 System.Case_Util.To_Lower (S1);
1884 -- Remove trailing directory separator, if any
1889 and then (S1 (Last) = '/'
1891 S1 (Last) = Directory_Separator)
1893 -- Special case for Windows: C:\
1896 and then S1 (1) /= Directory_Separator
1897 and then S1 (2) = ':'
1906 return S1 (1 .. Last);
1913 function Get_Directory (Dir : String) return String is
1914 Result : String (1 .. Dir'Length + 1);
1915 Length : constant Natural := Dir'Length;
1918 -- Directory given, add directory separator if needed
1921 Result (1 .. Length) := Dir;
1923 -- On Windows, change all '/' to '\'
1926 for J in 1 .. Length loop
1927 if Result (J) = '/' then
1928 Result (J) := Directory_Separator;
1933 -- Add directory separator, if needed
1935 if Result (Length) = Directory_Separator then
1936 return Result (1 .. Length);
1938 Result (Result'Length) := Directory_Separator;
1942 -- Directory name not given, get current directory
1946 Buffer : String (1 .. Max_Path + 2);
1947 Path_Len : Natural := Max_Path;
1950 Get_Current_Dir (Buffer'Address, Path_Len'Address);
1952 if Buffer (Path_Len) /= Directory_Separator then
1953 Path_Len := Path_Len + 1;
1954 Buffer (Path_Len) := Directory_Separator;
1957 -- By default, the drive letter on Windows is in upper case
1960 and then Path_Len >= 2
1961 and then Buffer (2) = ':'
1963 System.Case_Util.To_Upper (Buffer (1 .. 1));
1966 return Buffer (1 .. Path_Len);
1971 -- Start of processing for Normalize_Pathname
1974 -- Special case, return null if name is null, or if it is bigger than
1975 -- the biggest name allowed.
1977 if Name'Length = 0 or else Name'Length > Max_Path then
1981 -- First, convert VMS file spec to Unix file spec.
1982 -- If Name is not in VMS syntax, then this is equivalent
1983 -- to put Name at the beginning of Path_Buffer.
1985 VMS_Conversion : begin
1986 The_Name (1 .. Name'Length) := Name;
1987 The_Name (The_Name'Last) := ASCII.NUL;
1989 Canonical_File_Addr := To_Canonical_File_Spec (The_Name'Address);
1990 Canonical_File_Len := Integer (CRTL.strlen (Canonical_File_Addr));
1992 -- If VMS syntax conversion has failed, return an empty string
1993 -- to indicate the failure.
1995 if Canonical_File_Len = 0 then
2000 subtype Path_String is String (1 .. Canonical_File_Len);
2001 Canonical_File : Path_String;
2002 for Canonical_File'Address use Canonical_File_Addr;
2003 pragma Import (Ada, Canonical_File);
2006 Path_Buffer (1 .. Canonical_File_Len) := Canonical_File;
2007 End_Path := Canonical_File_Len;
2012 -- Replace all '/' by Directory Separators (this is for Windows)
2014 if Directory_Separator /= '/' then
2015 for Index in 1 .. End_Path loop
2016 if Path_Buffer (Index) = '/' then
2017 Path_Buffer (Index) := Directory_Separator;
2022 -- Resolve directory names for Windows
2026 -- On Windows, if we have an absolute path starting with a directory
2027 -- separator, we need to have the drive letter appended in front.
2029 -- On Windows, Get_Current_Dir will return a suitable directory name
2030 -- (path starting with a drive letter on Windows). So we take this
2031 -- drive letter and prepend it to the current path.
2033 if Path_Buffer (1) = Directory_Separator
2034 and then Path_Buffer (2) /= Directory_Separator
2037 Cur_Dir : constant String := Get_Directory ("");
2038 -- Get the current directory to get the drive letter
2041 if Cur_Dir'Length > 2
2042 and then Cur_Dir (Cur_Dir'First + 1) = ':'
2044 Path_Buffer (3 .. End_Path + 2) :=
2045 Path_Buffer (1 .. End_Path);
2046 Path_Buffer (1 .. 2) :=
2047 Cur_Dir (Cur_Dir'First .. Cur_Dir'First + 1);
2048 End_Path := End_Path + 2;
2052 -- We have a drive letter, ensure it is upper-case
2054 elsif Path_Buffer (1) in 'a' .. 'z'
2055 and then Path_Buffer (2) = ':'
2057 System.Case_Util.To_Upper (Path_Buffer (1 .. 1));
2061 -- On Windows, remove all double-quotes that are possibly part of the
2062 -- path but can cause problems with other methods.
2069 Index := Path_Buffer'First;
2070 for Current in Path_Buffer'First .. End_Path loop
2071 if Path_Buffer (Current) /= '"' then
2072 Path_Buffer (Index) := Path_Buffer (Current);
2077 End_Path := Index - 1;
2081 -- Start the conversions
2083 -- If this is not finished after Max_Iterations, give up and return an
2086 for J in 1 .. Max_Iterations loop
2088 -- If we don't have an absolute pathname, prepend the directory
2092 and then not Is_Absolute_Path (Path_Buffer (1 .. End_Path))
2095 Reference_Dir : constant String := Get_Directory (Directory);
2096 Ref_Dir_Len : constant Natural := Reference_Dir'Length;
2097 -- Current directory name specified and its length
2100 Path_Buffer (Ref_Dir_Len + 1 .. Ref_Dir_Len + End_Path) :=
2101 Path_Buffer (1 .. End_Path);
2102 End_Path := Ref_Dir_Len + End_Path;
2103 Path_Buffer (1 .. Ref_Dir_Len) := Reference_Dir;
2104 Last := Ref_Dir_Len;
2111 -- Ensure that Windows network drives are kept, e.g: \\server\drive-c
2114 and then Directory_Separator = '\
'
2115 and then Path_Buffer (1 .. 2) = "\\"
2120 -- If we have traversed the full pathname, return it
2122 if Start > End_Path then
2123 return Final_Value (Path_Buffer (1 .. End_Path));
2126 -- Remove duplicate directory separators
2128 while Path_Buffer (Start) = Directory_Separator loop
2129 if Start = End_Path then
2130 return Final_Value (Path_Buffer (1 .. End_Path - 1));
2133 Path_Buffer (Start .. End_Path - 1) :=
2134 Path_Buffer (Start + 1 .. End_Path);
2135 End_Path := End_Path - 1;
2139 -- Find the end of the current field: last character or the one
2140 -- preceding the next directory separator.
2142 while Finish < End_Path
2143 and then Path_Buffer (Finish + 1) /= Directory_Separator
2145 Finish := Finish + 1;
2150 if Start = Finish and then Path_Buffer (Start) = '.' then
2151 if Start = End_Path then
2153 return (1 => Directory_Separator);
2156 if Fold_To_Lower_Case then
2157 System.Case_Util.To_Lower (Path_Buffer (1 .. Last - 1));
2160 return Path_Buffer (1 .. Last - 1);
2165 Path_Buffer (Last + 1 .. End_Path - 2) :=
2166 Path_Buffer (Last + 3 .. End_Path);
2167 End_Path := End_Path - 2;
2170 -- Remove ".." fields
2172 elsif Finish = Start + 1
2173 and then Path_Buffer (Start .. Finish) = ".."
2179 or else Path_Buffer (Start) = Directory_Separator;
2183 if Finish = End_Path then
2184 return (1 => Directory_Separator);
2187 Path_Buffer (1 .. End_Path - Finish) :=
2188 Path_Buffer (Finish + 1 .. End_Path);
2189 End_Path := End_Path - Finish;
2194 if Finish = End_Path then
2195 return Final_Value (Path_Buffer (1 .. Start - 1));
2198 Path_Buffer (Start + 1 .. Start + End_Path - Finish - 1) :=
2199 Path_Buffer (Finish + 2 .. End_Path);
2200 End_Path := Start + End_Path - Finish - 1;
2205 -- Check if current field is a symbolic link
2207 elsif Resolve_Links then
2209 Saved : constant Character := Path_Buffer (Finish + 1);
2212 Path_Buffer (Finish + 1) := ASCII.NUL;
2213 Status := Readlink (Path_Buffer'Address,
2214 Link_Buffer'Address,
2215 Link_Buffer'Length);
2216 Path_Buffer (Finish + 1) := Saved;
2219 -- Not a symbolic link, move to the next field, if any
2224 -- Replace symbolic link with its value
2227 if Is_Absolute_Path (Link_Buffer (1 .. Status)) then
2228 Path_Buffer (Status + 1 .. End_Path - (Finish - Status)) :=
2229 Path_Buffer (Finish + 1 .. End_Path);
2230 End_Path := End_Path - (Finish - Status);
2231 Path_Buffer (1 .. Status) := Link_Buffer (1 .. Status);
2236 (Last + Status + 1 .. End_Path - Finish + Last + Status) :=
2237 Path_Buffer (Finish + 1 .. End_Path);
2238 End_Path := End_Path - Finish + Last + Status;
2239 Path_Buffer (Last + 1 .. Last + Status) :=
2240 Link_Buffer (1 .. Status);
2249 -- Too many iterations: give up
2251 -- This can happen when there is a circularity in the symbolic links: A
2252 -- is a symbolic link for B, which itself is a symbolic link, and the
2253 -- target of B or of another symbolic link target of B is A. In this
2254 -- case, we return an empty string to indicate failure to resolve.
2257 end Normalize_Pathname;
2264 (Name : C_File_Name;
2265 Fmode : Mode) return File_Descriptor
2267 function C_Open_Read
2268 (Name : C_File_Name;
2269 Fmode : Mode) return File_Descriptor;
2270 pragma Import (C, C_Open_Read, "__gnat_open_read");
2272 return C_Open_Read (Name, Fmode);
2277 Fmode : Mode) return File_Descriptor
2279 C_Name : String (1 .. Name'Length + 1);
2281 C_Name (1 .. Name'Length) := Name;
2282 C_Name (C_Name'Last) := ASCII.NUL;
2283 return Open_Read (C_Name (C_Name'First)'Address, Fmode);
2286 ---------------------
2287 -- Open_Read_Write --
2288 ---------------------
2290 function Open_Read_Write
2291 (Name : C_File_Name;
2292 Fmode : Mode) return File_Descriptor
2294 function C_Open_Read_Write
2295 (Name : C_File_Name;
2296 Fmode : Mode) return File_Descriptor;
2297 pragma Import (C, C_Open_Read_Write, "__gnat_open_rw");
2299 return C_Open_Read_Write (Name, Fmode);
2300 end Open_Read_Write;
2302 function Open_Read_Write
2304 Fmode : Mode) return File_Descriptor
2306 C_Name : String (1 .. Name'Length + 1);
2308 C_Name (1 .. Name'Length) := Name;
2309 C_Name (C_Name'Last) := ASCII.NUL;
2310 return Open_Read_Write (C_Name (C_Name'First)'Address, Fmode);
2311 end Open_Read_Write;
2317 procedure OS_Exit (Status : Integer) is
2319 OS_Exit_Ptr (Status);
2320 raise Program_Error;
2323 ---------------------
2324 -- OS_Exit_Default --
2325 ---------------------
2327 procedure OS_Exit_Default (Status : Integer) is
2328 procedure GNAT_OS_Exit (Status : Integer);
2329 pragma Import (C, GNAT_OS_Exit, "__gnat_os_exit");
2330 pragma No_Return (GNAT_OS_Exit);
2332 GNAT_OS_Exit (Status);
2333 end OS_Exit_Default;
2335 --------------------
2336 -- Pid_To_Integer --
2337 --------------------
2339 function Pid_To_Integer (Pid : Process_Id) return Integer is
2341 return Integer (Pid);
2349 (FD : File_Descriptor;
2351 N : Integer) return Integer
2355 Integer (System.CRTL.read
2356 (System.CRTL.int (FD),
2357 System.CRTL.chars (A),
2358 System.CRTL.size_t (N)));
2365 procedure Rename_File
2366 (Old_Name : C_File_Name;
2367 New_Name : C_File_Name;
2368 Success : out Boolean)
2370 function rename (From, To : Address) return Integer;
2371 pragma Import (C, rename, "__gnat_rename");
2374 R := rename (Old_Name, New_Name);
2378 procedure Rename_File
2381 Success : out Boolean)
2383 C_Old_Name : String (1 .. Old_Name'Length + 1);
2384 C_New_Name : String (1 .. New_Name'Length + 1);
2386 C_Old_Name (1 .. Old_Name'Length) := Old_Name;
2387 C_Old_Name (C_Old_Name'Last) := ASCII.NUL;
2388 C_New_Name (1 .. New_Name'Length) := New_Name;
2389 C_New_Name (C_New_Name'Last) := ASCII.NUL;
2390 Rename_File (C_Old_Name'Address, C_New_Name'Address, Success);
2393 -----------------------
2394 -- Set_Close_On_Exec --
2395 -----------------------
2397 procedure Set_Close_On_Exec
2398 (FD : File_Descriptor;
2399 Close_On_Exec : Boolean;
2400 Status : out Boolean)
2402 function C_Set_Close_On_Exec
2403 (FD : File_Descriptor; Close_On_Exec : System.CRTL.int)
2404 return System.CRTL.int;
2405 pragma Import (C, C_Set_Close_On_Exec, "__gnat_set_close_on_exec");
2407 Status := C_Set_Close_On_Exec (FD, Boolean'Pos (Close_On_Exec)) = 0;
2408 end Set_Close_On_Exec;
2410 --------------------
2411 -- Set_Executable --
2412 --------------------
2414 procedure Set_Executable (Name : String; Mode : Positive := S_Owner) is
2415 procedure C_Set_Executable (Name : C_File_Name; Mode : Integer);
2416 pragma Import (C, C_Set_Executable, "__gnat_set_executable");
2417 C_Name : aliased String (Name'First .. Name'Last + 1);
2419 C_Name (Name'Range) := Name;
2420 C_Name (C_Name'Last) := ASCII.NUL;
2421 C_Set_Executable (C_Name (C_Name'First)'Address, Mode);
2424 -------------------------------------
2425 -- Set_File_Last_Modify_Time_Stamp --
2426 -------------------------------------
2428 procedure Set_File_Last_Modify_Time_Stamp (Name : String; Time : OS_Time) is
2429 procedure C_Set_File_Time (Name : C_File_Name; Time : OS_Time);
2430 pragma Import (C, C_Set_File_Time, "__gnat_set_file_time_name");
2431 C_Name : aliased String (Name'First .. Name'Last + 1);
2433 C_Name (Name'Range) := Name;
2434 C_Name (C_Name'Last) := ASCII.NUL;
2435 C_Set_File_Time (C_Name'Address, Time);
2436 end Set_File_Last_Modify_Time_Stamp;
2438 ----------------------
2439 -- Set_Non_Readable --
2440 ----------------------
2442 procedure Set_Non_Readable (Name : String) is
2443 procedure C_Set_Non_Readable (Name : C_File_Name);
2444 pragma Import (C, C_Set_Non_Readable, "__gnat_set_non_readable");
2445 C_Name : aliased String (Name'First .. Name'Last + 1);
2447 C_Name (Name'Range) := Name;
2448 C_Name (C_Name'Last) := ASCII.NUL;
2449 C_Set_Non_Readable (C_Name (C_Name'First)'Address);
2450 end Set_Non_Readable;
2452 ----------------------
2453 -- Set_Non_Writable --
2454 ----------------------
2456 procedure Set_Non_Writable (Name : String) is
2457 procedure C_Set_Non_Writable (Name : C_File_Name);
2458 pragma Import (C, C_Set_Non_Writable, "__gnat_set_non_writable");
2459 C_Name : aliased String (Name'First .. Name'Last + 1);
2461 C_Name (Name'Range) := Name;
2462 C_Name (C_Name'Last) := ASCII.NUL;
2463 C_Set_Non_Writable (C_Name (C_Name'First)'Address);
2464 end Set_Non_Writable;
2470 procedure Set_Readable (Name : String) is
2471 procedure C_Set_Readable (Name : C_File_Name);
2472 pragma Import (C, C_Set_Readable, "__gnat_set_readable");
2473 C_Name : aliased String (Name'First .. Name'Last + 1);
2475 C_Name (Name'Range) := Name;
2476 C_Name (C_Name'Last) := ASCII.NUL;
2477 C_Set_Readable (C_Name (C_Name'First)'Address);
2480 --------------------
2482 --------------------
2484 procedure Set_Writable (Name : String) is
2485 procedure C_Set_Writable (Name : C_File_Name);
2486 pragma Import (C, C_Set_Writable, "__gnat_set_writable");
2487 C_Name : aliased String (Name'First .. Name'Last + 1);
2489 C_Name (Name'Range) := Name;
2490 C_Name (C_Name'Last) := ASCII.NUL;
2491 C_Set_Writable (C_Name (C_Name'First)'Address);
2498 procedure Setenv (Name : String; Value : String) is
2499 F_Name : String (1 .. Name'Length + 1);
2500 F_Value : String (1 .. Value'Length + 1);
2502 procedure Set_Env_Value (Name, Value : System.Address);
2503 pragma Import (C, Set_Env_Value, "__gnat_setenv");
2506 F_Name (1 .. Name'Length) := Name;
2507 F_Name (F_Name'Last) := ASCII.NUL;
2509 F_Value (1 .. Value'Length) := Value;
2510 F_Value (F_Value'Last) := ASCII.NUL;
2512 Set_Env_Value (F_Name'Address, F_Value'Address);
2520 (Program_Name : String;
2521 Args : Argument_List) return Integer
2525 pragma Warnings (Off, Junk);
2527 Spawn_Internal (Program_Name, Args, Result, Junk, Blocking => True);
2532 (Program_Name : String;
2533 Args : Argument_List;
2534 Success : out Boolean)
2537 Success := (Spawn (Program_Name, Args) = 0);
2541 (Program_Name : String;
2542 Args : Argument_List;
2543 Output_File_Descriptor : File_Descriptor;
2544 Return_Code : out Integer;
2545 Err_To_Out : Boolean := True)
2547 Saved_Output : File_Descriptor;
2548 Saved_Error : File_Descriptor := Invalid_FD; -- prevent compiler warning
2551 -- Set standard output and error to the temporary file
2553 Saved_Output := Dup (Standout);
2554 Dup2 (Output_File_Descriptor, Standout);
2557 Saved_Error := Dup (Standerr);
2558 Dup2 (Output_File_Descriptor, Standerr);
2561 -- Spawn the program
2563 Return_Code := Spawn (Program_Name, Args);
2565 -- Restore the standard output and error
2567 Dup2 (Saved_Output, Standout);
2570 Dup2 (Saved_Error, Standerr);
2573 -- And close the saved standard output and error file descriptors
2575 Close (Saved_Output);
2578 Close (Saved_Error);
2583 (Program_Name : String;
2584 Args : Argument_List;
2585 Output_File : String;
2586 Success : out Boolean;
2587 Return_Code : out Integer;
2588 Err_To_Out : Boolean := True)
2590 FD : File_Descriptor;
2596 FD := Create_Output_Text_File (Output_File);
2598 if FD = Invalid_FD then
2603 Spawn (Program_Name, Args, FD, Return_Code, Err_To_Out);
2605 Close (FD, Success);
2608 --------------------
2609 -- Spawn_Internal --
2610 --------------------
2612 procedure Spawn_Internal
2613 (Program_Name : String;
2614 Args : Argument_List;
2615 Result : out Integer;
2616 Pid : out Process_Id;
2620 procedure Spawn (Args : Argument_List);
2621 -- Call Spawn with given argument list
2623 N_Args : Argument_List (Args'Range);
2624 -- Normalized arguments
2630 procedure Spawn (Args : Argument_List) is
2631 type Chars is array (Positive range <>) of aliased Character;
2632 type Char_Ptr is access constant Character;
2634 Command_Len : constant Positive := Program_Name'Length + 1
2635 + Args_Length (Args);
2636 Command_Last : Natural := 0;
2637 Command : aliased Chars (1 .. Command_Len);
2638 -- Command contains all characters of the Program_Name and Args, all
2639 -- terminated by ASCII.NUL characters.
2641 Arg_List_Len : constant Positive := Args'Length + 2;
2642 Arg_List_Last : Natural := 0;
2643 Arg_List : aliased array (1 .. Arg_List_Len) of Char_Ptr;
2644 -- List with pointers to NUL-terminated strings of the Program_Name
2645 -- and the Args and terminated with a null pointer. We rely on the
2646 -- default initialization for the last null pointer.
2648 procedure Add_To_Command (S : String);
2649 -- Add S and a NUL character to Command, updating Last
2651 function Portable_Spawn (Args : Address) return Integer;
2652 pragma Import (C, Portable_Spawn, "__gnat_portable_spawn");
2654 function Portable_No_Block_Spawn (Args : Address) return Process_Id;
2656 (C, Portable_No_Block_Spawn, "__gnat_portable_no_block_spawn");
2658 --------------------
2659 -- Add_To_Command --
2660 --------------------
2662 procedure Add_To_Command (S : String) is
2663 First : constant Natural := Command_Last + 1;
2666 Command_Last := Command_Last + S'Length;
2668 -- Move characters one at a time, because Command has aliased
2671 -- But not volatile, so why is this necessary ???
2673 for J in S'Range loop
2674 Command (First + J - S'First) := S (J);
2677 Command_Last := Command_Last + 1;
2678 Command (Command_Last) := ASCII.NUL;
2680 Arg_List_Last := Arg_List_Last + 1;
2681 Arg_List (Arg_List_Last) := Command (First)'Access;
2684 -- Start of processing for Spawn
2687 Add_To_Command (Program_Name);
2689 for J in Args'Range loop
2690 Add_To_Command (Args (J).all);
2695 Result := Portable_Spawn (Arg_List'Address);
2697 Pid := Portable_No_Block_Spawn (Arg_List'Address);
2698 Result := Boolean'Pos (Pid /= Invalid_Pid);
2702 -- Start of processing for Spawn_Internal
2705 -- Copy arguments into a local structure
2707 for K in N_Args'Range loop
2708 N_Args (K) := new String'(Args
(K
).all);
2711 -- Normalize those arguments
2713 Normalize_Arguments
(N_Args
);
2715 -- Call spawn using the normalized arguments
2719 -- Free arguments list
2721 for K
in N_Args
'Range loop
2726 ---------------------------
2727 -- To_Path_String_Access --
2728 ---------------------------
2730 function To_Path_String_Access
2731 (Path_Addr
: Address
;
2732 Path_Len
: Integer) return String_Access
2734 subtype Path_String
is String (1 .. Path_Len
);
2735 type Path_String_Access
is access Path_String
;
2737 function Address_To_Access
is new Ada
.Unchecked_Conversion
2738 (Source
=> Address
, Target
=> Path_String_Access
);
2740 Path_Access
: constant Path_String_Access
:=
2741 Address_To_Access
(Path_Addr
);
2743 Return_Val
: String_Access
;
2746 Return_Val
:= new String (1 .. Path_Len
);
2748 for J
in 1 .. Path_Len
loop
2749 Return_Val
(J
) := Path_Access
(J
);
2753 end To_Path_String_Access
;
2759 procedure Wait_Process
(Pid
: out Process_Id
; Success
: out Boolean) is
2762 function Portable_Wait
(S
: Address
) return Process_Id
;
2763 pragma Import
(C
, Portable_Wait
, "__gnat_portable_wait");
2766 Pid
:= Portable_Wait
(Status
'Address);
2767 Success
:= (Status
= 0);
2775 (FD
: File_Descriptor
;
2777 N
: Integer) return Integer
2781 Integer (System
.CRTL
.write
2782 (System
.CRTL
.int
(FD
),
2783 System
.CRTL
.chars
(A
),
2784 System
.CRTL
.size_t
(N
)));