1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
5 -- S Y S T E M . O S _ L I B --
9 -- Copyright (C) 1995-2008, 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 2, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- As a special exception, if other files instantiate generics from this --
23 -- unit, or you link this unit with other files to produce an executable, --
24 -- this unit does not by itself cause the resulting executable to be --
25 -- covered by the GNU General Public License. This exception does not --
26 -- however invalidate any other reasons why the executable file might be --
27 -- covered by the GNU Public License. --
29 -- GNAT was originally developed by the GNAT team at New York University. --
30 -- Extensive contributions were provided by Ada Core Technologies Inc. --
32 ------------------------------------------------------------------------------
34 pragma Warnings
(Off
);
38 with System
.Case_Util
;
40 with System
.Soft_Links
;
41 with Ada
.Unchecked_Conversion
;
42 with Ada
.Unchecked_Deallocation
;
43 with System
; use System
;
45 package body System
.OS_Lib
is
47 -- Imported procedures Dup and Dup2 are used in procedures Spawn and
48 -- Non_Blocking_Spawn.
50 function Dup
(Fd
: File_Descriptor
) return File_Descriptor
;
51 pragma Import
(C
, Dup
, "__gnat_dup");
53 procedure Dup2
(Old_Fd
, New_Fd
: File_Descriptor
);
54 pragma Import
(C
, Dup2
, "__gnat_dup2");
56 On_Windows
: constant Boolean := Directory_Separator
= '\';
57 -- An indication that we are on Windows. Used in Normalize_Pathname, to
58 -- deal with drive letters in the beginning of absolute paths.
60 package SSL
renames System
.Soft_Links
;
62 -- The following are used by Create_Temp_File
64 First_Temp_File_Name
: constant String := "GNAT-TEMP-000000.TMP";
65 -- Used to initialize Current_Temp_File_Name and Temp_File_Name_Last_Digit
67 Current_Temp_File_Name
: String := First_Temp_File_Name
;
68 -- Name of the temp file last created
70 Temp_File_Name_Last_Digit
: constant Positive :=
71 First_Temp_File_Name
'Last - 4;
72 -- Position of the last digit in Current_Temp_File_Name
74 Max_Attempts
: constant := 100;
75 -- The maximum number of attempts to create a new temp file
77 -----------------------
78 -- Local Subprograms --
79 -----------------------
81 function Args_Length
(Args
: Argument_List
) return Natural;
82 -- Returns total number of characters needed to create a string
83 -- of all Args terminated by ASCII.NUL characters
85 function C_String_Length
(S
: Address
) return Integer;
86 -- Returns the length of a C string. Does check for null address
89 procedure Spawn_Internal
90 (Program_Name
: String;
95 -- Internal routine to implement the two Spawn (blocking/non blocking)
96 -- routines. If Blocking is set to True then the spawn is blocking
97 -- otherwise it is non blocking. In this latter case the Pid contains the
98 -- process id number. The first three parameters are as in Spawn. Note that
99 -- Spawn_Internal normalizes the argument list before calling the low level
100 -- system spawn routines (see Normalize_Arguments).
102 -- Note: Normalize_Arguments is designed to do nothing if it is called more
103 -- than once, so calling Normalize_Arguments before calling one of the
104 -- spawn routines is fine.
106 function To_Path_String_Access
107 (Path_Addr
: Address
;
108 Path_Len
: Integer) return String_Access
;
109 -- Converts a C String to an Ada String. We could do this making use of
110 -- Interfaces.C.Strings but we prefer not to import that entire package
116 function "<" (X
, Y
: OS_Time
) return Boolean is
118 return Long_Integer (X
) < Long_Integer (Y
);
125 function "<=" (X
, Y
: OS_Time
) return Boolean is
127 return Long_Integer (X
) <= Long_Integer (Y
);
134 function ">" (X
, Y
: OS_Time
) return Boolean is
136 return Long_Integer (X
) > Long_Integer (Y
);
143 function ">=" (X
, Y
: OS_Time
) return Boolean is
145 return Long_Integer (X
) >= Long_Integer (Y
);
152 function Args_Length
(Args
: Argument_List
) return Natural is
156 for J
in Args
'Range loop
157 Len
:= Len
+ Args
(J
)'Length + 1; -- One extra for ASCII.NUL
163 -----------------------------
164 -- Argument_String_To_List --
165 -----------------------------
167 function Argument_String_To_List
168 (Arg_String
: String) return Argument_List_Access
170 Max_Args
: constant Integer := Arg_String
'Length;
171 New_Argv
: Argument_List
(1 .. Max_Args
);
172 New_Argc
: Natural := 0;
176 Idx
:= Arg_String
'First;
179 exit when Idx
> Arg_String
'Last;
182 Quoted
: Boolean := False;
183 Backqd
: Boolean := False;
190 -- An unquoted space is the end of an argument
192 if not (Backqd
or Quoted
)
193 and then Arg_String
(Idx
) = ' '
197 -- Start of a quoted string
199 elsif not (Backqd
or Quoted
)
200 and then Arg_String
(Idx
) = '"'
204 -- End of a quoted string and end of an argument
206 elsif (Quoted
and not Backqd
)
207 and then Arg_String
(Idx
) = '"'
212 -- Following character is backquoted
214 elsif Arg_String
(Idx
) = '\' then
217 -- Turn off backquoting after advancing one character
225 exit when Idx
> Arg_String
'Last;
230 New_Argc
:= New_Argc
+ 1;
231 New_Argv
(New_Argc
) :=
232 new String'(Arg_String (Old_Idx .. Idx - 1));
234 -- Skip extraneous spaces
236 while Idx <= Arg_String'Last and then Arg_String (Idx) = ' ' loop
242 return new Argument_List'(New_Argv
(1 .. New_Argc
));
243 end Argument_String_To_List
;
245 ---------------------
246 -- C_String_Length --
247 ---------------------
249 function C_String_Length
(S
: Address
) return Integer is
250 function Strlen
(S
: Address
) return Integer;
251 pragma Import
(C
, Strlen
, "strlen");
253 if S
= Null_Address
then
264 procedure Close
(FD
: File_Descriptor
) is
265 procedure C_Close
(FD
: File_Descriptor
);
266 pragma Import
(C
, C_Close
, "close");
271 procedure Close
(FD
: File_Descriptor
; Status
: out Boolean) is
272 function C_Close
(FD
: File_Descriptor
) return Integer;
273 pragma Import
(C
, C_Close
, "close");
275 Status
:= (C_Close
(FD
) = 0);
285 Success
: out Boolean;
286 Mode
: Copy_Mode
:= Copy
;
287 Preserve
: Attribute
:= Time_Stamps
)
289 From
: File_Descriptor
;
290 To
: File_Descriptor
;
292 Copy_Error
: exception;
293 -- Internal exception raised to signal error in copy
295 function Build_Path
(Dir
: String; File
: String) return String;
296 -- Returns pathname Dir concatenated with File adding the directory
297 -- separator only if needed.
299 procedure Copy
(From
, To
: File_Descriptor
);
300 -- Read data from From and place them into To. In both cases the
301 -- operations uses the current file position. Raises Constraint_Error
302 -- if a problem occurs during the copy.
304 procedure Copy_To
(To_Name
: String);
305 -- Does a straight copy from source to designated destination file
311 function Build_Path
(Dir
: String; File
: String) return String is
312 Res
: String (1 .. Dir
'Length + File
'Length + 1);
314 Base_File_Ptr
: Integer;
315 -- The base file name is File (Base_File_Ptr + 1 .. File'Last)
317 function Is_Dirsep
(C
: Character) return Boolean;
318 pragma Inline
(Is_Dirsep
);
319 -- Returns True if C is a directory separator. On Windows we
320 -- handle both styles of directory separator.
326 function Is_Dirsep
(C
: Character) return Boolean is
328 return C
= Directory_Separator
or else C
= '/';
331 -- Start of processing for Build_Path
334 -- Find base file name
336 Base_File_Ptr
:= File
'Last;
337 while Base_File_Ptr
>= File
'First loop
338 exit when Is_Dirsep
(File
(Base_File_Ptr
));
339 Base_File_Ptr
:= Base_File_Ptr
- 1;
343 Base_File
: String renames
344 File
(Base_File_Ptr
+ 1 .. File
'Last);
347 Res
(1 .. Dir
'Length) := Dir
;
349 if Is_Dirsep
(Dir
(Dir
'Last)) then
350 Res
(Dir
'Length + 1 .. Dir
'Length + Base_File
'Length) :=
352 return Res
(1 .. Dir
'Length + Base_File
'Length);
355 Res
(Dir
'Length + 1) := Directory_Separator
;
356 Res
(Dir
'Length + 2 .. Dir
'Length + 1 + Base_File
'Length) :=
358 return Res
(1 .. Dir
'Length + 1 + Base_File
'Length);
367 procedure Copy
(From
, To
: File_Descriptor
) is
368 Buf_Size
: constant := 200_000
;
369 type Buf
is array (1 .. Buf_Size
) of Character;
370 type Buf_Ptr
is access Buf
;
376 Status_From
: Boolean;
378 -- Statuses for the calls to Close
380 procedure Free
is new Ada
.Unchecked_Deallocation
(Buf
, Buf_Ptr
);
383 -- Check for invalid descriptors, making sure that we do not
384 -- accidentally leave an open file descriptor around.
386 if From
= Invalid_FD
then
387 if To
/= Invalid_FD
then
388 Close
(To
, Status_To
);
393 elsif To
= Invalid_FD
then
394 Close
(From
, Status_From
);
398 -- Allocate the buffer on the heap
403 R
:= Read
(From
, Buffer
(1)'Address, Buf_Size
);
405 -- For VMS, the buffer may not be full. So, we need to try again
406 -- until there is nothing to read.
410 W
:= Write
(To
, Buffer
(1)'Address, R
);
414 -- Problem writing data, could be a disk full. Close files
415 -- without worrying about status, since we are raising a
416 -- Copy_Error exception in any case.
418 Close
(From
, Status_From
);
419 Close
(To
, Status_To
);
427 Close
(From
, Status_From
);
428 Close
(To
, Status_To
);
432 if not (Status_From
and Status_To
) then
441 procedure Copy_To
(To_Name
: String) is
443 function Copy_Attributes
444 (From
, To
: System
.Address
;
445 Mode
: Integer) return Integer;
446 pragma Import
(C
, Copy_Attributes
, "__gnat_copy_attribs");
447 -- Mode = 0 - copy only time stamps.
448 -- Mode = 1 - copy time stamps and read/write/execute attributes
450 C_From
: String (1 .. Name
'Length + 1);
451 C_To
: String (1 .. To_Name
'Length + 1);
454 From
:= Open_Read
(Name
, Binary
);
456 -- Do not clobber destination file if source file could not be opened
458 if From
/= Invalid_FD
then
459 To
:= Create_File
(To_Name
, Binary
);
466 C_From
(1 .. Name
'Length) := Name
;
467 C_From
(C_From
'Last) := ASCII
.NUL
;
469 C_To
(1 .. To_Name
'Length) := To_Name
;
470 C_To
(C_To
'Last) := ASCII
.NUL
;
475 if Copy_Attributes
(C_From
'Address, C_To
'Address, 0) = -1 then
480 if Copy_Attributes
(C_From
'Address, C_To
'Address, 1) = -1 then
490 -- Start of processing for Copy_File
495 -- The source file must exist
497 if not Is_Regular_File
(Name
) then
501 -- The source file exists
505 -- Copy case, target file must not exist
509 -- If the target file exists, we have an error
511 if Is_Regular_File
(Pathname
) then
514 -- Case of target is a directory
516 elsif Is_Directory
(Pathname
) then
518 Dest
: constant String := Build_Path
(Pathname
, Name
);
521 -- If target file exists, we have an error, else do copy
523 if Is_Regular_File
(Dest
) then
530 -- Case of normal copy to file (destination does not exist)
536 -- Overwrite case (destination file may or may not exist)
539 if Is_Directory
(Pathname
) then
540 Copy_To
(Build_Path
(Pathname
, Name
));
545 -- Append case (destination file may or may not exist)
549 -- Appending to existing file
551 if Is_Regular_File
(Pathname
) then
553 -- Append mode and destination file exists, append data at the
554 -- end of Pathname. But if we fail to open source file, do not
555 -- touch destination file at all.
557 From
:= Open_Read
(Name
, Binary
);
558 if From
/= Invalid_FD
then
559 To
:= Open_Read_Write
(Pathname
, Binary
);
562 Lseek
(To
, 0, Seek_End
);
566 -- Appending to directory, not allowed
568 elsif Is_Directory
(Pathname
) then
571 -- Appending when target file does not exist
578 -- All error cases are caught here
587 Pathname
: C_File_Name
;
588 Success
: out Boolean;
589 Mode
: Copy_Mode
:= Copy
;
590 Preserve
: Attribute
:= Time_Stamps
)
592 Ada_Name
: String_Access
:=
593 To_Path_String_Access
594 (Name
, C_String_Length
(Name
));
596 Ada_Pathname
: String_Access
:=
597 To_Path_String_Access
598 (Pathname
, C_String_Length
(Pathname
));
601 Copy_File
(Ada_Name
.all, Ada_Pathname
.all, Success
, Mode
, Preserve
);
606 ----------------------
607 -- Copy_Time_Stamps --
608 ----------------------
610 procedure Copy_Time_Stamps
(Source
, Dest
: String; Success
: out Boolean) is
612 function Copy_Attributes
613 (From
, To
: System
.Address
;
614 Mode
: Integer) return Integer;
615 pragma Import
(C
, Copy_Attributes
, "__gnat_copy_attribs");
616 -- Mode = 0 - copy only time stamps.
617 -- Mode = 1 - copy time stamps and read/write/execute attributes
620 if Is_Regular_File
(Source
) and then Is_Writable_File
(Dest
) then
622 C_Source
: String (1 .. Source
'Length + 1);
623 C_Dest
: String (1 .. Dest
'Length + 1);
625 C_Source
(1 .. Source
'Length) := Source
;
626 C_Source
(C_Source
'Last) := ASCII
.NUL
;
628 C_Dest
(1 .. Dest
'Length) := Dest
;
629 C_Dest
(C_Dest
'Last) := ASCII
.NUL
;
631 if Copy_Attributes
(C_Source
'Address, C_Dest
'Address, 0) = -1 then
641 end Copy_Time_Stamps
;
643 procedure Copy_Time_Stamps
644 (Source
, Dest
: C_File_Name
;
645 Success
: out Boolean)
647 Ada_Source
: String_Access
:=
648 To_Path_String_Access
649 (Source
, C_String_Length
(Source
));
651 Ada_Dest
: String_Access
:=
652 To_Path_String_Access
653 (Dest
, C_String_Length
(Dest
));
655 Copy_Time_Stamps
(Ada_Source
.all, Ada_Dest
.all, Success
);
658 end Copy_Time_Stamps
;
666 Fmode
: Mode
) return File_Descriptor
668 function C_Create_File
670 Fmode
: Mode
) return File_Descriptor
;
671 pragma Import
(C
, C_Create_File
, "__gnat_open_create");
674 return C_Create_File
(Name
, Fmode
);
679 Fmode
: Mode
) return File_Descriptor
681 C_Name
: String (1 .. Name
'Length + 1);
684 C_Name
(1 .. Name
'Length) := Name
;
685 C_Name
(C_Name
'Last) := ASCII
.NUL
;
686 return Create_File
(C_Name
(C_Name
'First)'Address, Fmode
);
689 ---------------------
690 -- Create_New_File --
691 ---------------------
693 function Create_New_File
695 Fmode
: Mode
) return File_Descriptor
697 function C_Create_New_File
699 Fmode
: Mode
) return File_Descriptor
;
700 pragma Import
(C
, C_Create_New_File
, "__gnat_open_new");
703 return C_Create_New_File
(Name
, Fmode
);
706 function Create_New_File
708 Fmode
: Mode
) return File_Descriptor
710 C_Name
: String (1 .. Name
'Length + 1);
713 C_Name
(1 .. Name
'Length) := Name
;
714 C_Name
(C_Name
'Last) := ASCII
.NUL
;
715 return Create_New_File
(C_Name
(C_Name
'First)'Address, Fmode
);
718 -----------------------------
719 -- Create_Output_Text_File --
720 -----------------------------
722 function Create_Output_Text_File
(Name
: String) return File_Descriptor
is
723 function C_Create_File
724 (Name
: C_File_Name
) return File_Descriptor
;
725 pragma Import
(C
, C_Create_File
, "__gnat_create_output_file");
727 C_Name
: String (1 .. Name
'Length + 1);
730 C_Name
(1 .. Name
'Length) := Name
;
731 C_Name
(C_Name
'Last) := ASCII
.NUL
;
732 return C_Create_File
(C_Name
(C_Name
'First)'Address);
733 end Create_Output_Text_File
;
735 ----------------------
736 -- Create_Temp_File --
737 ----------------------
739 procedure Create_Temp_File
740 (FD
: out File_Descriptor
;
741 Name
: out Temp_File_Name
)
743 function Open_New_Temp
744 (Name
: System
.Address
;
745 Fmode
: Mode
) return File_Descriptor
;
746 pragma Import
(C
, Open_New_Temp
, "__gnat_open_new_temp");
749 FD
:= Open_New_Temp
(Name
'Address, Binary
);
750 end Create_Temp_File
;
752 procedure Create_Temp_File
753 (FD
: out File_Descriptor
;
754 Name
: out String_Access
)
757 Attempts
: Natural := 0;
758 Current
: String (Current_Temp_File_Name
'Range);
761 -- Loop until a new temp file can be created
765 -- We need to protect global variable Current_Temp_File_Name
766 -- against concurrent access by different tasks.
770 -- Start at the last digit
772 Pos
:= Temp_File_Name_Last_Digit
;
776 -- Increment the digit by one
778 case Current_Temp_File_Name
(Pos
) is
780 Current_Temp_File_Name
(Pos
) :=
781 Character'Succ (Current_Temp_File_Name
(Pos
));
786 -- For 9, set the digit to 0 and go to the previous digit
788 Current_Temp_File_Name
(Pos
) := '0';
793 -- If it is not a digit, then there are no available
794 -- temp file names. Return Invalid_FD. There is almost
795 -- no that this code will be ever be executed, since
796 -- it would mean that there are one million temp files
797 -- in the same directory!
806 Current
:= Current_Temp_File_Name
;
808 -- We can now release the lock, because we are no longer
809 -- accessing Current_Temp_File_Name.
819 -- Attempt to create the file
821 FD
:= Create_New_File
(Current
, Binary
);
823 if FD
/= Invalid_FD
then
824 Name
:= new String'(Current);
828 if not Is_Regular_File (Current) then
830 -- If the file does not already exist and we are unable to create
831 -- it, we give up after Max_Attempts. Otherwise, we try again with
832 -- the next available file name.
834 Attempts := Attempts + 1;
836 if Attempts >= Max_Attempts then
843 end Create_Temp_File;
849 procedure Delete_File (Name : Address; Success : out Boolean) is
852 function unlink (A : Address) return Integer;
853 pragma Import (C, unlink, "unlink");
860 procedure Delete_File (Name : String; Success : out Boolean) is
861 C_Name : String (1 .. Name'Length + 1);
864 C_Name (1 .. Name'Length) := Name;
865 C_Name (C_Name'Last) := ASCII.NUL;
867 Delete_File (C_Name'Address, Success);
870 ---------------------
871 -- File_Time_Stamp --
872 ---------------------
874 function File_Time_Stamp (FD : File_Descriptor) return OS_Time is
875 function File_Time (FD : File_Descriptor) return OS_Time;
876 pragma Import (C, File_Time, "__gnat_file_time_fd");
878 return File_Time (FD);
881 function File_Time_Stamp (Name : C_File_Name) return OS_Time is
882 function File_Time (Name : Address) return OS_Time;
883 pragma Import (C, File_Time, "__gnat_file_time_name");
885 return File_Time (Name);
888 function File_Time_Stamp (Name : String) return OS_Time is
889 F_Name : String (1 .. Name'Length + 1);
891 F_Name (1 .. Name'Length) := Name;
892 F_Name (F_Name'Last) := ASCII.NUL;
893 return File_Time_Stamp (F_Name'Address);
896 ---------------------------
897 -- Get_Debuggable_Suffix --
898 ---------------------------
900 function Get_Debuggable_Suffix return String_Access is
901 procedure Get_Suffix_Ptr (Length, Ptr : Address);
902 pragma Import (C, Get_Suffix_Ptr, "__gnat_get_debuggable_suffix_ptr");
904 procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
905 pragma Import (C, Strncpy, "strncpy");
907 Suffix_Ptr : Address;
908 Suffix_Length : Integer;
909 Result : String_Access;
912 Get_Suffix_Ptr (Suffix_Length'Address, Suffix_Ptr'Address);
914 Result := new String (1 .. Suffix_Length);
916 if Suffix_Length > 0 then
917 Strncpy (Result.all'Address, Suffix_Ptr, Suffix_Length);
921 end Get_Debuggable_Suffix;
923 ---------------------------
924 -- Get_Executable_Suffix --
925 ---------------------------
927 function Get_Executable_Suffix return String_Access is
928 procedure Get_Suffix_Ptr (Length, Ptr : Address);
929 pragma Import (C, Get_Suffix_Ptr, "__gnat_get_executable_suffix_ptr");
931 procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
932 pragma Import (C, Strncpy, "strncpy");
934 Suffix_Ptr : Address;
935 Suffix_Length : Integer;
936 Result : String_Access;
939 Get_Suffix_Ptr (Suffix_Length'Address, Suffix_Ptr'Address);
941 Result := new String (1 .. Suffix_Length);
943 if Suffix_Length > 0 then
944 Strncpy (Result.all'Address, Suffix_Ptr, Suffix_Length);
948 end Get_Executable_Suffix;
950 -----------------------
951 -- Get_Object_Suffix --
952 -----------------------
954 function Get_Object_Suffix return String_Access is
955 procedure Get_Suffix_Ptr (Length, Ptr : Address);
956 pragma Import (C, Get_Suffix_Ptr, "__gnat_get_object_suffix_ptr");
958 procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
959 pragma Import (C, Strncpy, "strncpy");
961 Suffix_Ptr : Address;
962 Suffix_Length : Integer;
963 Result : String_Access;
966 Get_Suffix_Ptr (Suffix_Length'Address, Suffix_Ptr'Address);
968 Result := new String (1 .. Suffix_Length);
970 if Suffix_Length > 0 then
971 Strncpy (Result.all'Address, Suffix_Ptr, Suffix_Length);
975 end Get_Object_Suffix;
977 ----------------------------------
978 -- Get_Target_Debuggable_Suffix --
979 ----------------------------------
981 function Get_Target_Debuggable_Suffix return String_Access is
982 Target_Exec_Ext_Ptr : Address;
984 (C, Target_Exec_Ext_Ptr, "__gnat_target_debuggable_extension");
986 procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
987 pragma Import (C, Strncpy, "strncpy");
989 function Strlen (Cstring : Address) return Integer;
990 pragma Import (C, Strlen, "strlen");
992 Suffix_Length : Integer;
993 Result : String_Access;
996 Suffix_Length := Strlen (Target_Exec_Ext_Ptr);
998 Result := new String (1 .. Suffix_Length);
1000 if Suffix_Length > 0 then
1001 Strncpy (Result.all'Address, Target_Exec_Ext_Ptr, Suffix_Length);
1005 end Get_Target_Debuggable_Suffix;
1007 ----------------------------------
1008 -- Get_Target_Executable_Suffix --
1009 ----------------------------------
1011 function Get_Target_Executable_Suffix return String_Access is
1012 Target_Exec_Ext_Ptr : Address;
1014 (C, Target_Exec_Ext_Ptr, "__gnat_target_executable_extension");
1016 procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
1017 pragma Import (C, Strncpy, "strncpy");
1019 function Strlen (Cstring : Address) return Integer;
1020 pragma Import (C, Strlen, "strlen");
1022 Suffix_Length : Integer;
1023 Result : String_Access;
1026 Suffix_Length := Strlen (Target_Exec_Ext_Ptr);
1028 Result := new String (1 .. Suffix_Length);
1030 if Suffix_Length > 0 then
1031 Strncpy (Result.all'Address, Target_Exec_Ext_Ptr, Suffix_Length);
1035 end Get_Target_Executable_Suffix;
1037 ------------------------------
1038 -- Get_Target_Object_Suffix --
1039 ------------------------------
1041 function Get_Target_Object_Suffix return String_Access is
1042 Target_Object_Ext_Ptr : Address;
1044 (C, Target_Object_Ext_Ptr, "__gnat_target_object_extension");
1046 procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
1047 pragma Import (C, Strncpy, "strncpy");
1049 function Strlen (Cstring : Address) return Integer;
1050 pragma Import (C, Strlen, "strlen");
1052 Suffix_Length : Integer;
1053 Result : String_Access;
1056 Suffix_Length := Strlen (Target_Object_Ext_Ptr);
1058 Result := new String (1 .. Suffix_Length);
1060 if Suffix_Length > 0 then
1061 Strncpy (Result.all'Address, Target_Object_Ext_Ptr, Suffix_Length);
1065 end Get_Target_Object_Suffix;
1071 function Getenv (Name : String) return String_Access is
1072 procedure Get_Env_Value_Ptr (Name, Length, Ptr : Address);
1073 pragma Import (C, Get_Env_Value_Ptr, "__gnat_getenv");
1075 procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
1076 pragma Import (C, Strncpy, "strncpy");
1078 Env_Value_Ptr : aliased Address;
1079 Env_Value_Length : aliased Integer;
1080 F_Name : aliased String (1 .. Name'Length + 1);
1081 Result : String_Access;
1084 F_Name (1 .. Name'Length) := Name;
1085 F_Name (F_Name'Last) := ASCII.NUL;
1088 (F_Name'Address, Env_Value_Length'Address, Env_Value_Ptr'Address);
1090 Result := new String (1 .. Env_Value_Length);
1092 if Env_Value_Length > 0 then
1093 Strncpy (Result.all'Address, Env_Value_Ptr, Env_Value_Length);
1103 function GM_Day (Date : OS_Time) return Day_Type is
1106 pragma Warnings (Off);
1112 pragma Warnings (On);
1115 GM_Split (Date, Y, Mo, D, H, Mn, S);
1123 function GM_Hour (Date : OS_Time) return Hour_Type is
1126 pragma Warnings (Off);
1132 pragma Warnings (On);
1135 GM_Split (Date, Y, Mo, D, H, Mn, S);
1143 function GM_Minute (Date : OS_Time) return Minute_Type is
1146 pragma Warnings (Off);
1152 pragma Warnings (On);
1155 GM_Split (Date, Y, Mo, D, H, Mn, S);
1163 function GM_Month (Date : OS_Time) return Month_Type is
1166 pragma Warnings (Off);
1172 pragma Warnings (On);
1175 GM_Split (Date, Y, Mo, D, H, Mn, S);
1183 function GM_Second (Date : OS_Time) return Second_Type is
1186 pragma Warnings (Off);
1192 pragma Warnings (On);
1195 GM_Split (Date, Y, Mo, D, H, Mn, S);
1205 Year : out Year_Type;
1206 Month : out Month_Type;
1208 Hour : out Hour_Type;
1209 Minute : out Minute_Type;
1210 Second : out Second_Type)
1212 procedure To_GM_Time
1213 (P_Time_T, P_Year, P_Month, P_Day, P_Hours, P_Mins, P_Secs : Address);
1214 pragma Import (C, To_GM_Time, "__gnat_to_gm_time");
1216 T : OS_Time := Date;
1225 -- Use the global lock because To_GM_Time is not thread safe
1227 Locked_Processing : begin
1230 (T'Address, Y'Address, Mo'Address, D'Address,
1231 H'Address, Mn'Address, S'Address);
1232 SSL.Unlock_Task.all;
1236 SSL.Unlock_Task.all;
1238 end Locked_Processing;
1252 function GM_Year (Date : OS_Time) return Year_Type is
1255 pragma Warnings (Off);
1261 pragma Warnings (On);
1264 GM_Split (Date, Y, Mo, D, H, Mn, S);
1268 ----------------------
1269 -- Is_Absolute_Path --
1270 ----------------------
1272 function Is_Absolute_Path (Name : String) return Boolean is
1273 function Is_Absolute_Path
1275 Length : Integer) return Integer;
1276 pragma Import (C, Is_Absolute_Path, "__gnat_is_absolute_path");
1278 return Is_Absolute_Path (Name'Address, Name'Length) /= 0;
1279 end Is_Absolute_Path;
1285 function Is_Directory (Name : C_File_Name) return Boolean is
1286 function Is_Directory (Name : Address) return Integer;
1287 pragma Import (C, Is_Directory, "__gnat_is_directory");
1289 return Is_Directory (Name) /= 0;
1292 function Is_Directory (Name : String) return Boolean is
1293 F_Name : String (1 .. Name'Length + 1);
1295 F_Name (1 .. Name'Length) := Name;
1296 F_Name (F_Name'Last) := ASCII.NUL;
1297 return Is_Directory (F_Name'Address);
1300 ----------------------
1301 -- Is_Readable_File --
1302 ----------------------
1304 function Is_Readable_File (Name : C_File_Name) return Boolean is
1305 function Is_Readable_File (Name : Address) return Integer;
1306 pragma Import (C, Is_Readable_File, "__gnat_is_readable_file");
1308 return Is_Readable_File (Name) /= 0;
1309 end Is_Readable_File;
1311 function Is_Readable_File (Name : String) return Boolean is
1312 F_Name : String (1 .. Name'Length + 1);
1314 F_Name (1 .. Name'Length) := Name;
1315 F_Name (F_Name'Last) := ASCII.NUL;
1316 return Is_Readable_File (F_Name'Address);
1317 end Is_Readable_File;
1319 ---------------------
1320 -- Is_Regular_File --
1321 ---------------------
1323 function Is_Regular_File (Name : C_File_Name) return Boolean is
1324 function Is_Regular_File (Name : Address) return Integer;
1325 pragma Import (C, Is_Regular_File, "__gnat_is_regular_file");
1327 return Is_Regular_File (Name) /= 0;
1328 end Is_Regular_File;
1330 function Is_Regular_File (Name : String) return Boolean is
1331 F_Name : String (1 .. Name'Length + 1);
1333 F_Name (1 .. Name'Length) := Name;
1334 F_Name (F_Name'Last) := ASCII.NUL;
1335 return Is_Regular_File (F_Name'Address);
1336 end Is_Regular_File;
1338 ----------------------
1339 -- Is_Symbolic_Link --
1340 ----------------------
1342 function Is_Symbolic_Link (Name : C_File_Name) return Boolean is
1343 function Is_Symbolic_Link (Name : Address) return Integer;
1344 pragma Import (C, Is_Symbolic_Link, "__gnat_is_symbolic_link");
1346 return Is_Symbolic_Link (Name) /= 0;
1347 end Is_Symbolic_Link;
1349 function Is_Symbolic_Link (Name : String) return Boolean is
1350 F_Name : String (1 .. Name'Length + 1);
1352 F_Name (1 .. Name'Length) := Name;
1353 F_Name (F_Name'Last) := ASCII.NUL;
1354 return Is_Symbolic_Link (F_Name'Address);
1355 end Is_Symbolic_Link;
1357 ----------------------
1358 -- Is_Writable_File --
1359 ----------------------
1361 function Is_Writable_File (Name : C_File_Name) return Boolean is
1362 function Is_Writable_File (Name : Address) return Integer;
1363 pragma Import (C, Is_Writable_File, "__gnat_is_writable_file");
1365 return Is_Writable_File (Name) /= 0;
1366 end Is_Writable_File;
1368 function Is_Writable_File (Name : String) return Boolean is
1369 F_Name : String (1 .. Name'Length + 1);
1371 F_Name (1 .. Name'Length) := Name;
1372 F_Name (F_Name'Last) := ASCII.NUL;
1373 return Is_Writable_File (F_Name'Address);
1374 end Is_Writable_File;
1376 -------------------------
1377 -- Locate_Exec_On_Path --
1378 -------------------------
1380 function Locate_Exec_On_Path
1381 (Exec_Name : String) return String_Access
1383 function Locate_Exec_On_Path (C_Exec_Name : Address) return Address;
1384 pragma Import (C, Locate_Exec_On_Path, "__gnat_locate_exec_on_path");
1386 procedure Free (Ptr : System.Address);
1387 pragma Import (C, Free, "free");
1389 C_Exec_Name : String (1 .. Exec_Name'Length + 1);
1390 Path_Addr : Address;
1392 Result : String_Access;
1395 C_Exec_Name (1 .. Exec_Name'Length) := Exec_Name;
1396 C_Exec_Name (C_Exec_Name'Last) := ASCII.NUL;
1398 Path_Addr := Locate_Exec_On_Path (C_Exec_Name'Address);
1399 Path_Len := C_String_Length (Path_Addr);
1401 if Path_Len = 0 then
1405 Result := To_Path_String_Access (Path_Addr, Path_Len);
1408 -- Always return an absolute path name
1410 if not Is_Absolute_Path (Result.all) then
1412 Absolute_Path : constant String :=
1413 Normalize_Pathname (Result.all);
1416 Result := new String'(Absolute_Path
);
1422 end Locate_Exec_On_Path
;
1424 -------------------------
1425 -- Locate_Regular_File --
1426 -------------------------
1428 function Locate_Regular_File
1429 (File_Name
: C_File_Name
;
1430 Path
: C_File_Name
) return String_Access
1432 function Locate_Regular_File
1433 (C_File_Name
, Path_Val
: Address
) return Address
;
1434 pragma Import
(C
, Locate_Regular_File
, "__gnat_locate_regular_file");
1436 procedure Free
(Ptr
: System
.Address
);
1437 pragma Import
(C
, Free
, "free");
1439 Path_Addr
: Address
;
1441 Result
: String_Access
;
1444 Path_Addr
:= Locate_Regular_File
(File_Name
, Path
);
1445 Path_Len
:= C_String_Length
(Path_Addr
);
1447 if Path_Len
= 0 then
1450 Result
:= To_Path_String_Access
(Path_Addr
, Path_Len
);
1454 end Locate_Regular_File
;
1456 function Locate_Regular_File
1457 (File_Name
: String;
1458 Path
: String) return String_Access
1460 C_File_Name
: String (1 .. File_Name
'Length + 1);
1461 C_Path
: String (1 .. Path
'Length + 1);
1462 Result
: String_Access
;
1465 C_File_Name
(1 .. File_Name
'Length) := File_Name
;
1466 C_File_Name
(C_File_Name
'Last) := ASCII
.NUL
;
1468 C_Path
(1 .. Path
'Length) := Path
;
1469 C_Path
(C_Path
'Last) := ASCII
.NUL
;
1471 Result
:= Locate_Regular_File
(C_File_Name
'Address, C_Path
'Address);
1473 -- Always return an absolute path name
1475 if Result
/= null and then not Is_Absolute_Path
(Result
.all) then
1477 Absolute_Path
: constant String := Normalize_Pathname
(Result
.all);
1480 Result
:= new String'(Absolute_Path);
1485 end Locate_Regular_File;
1487 ------------------------
1488 -- Non_Blocking_Spawn --
1489 ------------------------
1491 function Non_Blocking_Spawn
1492 (Program_Name : String;
1493 Args : Argument_List) return Process_Id
1497 pragma Warnings (Off, Junk);
1499 Spawn_Internal (Program_Name, Args, Junk, Pid, Blocking => False);
1501 end Non_Blocking_Spawn;
1503 function Non_Blocking_Spawn
1504 (Program_Name : String;
1505 Args : Argument_List;
1506 Output_File_Descriptor : File_Descriptor;
1507 Err_To_Out : Boolean := True) return Process_Id
1509 Saved_Output : File_Descriptor;
1510 Saved_Error : File_Descriptor := Invalid_FD; -- prevent warning
1514 if Output_File_Descriptor = Invalid_FD then
1518 -- Set standard output and, if specified, error to the temporary file
1520 Saved_Output := Dup (Standout);
1521 Dup2 (Output_File_Descriptor, Standout);
1524 Saved_Error := Dup (Standerr);
1525 Dup2 (Output_File_Descriptor, Standerr);
1528 -- Spawn the program
1530 Pid := Non_Blocking_Spawn (Program_Name, Args);
1532 -- Restore the standard output and error
1534 Dup2 (Saved_Output, Standout);
1537 Dup2 (Saved_Error, Standerr);
1540 -- And close the saved standard output and error file descriptors
1542 Close (Saved_Output);
1545 Close (Saved_Error);
1549 end Non_Blocking_Spawn;
1551 function Non_Blocking_Spawn
1552 (Program_Name : String;
1553 Args : Argument_List;
1554 Output_File : String;
1555 Err_To_Out : Boolean := True) return Process_Id
1557 Output_File_Descriptor : constant File_Descriptor :=
1558 Create_Output_Text_File (Output_File);
1559 Result : Process_Id;
1562 -- Do not attempt to spawn if the output file could not be created
1564 if Output_File_Descriptor = Invalid_FD then
1568 Result := Non_Blocking_Spawn
1569 (Program_Name, Args, Output_File_Descriptor, Err_To_Out);
1571 -- Close the file just created for the output, as the file descriptor
1572 -- cannot be used anywhere, being a local value. It is safe to do
1573 -- that, as the file descriptor has been duplicated to form
1574 -- standard output and error of the spawned process.
1576 Close (Output_File_Descriptor);
1580 end Non_Blocking_Spawn;
1582 -------------------------
1583 -- Normalize_Arguments --
1584 -------------------------
1586 procedure Normalize_Arguments (Args : in out Argument_List) is
1588 procedure Quote_Argument (Arg : in out String_Access);
1589 -- Add quote around argument if it contains spaces
1591 C_Argument_Needs_Quote : Integer;
1592 pragma Import (C, C_Argument_Needs_Quote, "__gnat_argument_needs_quote");
1593 Argument_Needs_Quote : constant Boolean := C_Argument_Needs_Quote /= 0;
1595 --------------------
1596 -- Quote_Argument --
1597 --------------------
1599 procedure Quote_Argument (Arg : in out String_Access) is
1600 Res : String (1 .. Arg'Length * 2);
1602 Quote_Needed : Boolean := False;
1605 if Arg (Arg'First) /= '"' or else Arg (Arg'Last) /= '"' then
1611 for K in Arg'Range loop
1615 if Arg (K) = '"' then
1619 Quote_Needed := True;
1621 elsif Arg (K) = ' ' then
1623 Quote_Needed := True;
1631 if Quote_Needed then
1633 -- If null terminated string, put the quote before
1635 if Res (J) = ASCII.NUL then
1638 Res (J) := ASCII.NUL;
1640 -- If argument is terminated by '\
', then double it. Otherwise
1641 -- the ending quote will be taken as-is. This is quite strange
1642 -- spawn behavior from Windows, but this is what we see!
1645 if Res (J) = '\
' then
1657 Old : String_Access := Arg;
1660 Arg := new String'(Res (1 .. J));
1668 -- Start of processing for Normalize_Arguments
1671 if Argument_Needs_Quote then
1672 for K in Args'Range loop
1673 if Args (K) /= null and then Args (K)'Length /= 0 then
1674 Quote_Argument (Args (K));
1678 end Normalize_Arguments;
1680 ------------------------
1681 -- Normalize_Pathname --
1682 ------------------------
1684 function Normalize_Pathname
1686 Directory : String := "";
1687 Resolve_Links : Boolean := True;
1688 Case_Sensitive : Boolean := True) return String
1691 pragma Import (C, Max_Path, "__gnat_max_path_len
");
1692 -- Maximum length of a path name
1694 procedure Get_Current_Dir
1695 (Dir : System.Address;
1696 Length : System.Address);
1697 pragma Import (C, Get_Current_Dir, "__gnat_get_current_dir
");
1699 Path_Buffer : String (1 .. Max_Path + Max_Path + 2);
1700 End_Path : Natural := 0;
1701 Link_Buffer : String (1 .. Max_Path + 2);
1707 Max_Iterations : constant := 500;
1709 function Get_File_Names_Case_Sensitive return Integer;
1711 (C, Get_File_Names_Case_Sensitive,
1712 "__gnat_get_file_names_case_sensitive
");
1714 Fold_To_Lower_Case : constant Boolean :=
1716 and then Get_File_Names_Case_Sensitive = 0;
1719 (Path : System.Address;
1720 Buf : System.Address;
1721 Bufsiz : Integer) return Integer;
1722 pragma Import (C, Readlink, "__gnat_readlink
");
1724 function To_Canonical_File_Spec
1725 (Host_File : System.Address) return System.Address;
1727 (C, To_Canonical_File_Spec, "__gnat_to_canonical_file_spec
");
1729 The_Name : String (1 .. Name'Length + 1);
1730 Canonical_File_Addr : System.Address;
1731 Canonical_File_Len : Integer;
1733 function Strlen (S : System.Address) return Integer;
1734 pragma Import (C, Strlen, "strlen
");
1736 function Final_Value (S : String) return String;
1737 -- Make final adjustment to the returned string. This function strips
1738 -- trailing directory separators, and folds returned string to lower
1739 -- case if required.
1741 function Get_Directory (Dir : String) return String;
1742 -- If Dir is not empty, return it, adding a directory separator
1743 -- if not already present, otherwise return current working directory
1744 -- with terminating directory separator.
1750 function Final_Value (S : String) return String is
1752 -- We may need to fold S to lower case, so we need a variable
1757 if Fold_To_Lower_Case then
1758 System.Case_Util.To_Lower (S1);
1761 -- Remove trailing directory separator, if any
1766 and then (S1 (Last) = '/'
1768 S1 (Last) = Directory_Separator)
1770 -- Special case for Windows: C:\
1773 and then S1 (1) /= Directory_Separator
1774 and then S1 (2) = ':'
1783 return S1 (1 .. Last);
1790 function Get_Directory (Dir : String) return String is
1792 -- Directory given, add directory separator if needed
1794 if Dir'Length > 0 then
1795 if Dir (Dir'Last) = Directory_Separator then
1799 Result : String (1 .. Dir'Length + 1);
1801 Result (1 .. Dir'Length) := Dir;
1802 Result (Result'Length) := Directory_Separator;
1807 -- Directory name not given, get current directory
1811 Buffer : String (1 .. Max_Path + 2);
1812 Path_Len : Natural := Max_Path;
1815 Get_Current_Dir (Buffer'Address, Path_Len'Address);
1817 if Buffer (Path_Len) /= Directory_Separator then
1818 Path_Len := Path_Len + 1;
1819 Buffer (Path_Len) := Directory_Separator;
1822 -- By default, the drive letter on Windows is in upper case
1824 if On_Windows and then Path_Len >= 2 and then
1827 System.Case_Util.To_Upper (Buffer (1 .. 1));
1830 return Buffer (1 .. Path_Len);
1835 -- Start of processing for Normalize_Pathname
1838 -- Special case, if name is null, then return null
1840 if Name'Length = 0 then
1844 -- First, convert VMS file spec to Unix file spec.
1845 -- If Name is not in VMS syntax, then this is equivalent
1846 -- to put Name at the beginning of Path_Buffer.
1848 VMS_Conversion : begin
1849 The_Name (1 .. Name'Length) := Name;
1850 The_Name (The_Name'Last) := ASCII.NUL;
1852 Canonical_File_Addr := To_Canonical_File_Spec (The_Name'Address);
1853 Canonical_File_Len := Strlen (Canonical_File_Addr);
1855 -- If VMS syntax conversion has failed, return an empty string
1856 -- to indicate the failure.
1858 if Canonical_File_Len = 0 then
1863 subtype Path_String is String (1 .. Canonical_File_Len);
1864 type Path_String_Access is access Path_String;
1866 function Address_To_Access is new
1867 Ada.Unchecked_Conversion (Source => Address,
1868 Target => Path_String_Access);
1870 Path_Access : constant Path_String_Access :=
1871 Address_To_Access (Canonical_File_Addr);
1874 Path_Buffer (1 .. Canonical_File_Len) := Path_Access.all;
1875 End_Path := Canonical_File_Len;
1880 -- Replace all '/' by Directory Separators (this is for Windows)
1882 if Directory_Separator /= '/' then
1883 for Index in 1 .. End_Path loop
1884 if Path_Buffer (Index) = '/' then
1885 Path_Buffer (Index) := Directory_Separator;
1890 -- Resolve directory names for Windows (formerly also VMS)
1892 -- On VMS, if we have a Unix path such as /temp/..., and TEMP is a
1893 -- logical name, we must not try to resolve this logical name, because
1894 -- it may have multiple equivalences and if resolved we will only
1895 -- get the first one.
1897 -- On Windows, if we have an absolute path starting with a directory
1898 -- separator, we need to have the drive letter appended in front.
1900 -- On Windows, Get_Current_Dir will return a suitable directory
1901 -- name (path starting with a drive letter on Windows). So we take this
1902 -- drive letter and prepend it to the current path.
1905 and then Path_Buffer (1) = Directory_Separator
1906 and then Path_Buffer (2) /= Directory_Separator
1909 Cur_Dir : constant String := Get_Directory ("");
1910 -- Get the current directory to get the drive letter
1913 if Cur_Dir'Length > 2
1914 and then Cur_Dir (Cur_Dir'First + 1) = ':'
1916 Path_Buffer (3 .. End_Path + 2) := Path_Buffer (1 .. End_Path);
1917 Path_Buffer (1 .. 2) :=
1918 Cur_Dir (Cur_Dir'First .. Cur_Dir'First + 1);
1919 End_Path := End_Path + 2;
1924 -- Start the conversions
1926 -- If this is not finished after Max_Iterations, give up and return an
1929 for J in 1 .. Max_Iterations loop
1931 -- If we don't have an absolute pathname, prepend the directory
1935 and then not Is_Absolute_Path (Path_Buffer (1 .. End_Path))
1938 Reference_Dir : constant String := Get_Directory (Directory);
1939 Ref_Dir_Len : constant Natural := Reference_Dir'Length;
1940 -- Current directory name specified and its length
1943 Path_Buffer (Ref_Dir_Len + 1 .. Ref_Dir_Len + End_Path) :=
1944 Path_Buffer (1 .. End_Path);
1945 End_Path := Ref_Dir_Len + End_Path;
1946 Path_Buffer (1 .. Ref_Dir_Len) := Reference_Dir;
1947 Last := Ref_Dir_Len;
1954 -- Ensure that Windows network drives are kept, e.g: \\server\drive-c
1957 and then Directory_Separator = '\'
1958 and then Path_Buffer (1 .. 2) = "\\"
1963 -- If we have traversed the full pathname, return it
1965 if Start > End_Path then
1966 return Final_Value (Path_Buffer (1 .. End_Path));
1969 -- Remove duplicate directory separators
1971 while Path_Buffer (Start) = Directory_Separator loop
1972 if Start = End_Path then
1973 return Final_Value (Path_Buffer (1 .. End_Path - 1));
1976 Path_Buffer (Start .. End_Path - 1) :=
1977 Path_Buffer (Start + 1 .. End_Path);
1978 End_Path := End_Path - 1;
1982 -- Find the end of the current field: last character or the one
1983 -- preceding the next directory separator.
1985 while Finish < End_Path
1986 and then Path_Buffer (Finish + 1) /= Directory_Separator
1988 Finish := Finish + 1;
1993 if Start = Finish and then Path_Buffer (Start) = '.' then
1994 if Start = End_Path then
1996 return (1 => Directory_Separator);
1999 if Fold_To_Lower_Case then
2000 System.Case_Util.To_Lower (Path_Buffer (1 .. Last - 1));
2003 return Path_Buffer (1 .. Last - 1);
2008 Path_Buffer (Last + 1 .. End_Path - 2) :=
2009 Path_Buffer (Last + 3 .. End_Path);
2010 End_Path := End_Path - 2;
2013 -- Remove ".." fields
2015 elsif Finish = Start + 1
2016 and then Path_Buffer (Start .. Finish) = ".."
2021 exit when Start < 1 or else
2022 Path_Buffer (Start) = Directory_Separator;
2026 if Finish = End_Path then
2027 return (1 => Directory_Separator);
2030 Path_Buffer (1 .. End_Path - Finish) :=
2031 Path_Buffer (Finish + 1 .. End_Path);
2032 End_Path := End_Path - Finish;
2037 if Finish = End_Path then
2038 return Final_Value (Path_Buffer (1 .. Start - 1));
2041 Path_Buffer (Start + 1 .. Start + End_Path - Finish - 1) :=
2042 Path_Buffer (Finish + 2 .. End_Path);
2043 End_Path := Start + End_Path - Finish - 1;
2048 -- Check if current field is a symbolic link
2050 elsif Resolve_Links then
2052 Saved : constant Character := Path_Buffer (Finish + 1);
2055 Path_Buffer (Finish + 1) := ASCII.NUL;
2056 Status := Readlink (Path_Buffer'Address,
2057 Link_Buffer'Address,
2058 Link_Buffer'Length);
2059 Path_Buffer (Finish + 1) := Saved;
2062 -- Not a symbolic link, move to the next field, if any
2067 -- Replace symbolic link with its value
2070 if Is_Absolute_Path (Link_Buffer (1 .. Status)) then
2071 Path_Buffer (Status + 1 .. End_Path - (Finish - Status)) :=
2072 Path_Buffer (Finish + 1 .. End_Path);
2073 End_Path := End_Path - (Finish - Status);
2074 Path_Buffer (1 .. Status) := Link_Buffer (1 .. Status);
2079 (Last + Status + 1 .. End_Path - Finish + Last + Status) :=
2080 Path_Buffer (Finish + 1 .. End_Path);
2081 End_Path := End_Path - Finish + Last + Status;
2082 Path_Buffer (Last + 1 .. Last + Status) :=
2083 Link_Buffer (1 .. Status);
2092 -- Too many iterations: give up
2094 -- This can happen when there is a circularity in the symbolic links: A
2095 -- is a symbolic link for B, which itself is a symbolic link, and the
2096 -- target of B or of another symbolic link target of B is A. In this
2097 -- case, we return an empty string to indicate failure to resolve.
2100 end Normalize_Pathname;
2107 (Name : C_File_Name;
2108 Fmode : Mode) return File_Descriptor
2110 function C_Open_Read
2111 (Name : C_File_Name;
2112 Fmode : Mode) return File_Descriptor;
2113 pragma Import (C, C_Open_Read, "__gnat_open_read
");
2115 return C_Open_Read (Name, Fmode);
2120 Fmode : Mode) return File_Descriptor
2122 C_Name : String (1 .. Name'Length + 1);
2124 C_Name (1 .. Name'Length) := Name;
2125 C_Name (C_Name'Last) := ASCII.NUL;
2126 return Open_Read (C_Name (C_Name'First)'Address, Fmode);
2129 ---------------------
2130 -- Open_Read_Write --
2131 ---------------------
2133 function Open_Read_Write
2134 (Name : C_File_Name;
2135 Fmode : Mode) return File_Descriptor
2137 function C_Open_Read_Write
2138 (Name : C_File_Name;
2139 Fmode : Mode) return File_Descriptor;
2140 pragma Import (C, C_Open_Read_Write, "__gnat_open_rw
");
2142 return C_Open_Read_Write (Name, Fmode);
2143 end Open_Read_Write;
2145 function Open_Read_Write
2147 Fmode : Mode) return File_Descriptor
2149 C_Name : String (1 .. Name'Length + 1);
2151 C_Name (1 .. Name'Length) := Name;
2152 C_Name (C_Name'Last) := ASCII.NUL;
2153 return Open_Read_Write (C_Name (C_Name'First)'Address, Fmode);
2154 end Open_Read_Write;
2160 procedure OS_Exit (Status : Integer) is
2162 OS_Exit_Ptr (Status);
2163 raise Program_Error;
2166 ---------------------
2167 -- OS_Exit_Default --
2168 ---------------------
2170 procedure OS_Exit_Default (Status : Integer) is
2171 procedure GNAT_OS_Exit (Status : Integer);
2172 pragma Import (C, GNAT_OS_Exit, "__gnat_os_exit
");
2173 pragma No_Return (GNAT_OS_Exit);
2175 GNAT_OS_Exit (Status);
2176 end OS_Exit_Default;
2178 --------------------
2179 -- Pid_To_Integer --
2180 --------------------
2182 function Pid_To_Integer (Pid : Process_Id) return Integer is
2184 return Integer (Pid);
2192 (FD : File_Descriptor;
2194 N : Integer) return Integer
2197 return Integer (System.CRTL.read
2198 (System.CRTL.int (FD), System.CRTL.chars (A), System.CRTL.int (N)));
2205 procedure Rename_File
2206 (Old_Name : C_File_Name;
2207 New_Name : C_File_Name;
2208 Success : out Boolean)
2210 function rename (From, To : Address) return Integer;
2211 pragma Import (C, rename, "rename
");
2214 R := rename (Old_Name, New_Name);
2218 procedure Rename_File
2221 Success : out Boolean)
2223 C_Old_Name : String (1 .. Old_Name'Length + 1);
2224 C_New_Name : String (1 .. New_Name'Length + 1);
2226 C_Old_Name (1 .. Old_Name'Length) := Old_Name;
2227 C_Old_Name (C_Old_Name'Last) := ASCII.NUL;
2228 C_New_Name (1 .. New_Name'Length) := New_Name;
2229 C_New_Name (C_New_Name'Last) := ASCII.NUL;
2230 Rename_File (C_Old_Name'Address, C_New_Name'Address, Success);
2233 -----------------------
2234 -- Set_Close_On_Exec --
2235 -----------------------
2237 procedure Set_Close_On_Exec
2238 (FD : File_Descriptor;
2239 Close_On_Exec : Boolean;
2240 Status : out Boolean)
2242 function C_Set_Close_On_Exec
2243 (FD : File_Descriptor; Close_On_Exec : System.CRTL.int)
2244 return System.CRTL.int;
2245 pragma Import (C, C_Set_Close_On_Exec, "__gnat_set_close_on_exec
");
2247 Status := C_Set_Close_On_Exec (FD, Boolean'Pos (Close_On_Exec)) = 0;
2248 end Set_Close_On_Exec;
2250 --------------------
2251 -- Set_Executable --
2252 --------------------
2254 procedure Set_Executable (Name : String) is
2255 procedure C_Set_Executable (Name : C_File_Name);
2256 pragma Import (C, C_Set_Executable, "__gnat_set_executable
");
2257 C_Name : aliased String (Name'First .. Name'Last + 1);
2259 C_Name (Name'Range) := Name;
2260 C_Name (C_Name'Last) := ASCII.NUL;
2261 C_Set_Executable (C_Name (C_Name'First)'Address);
2264 --------------------
2266 --------------------
2268 procedure Set_Read_Only (Name : String) is
2269 procedure C_Set_Read_Only (Name : C_File_Name);
2270 pragma Import (C, C_Set_Read_Only, "__gnat_set_readonly
");
2271 C_Name : aliased String (Name'First .. Name'Last + 1);
2273 C_Name (Name'Range) := Name;
2274 C_Name (C_Name'Last) := ASCII.NUL;
2275 C_Set_Read_Only (C_Name (C_Name'First)'Address);
2278 --------------------
2280 --------------------
2282 procedure Set_Writable (Name : String) is
2283 procedure C_Set_Writable (Name : C_File_Name);
2284 pragma Import (C, C_Set_Writable, "__gnat_set_writable
");
2285 C_Name : aliased String (Name'First .. Name'Last + 1);
2287 C_Name (Name'Range) := Name;
2288 C_Name (C_Name'Last) := ASCII.NUL;
2289 C_Set_Writable (C_Name (C_Name'First)'Address);
2296 procedure Setenv (Name : String; Value : String) is
2297 F_Name : String (1 .. Name'Length + 1);
2298 F_Value : String (1 .. Value'Length + 1);
2300 procedure Set_Env_Value (Name, Value : System.Address);
2301 pragma Import (C, Set_Env_Value, "__gnat_setenv
");
2304 F_Name (1 .. Name'Length) := Name;
2305 F_Name (F_Name'Last) := ASCII.NUL;
2307 F_Value (1 .. Value'Length) := Value;
2308 F_Value (F_Value'Last) := ASCII.NUL;
2310 Set_Env_Value (F_Name'Address, F_Value'Address);
2318 (Program_Name : String;
2319 Args : Argument_List) return Integer
2323 pragma Warnings (Off, Junk);
2325 Spawn_Internal (Program_Name, Args, Result, Junk, Blocking => True);
2330 (Program_Name : String;
2331 Args : Argument_List;
2332 Success : out Boolean)
2335 Success := (Spawn (Program_Name, Args) = 0);
2339 (Program_Name : String;
2340 Args : Argument_List;
2341 Output_File_Descriptor : File_Descriptor;
2342 Return_Code : out Integer;
2343 Err_To_Out : Boolean := True)
2345 Saved_Output : File_Descriptor;
2346 Saved_Error : File_Descriptor := Invalid_FD; -- prevent compiler warning
2349 -- Set standard output and error to the temporary file
2351 Saved_Output := Dup (Standout);
2352 Dup2 (Output_File_Descriptor, Standout);
2355 Saved_Error := Dup (Standerr);
2356 Dup2 (Output_File_Descriptor, Standerr);
2359 -- Spawn the program
2361 Return_Code := Spawn (Program_Name, Args);
2363 -- Restore the standard output and error
2365 Dup2 (Saved_Output, Standout);
2368 Dup2 (Saved_Error, Standerr);
2371 -- And close the saved standard output and error file descriptors
2373 Close (Saved_Output);
2376 Close (Saved_Error);
2381 (Program_Name : String;
2382 Args : Argument_List;
2383 Output_File : String;
2384 Success : out Boolean;
2385 Return_Code : out Integer;
2386 Err_To_Out : Boolean := True)
2388 FD : File_Descriptor;
2394 FD := Create_Output_Text_File (Output_File);
2396 if FD = Invalid_FD then
2401 Spawn (Program_Name, Args, FD, Return_Code, Err_To_Out);
2403 Close (FD, Success);
2406 --------------------
2407 -- Spawn_Internal --
2408 --------------------
2410 procedure Spawn_Internal
2411 (Program_Name : String;
2412 Args : Argument_List;
2413 Result : out Integer;
2414 Pid : out Process_Id;
2418 procedure Spawn (Args : Argument_List);
2419 -- Call Spawn with given argument list
2421 N_Args : Argument_List (Args'Range);
2422 -- Normalized arguments
2428 procedure Spawn (Args : Argument_List) is
2429 type Chars is array (Positive range <>) of aliased Character;
2430 type Char_Ptr is access constant Character;
2432 Command_Len : constant Positive := Program_Name'Length + 1
2433 + Args_Length (Args);
2434 Command_Last : Natural := 0;
2435 Command : aliased Chars (1 .. Command_Len);
2436 -- Command contains all characters of the Program_Name and Args, all
2437 -- terminated by ASCII.NUL characters
2439 Arg_List_Len : constant Positive := Args'Length + 2;
2440 Arg_List_Last : Natural := 0;
2441 Arg_List : aliased array (1 .. Arg_List_Len) of Char_Ptr;
2442 -- List with pointers to NUL-terminated strings of the Program_Name
2443 -- and the Args and terminated with a null pointer. We rely on the
2444 -- default initialization for the last null pointer.
2446 procedure Add_To_Command (S : String);
2447 -- Add S and a NUL character to Command, updating Last
2449 function Portable_Spawn (Args : Address) return Integer;
2450 pragma Import (C, Portable_Spawn, "__gnat_portable_spawn
");
2452 function Portable_No_Block_Spawn (Args : Address) return Process_Id;
2454 (C, Portable_No_Block_Spawn, "__gnat_portable_no_block_spawn
");
2456 --------------------
2457 -- Add_To_Command --
2458 --------------------
2460 procedure Add_To_Command (S : String) is
2461 First : constant Natural := Command_Last + 1;
2464 Command_Last := Command_Last + S'Length;
2466 -- Move characters one at a time, because Command has aliased
2469 -- But not volatile, so why is this necessary ???
2471 for J in S'Range loop
2472 Command (First + J - S'First) := S (J);
2475 Command_Last := Command_Last + 1;
2476 Command (Command_Last) := ASCII.NUL;
2478 Arg_List_Last := Arg_List_Last + 1;
2479 Arg_List (Arg_List_Last) := Command (First)'Access;
2482 -- Start of processing for Spawn
2485 Add_To_Command (Program_Name);
2487 for J in Args'Range loop
2488 Add_To_Command (Args (J).all);
2493 Result := Portable_Spawn (Arg_List'Address);
2495 Pid := Portable_No_Block_Spawn (Arg_List'Address);
2496 Result := Boolean'Pos (Pid /= Invalid_Pid);
2500 -- Start of processing for Spawn_Internal
2503 -- Copy arguments into a local structure
2505 for K in N_Args'Range loop
2506 N_Args (K) := new String'(Args (K).all);
2509 -- Normalize those arguments
2511 Normalize_Arguments (N_Args);
2513 -- Call spawn using the normalized arguments
2517 -- Free arguments list
2519 for K in N_Args'Range loop
2524 ---------------------------
2525 -- To_Path_String_Access --
2526 ---------------------------
2528 function To_Path_String_Access
2529 (Path_Addr : Address;
2530 Path_Len : Integer) return String_Access
2532 subtype Path_String is String (1 .. Path_Len);
2533 type Path_String_Access is access Path_String;
2535 function Address_To_Access is new
2536 Ada.Unchecked_Conversion (Source => Address,
2537 Target => Path_String_Access);
2539 Path_Access : constant Path_String_Access :=
2540 Address_To_Access (Path_Addr);
2542 Return_Val : String_Access;
2545 Return_Val := new String (1 .. Path_Len);
2547 for J in 1 .. Path_Len loop
2548 Return_Val (J) := Path_Access (J);
2552 end To_Path_String_Access;
2558 procedure Wait_Process (Pid : out Process_Id; Success : out Boolean) is
2561 function Portable_Wait (S : Address) return Process_Id;
2562 pragma Import (C, Portable_Wait, "__gnat_portable_wait
");
2565 Pid := Portable_Wait (Status'Address);
2566 Success := (Status = 0);
2574 (FD : File_Descriptor;
2576 N : Integer) return Integer
2579 return Integer (System.CRTL.write
2580 (System.CRTL.int (FD), System.CRTL.chars (A), System.CRTL.int (N)));