1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
5 -- G N A T . O S _ L I B --
9 -- Copyright (C) 1995-2006, 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 with System
.Case_Util
;
36 with System
.Soft_Links
;
37 with Unchecked_Conversion
;
38 with Unchecked_Deallocation
;
39 with System
; use System
;
41 package body GNAT
.OS_Lib
is
43 -- Imported procedures Dup and Dup2 are used in procedures Spawn and
44 -- Non_Blocking_Spawn.
46 function Dup
(Fd
: File_Descriptor
) return File_Descriptor
;
47 pragma Import
(C
, Dup
, "__gnat_dup");
49 procedure Dup2
(Old_Fd
, New_Fd
: File_Descriptor
);
50 pragma Import
(C
, Dup2
, "__gnat_dup2");
52 On_Windows
: constant Boolean := Directory_Separator
= '\';
53 -- An indication that we are on Windows. Used in Normalize_Pathname, to
54 -- deal with drive letters in the beginning of absolute paths.
56 package SSL
renames System
.Soft_Links
;
58 -- The following are used by Create_Temp_File
60 First_Temp_File_Name
: constant String := "GNAT-TEMP-000000.TMP";
61 -- Used to initialize Current_Temp_File_Name and Temp_File_Name_Last_Digit
63 Current_Temp_File_Name
: String := First_Temp_File_Name
;
64 -- Name of the temp file last created
66 Temp_File_Name_Last_Digit
: constant Positive :=
67 First_Temp_File_Name
'Last - 4;
68 -- Position of the last digit in Current_Temp_File_Name
70 Max_Attempts
: constant := 100;
71 -- The maximum number of attempts to create a new temp file
73 -----------------------
74 -- Local Subprograms --
75 -----------------------
77 function Args_Length
(Args
: Argument_List
) return Natural;
78 -- Returns total number of characters needed to create a string
79 -- of all Args terminated by ASCII.NUL characters
81 function C_String_Length
(S
: Address
) return Integer;
82 -- Returns the length of a C string. Does check for null address
85 procedure Spawn_Internal
86 (Program_Name
: String;
91 -- Internal routine to implement the two Spawn (blocking/non blocking)
92 -- routines. If Blocking is set to True then the spawn is blocking
93 -- otherwise it is non blocking. In this latter case the Pid contains the
94 -- process id number. The first three parameters are as in Spawn. Note that
95 -- Spawn_Internal normalizes the argument list before calling the low level
96 -- system spawn routines (see Normalize_Arguments).
98 -- Note: Normalize_Arguments is designed to do nothing if it is called more
99 -- than once, so calling Normalize_Arguments before calling one of the
100 -- spawn routines is fine.
102 function To_Path_String_Access
103 (Path_Addr
: Address
;
104 Path_Len
: Integer) return String_Access
;
105 -- Converts a C String to an Ada String. We could do this making use of
106 -- Interfaces.C.Strings but we prefer not to import that entire package
112 function "<" (X
, Y
: OS_Time
) return Boolean is
114 return Long_Integer (X
) < Long_Integer (Y
);
121 function "<=" (X
, Y
: OS_Time
) return Boolean is
123 return Long_Integer (X
) <= Long_Integer (Y
);
130 function ">" (X
, Y
: OS_Time
) return Boolean is
132 return Long_Integer (X
) > Long_Integer (Y
);
139 function ">=" (X
, Y
: OS_Time
) return Boolean is
141 return Long_Integer (X
) >= Long_Integer (Y
);
148 function Args_Length
(Args
: Argument_List
) return Natural is
152 for J
in Args
'Range loop
153 Len
:= Len
+ Args
(J
)'Length + 1; -- One extra for ASCII.NUL
159 -----------------------------
160 -- Argument_String_To_List --
161 -----------------------------
163 function Argument_String_To_List
164 (Arg_String
: String) return Argument_List_Access
166 Max_Args
: constant Integer := Arg_String
'Length;
167 New_Argv
: Argument_List
(1 .. Max_Args
);
168 New_Argc
: Natural := 0;
172 Idx
:= Arg_String
'First;
175 exit when Idx
> Arg_String
'Last;
178 Quoted
: Boolean := False;
179 Backqd
: Boolean := False;
186 -- An unquoted space is the end of an argument
188 if not (Backqd
or Quoted
)
189 and then Arg_String
(Idx
) = ' '
193 -- Start of a quoted string
195 elsif not (Backqd
or Quoted
)
196 and then Arg_String
(Idx
) = '"'
200 -- End of a quoted string and end of an argument
202 elsif (Quoted
and not Backqd
)
203 and then Arg_String
(Idx
) = '"'
208 -- Following character is backquoted
210 elsif Arg_String
(Idx
) = '\' then
213 -- Turn off backquoting after advancing one character
221 exit when Idx
> Arg_String
'Last;
226 New_Argc
:= New_Argc
+ 1;
227 New_Argv
(New_Argc
) :=
228 new String'(Arg_String (Old_Idx .. Idx - 1));
230 -- Skip extraneous spaces
232 while Idx <= Arg_String'Last and then Arg_String (Idx) = ' ' loop
238 return new Argument_List'(New_Argv
(1 .. New_Argc
));
239 end Argument_String_To_List
;
241 ---------------------
242 -- C_String_Length --
243 ---------------------
245 function C_String_Length
(S
: Address
) return Integer is
246 function Strlen
(S
: Address
) return Integer;
247 pragma Import
(C
, Strlen
, "strlen");
249 if S
= Null_Address
then
260 procedure Close
(FD
: File_Descriptor
) is
261 procedure C_Close
(FD
: File_Descriptor
);
262 pragma Import
(C
, C_Close
, "close");
267 procedure Close
(FD
: File_Descriptor
; Status
: out Boolean) is
268 function C_Close
(FD
: File_Descriptor
) return Integer;
269 pragma Import
(C
, C_Close
, "close");
271 Status
:= (C_Close
(FD
) = 0);
281 Success
: out Boolean;
282 Mode
: Copy_Mode
:= Copy
;
283 Preserve
: Attribute
:= Time_Stamps
)
285 From
: File_Descriptor
;
286 To
: File_Descriptor
;
288 Copy_Error
: exception;
289 -- Internal exception raised to signal error in copy
291 function Build_Path
(Dir
: String; File
: String) return String;
292 -- Returns pathname Dir catenated with File adding the directory
293 -- separator only if needed.
295 procedure Copy
(From
, To
: File_Descriptor
);
296 -- Read data from From and place them into To. In both cases the
297 -- operations uses the current file position. Raises Constraint_Error
298 -- if a problem occurs during the copy.
300 procedure Copy_To
(To_Name
: String);
301 -- Does a straight copy from source to designated destination file
307 function Build_Path
(Dir
: String; File
: String) return String is
308 Res
: String (1 .. Dir
'Length + File
'Length + 1);
310 Base_File_Ptr
: Integer;
311 -- The base file name is File (Base_File_Ptr + 1 .. File'Last)
313 function Is_Dirsep
(C
: Character) return Boolean;
314 pragma Inline
(Is_Dirsep
);
315 -- Returns True if C is a directory separator. On Windows we
316 -- handle both styles of directory separator.
322 function Is_Dirsep
(C
: Character) return Boolean is
324 return C
= Directory_Separator
or else C
= '/';
327 -- Start of processing for Build_Path
330 -- Find base file name
332 Base_File_Ptr
:= File
'Last;
333 while Base_File_Ptr
>= File
'First loop
334 exit when Is_Dirsep
(File
(Base_File_Ptr
));
335 Base_File_Ptr
:= Base_File_Ptr
- 1;
339 Base_File
: String renames
340 File
(Base_File_Ptr
+ 1 .. File
'Last);
343 Res
(1 .. Dir
'Length) := Dir
;
345 if Is_Dirsep
(Dir
(Dir
'Last)) then
346 Res
(Dir
'Length + 1 .. Dir
'Length + Base_File
'Length) :=
348 return Res
(1 .. Dir
'Length + Base_File
'Length);
351 Res
(Dir
'Length + 1) := Directory_Separator
;
352 Res
(Dir
'Length + 2 .. Dir
'Length + 1 + Base_File
'Length) :=
354 return Res
(1 .. Dir
'Length + 1 + Base_File
'Length);
363 procedure Copy
(From
, To
: File_Descriptor
) is
364 Buf_Size
: constant := 200_000
;
365 type Buf
is array (1 .. Buf_Size
) of Character;
366 type Buf_Ptr
is access Buf
;
372 Status_From
: Boolean;
374 -- Statuses for the calls to Close
376 procedure Free
is new Unchecked_Deallocation
(Buf
, Buf_Ptr
);
379 -- Check for invalid descriptors, making sure that we do not
380 -- accidentally leave an open file descriptor around.
382 if From
= Invalid_FD
then
383 if To
/= Invalid_FD
then
384 Close
(To
, Status_To
);
389 elsif To
= Invalid_FD
then
390 Close
(From
, Status_From
);
394 -- Allocate the buffer on the heap
399 R
:= Read
(From
, Buffer
(1)'Address, Buf_Size
);
401 -- For VMS, the buffer may not be full. So, we need to try again
402 -- until there is nothing to read.
406 W
:= Write
(To
, Buffer
(1)'Address, R
);
410 -- Problem writing data, could be a disk full. Close files
411 -- without worrying about status, since we are raising a
412 -- Copy_Error exception in any case.
414 Close
(From
, Status_From
);
415 Close
(To
, Status_To
);
423 Close
(From
, Status_From
);
424 Close
(To
, Status_To
);
428 if not (Status_From
and Status_To
) then
437 procedure Copy_To
(To_Name
: String) is
439 function Copy_Attributes
440 (From
, To
: System
.Address
;
441 Mode
: Integer) return Integer;
442 pragma Import
(C
, Copy_Attributes
, "__gnat_copy_attribs");
443 -- Mode = 0 - copy only time stamps.
444 -- Mode = 1 - copy time stamps and read/write/execute attributes
446 C_From
: String (1 .. Name
'Length + 1);
447 C_To
: String (1 .. To_Name
'Length + 1);
450 From
:= Open_Read
(Name
, Binary
);
451 To
:= Create_File
(To_Name
, Binary
);
456 C_From
(1 .. Name
'Length) := Name
;
457 C_From
(C_From
'Last) := ASCII
.Nul
;
459 C_To
(1 .. To_Name
'Length) := To_Name
;
460 C_To
(C_To
'Last) := ASCII
.Nul
;
465 if Copy_Attributes
(C_From
'Address, C_To
'Address, 0) = -1 then
470 if Copy_Attributes
(C_From
'Address, C_To
'Address, 1) = -1 then
480 -- Start of processing for Copy_File
485 -- The source file must exist
487 if not Is_Regular_File
(Name
) then
491 -- The source file exists
495 -- Copy case, target file must not exist
499 -- If the target file exists, we have an error
501 if Is_Regular_File
(Pathname
) then
504 -- Case of target is a directory
506 elsif Is_Directory
(Pathname
) then
508 Dest
: constant String := Build_Path
(Pathname
, Name
);
511 -- If target file exists, we have an error, else do copy
513 if Is_Regular_File
(Dest
) then
520 -- Case of normal copy to file (destination does not exist)
526 -- Overwrite case (destination file may or may not exist)
529 if Is_Directory
(Pathname
) then
530 Copy_To
(Build_Path
(Pathname
, Name
));
535 -- Append case (destination file may or may not exist)
539 -- Appending to existing file
541 if Is_Regular_File
(Pathname
) then
543 -- Append mode and destination file exists, append data at the
546 From
:= Open_Read
(Name
, Binary
);
547 To
:= Open_Read_Write
(Pathname
, Binary
);
548 Lseek
(To
, 0, Seek_End
);
552 -- Appending to directory, not allowed
554 elsif Is_Directory
(Pathname
) then
557 -- Appending when target file does not exist
564 -- All error cases are caught here
573 Pathname
: C_File_Name
;
574 Success
: out Boolean;
575 Mode
: Copy_Mode
:= Copy
;
576 Preserve
: Attribute
:= Time_Stamps
)
578 Ada_Name
: String_Access
:=
579 To_Path_String_Access
580 (Name
, C_String_Length
(Name
));
582 Ada_Pathname
: String_Access
:=
583 To_Path_String_Access
584 (Pathname
, C_String_Length
(Pathname
));
587 Copy_File
(Ada_Name
.all, Ada_Pathname
.all, Success
, Mode
, Preserve
);
592 ----------------------
593 -- Copy_Time_Stamps --
594 ----------------------
596 procedure Copy_Time_Stamps
(Source
, Dest
: String; Success
: out Boolean) is
598 function Copy_Attributes
599 (From
, To
: System
.Address
;
600 Mode
: Integer) return Integer;
601 pragma Import
(C
, Copy_Attributes
, "__gnat_copy_attribs");
602 -- Mode = 0 - copy only time stamps.
603 -- Mode = 1 - copy time stamps and read/write/execute attributes
606 if Is_Regular_File
(Source
) and then Is_Writable_File
(Dest
) then
608 C_Source
: String (1 .. Source
'Length + 1);
609 C_Dest
: String (1 .. Dest
'Length + 1);
611 C_Source
(1 .. Source
'Length) := Source
;
612 C_Source
(C_Source
'Last) := ASCII
.NUL
;
614 C_Dest
(1 .. Dest
'Length) := Dest
;
615 C_Dest
(C_Dest
'Last) := ASCII
.NUL
;
617 if Copy_Attributes
(C_Source
'Address, C_Dest
'Address, 0) = -1 then
627 end Copy_Time_Stamps
;
629 procedure Copy_Time_Stamps
630 (Source
, Dest
: C_File_Name
;
631 Success
: out Boolean)
633 Ada_Source
: String_Access
:=
634 To_Path_String_Access
635 (Source
, C_String_Length
(Source
));
637 Ada_Dest
: String_Access
:=
638 To_Path_String_Access
639 (Dest
, C_String_Length
(Dest
));
641 Copy_Time_Stamps
(Ada_Source
.all, Ada_Dest
.all, Success
);
644 end Copy_Time_Stamps
;
652 Fmode
: Mode
) return File_Descriptor
654 function C_Create_File
656 Fmode
: Mode
) return File_Descriptor
;
657 pragma Import
(C
, C_Create_File
, "__gnat_open_create");
660 return C_Create_File
(Name
, Fmode
);
665 Fmode
: Mode
) return File_Descriptor
667 C_Name
: String (1 .. Name
'Length + 1);
670 C_Name
(1 .. Name
'Length) := Name
;
671 C_Name
(C_Name
'Last) := ASCII
.NUL
;
672 return Create_File
(C_Name
(C_Name
'First)'Address, Fmode
);
675 ---------------------
676 -- Create_New_File --
677 ---------------------
679 function Create_New_File
681 Fmode
: Mode
) return File_Descriptor
683 function C_Create_New_File
685 Fmode
: Mode
) return File_Descriptor
;
686 pragma Import
(C
, C_Create_New_File
, "__gnat_open_new");
689 return C_Create_New_File
(Name
, Fmode
);
692 function Create_New_File
694 Fmode
: Mode
) return File_Descriptor
696 C_Name
: String (1 .. Name
'Length + 1);
699 C_Name
(1 .. Name
'Length) := Name
;
700 C_Name
(C_Name
'Last) := ASCII
.NUL
;
701 return Create_New_File
(C_Name
(C_Name
'First)'Address, Fmode
);
704 -----------------------------
705 -- Create_Output_Text_File --
706 -----------------------------
708 function Create_Output_Text_File
(Name
: String) return File_Descriptor
is
709 function C_Create_File
710 (Name
: C_File_Name
) return File_Descriptor
;
711 pragma Import
(C
, C_Create_File
, "__gnat_create_output_file");
713 C_Name
: String (1 .. Name
'Length + 1);
716 C_Name
(1 .. Name
'Length) := Name
;
717 C_Name
(C_Name
'Last) := ASCII
.NUL
;
718 return C_Create_File
(C_Name
(C_Name
'First)'Address);
719 end Create_Output_Text_File
;
721 ----------------------
722 -- Create_Temp_File --
723 ----------------------
725 procedure Create_Temp_File
726 (FD
: out File_Descriptor
;
727 Name
: out Temp_File_Name
)
729 function Open_New_Temp
730 (Name
: System
.Address
;
731 Fmode
: Mode
) return File_Descriptor
;
732 pragma Import
(C
, Open_New_Temp
, "__gnat_open_new_temp");
735 FD
:= Open_New_Temp
(Name
'Address, Binary
);
736 end Create_Temp_File
;
738 procedure Create_Temp_File
739 (FD
: out File_Descriptor
;
740 Name
: out String_Access
)
743 Attempts
: Natural := 0;
744 Current
: String (Current_Temp_File_Name
'Range);
747 -- Loop until a new temp file can be created
751 -- We need to protect global variable Current_Temp_File_Name
752 -- against concurrent access by different tasks.
756 -- Start at the last digit
758 Pos
:= Temp_File_Name_Last_Digit
;
762 -- Increment the digit by one
764 case Current_Temp_File_Name
(Pos
) is
766 Current_Temp_File_Name
(Pos
) :=
767 Character'Succ (Current_Temp_File_Name
(Pos
));
772 -- For 9, set the digit to 0 and go to the previous digit
774 Current_Temp_File_Name
(Pos
) := '0';
779 -- If it is not a digit, then there are no available
780 -- temp file names. Return Invalid_FD. There is almost
781 -- no that this code will be ever be executed, since
782 -- it would mean that there are one million temp files
783 -- in the same directory!
792 Current
:= Current_Temp_File_Name
;
794 -- We can now release the lock, because we are no longer
795 -- accessing Current_Temp_File_Name.
805 -- Attempt to create the file
807 FD
:= Create_New_File
(Current
, Binary
);
809 if FD
/= Invalid_FD
then
810 Name
:= new String'(Current);
814 if not Is_Regular_File (Current) then
816 -- If the file does not already exist and we are unable to create
817 -- it, we give up after Max_Attempts. Otherwise, we try again with
818 -- the next available file name.
820 Attempts := Attempts + 1;
822 if Attempts >= Max_Attempts then
829 end Create_Temp_File;
835 procedure Delete_File (Name : Address; Success : out Boolean) is
838 function unlink (A : Address) return Integer;
839 pragma Import (C, unlink, "unlink");
846 procedure Delete_File (Name : String; Success : out Boolean) is
847 C_Name : String (1 .. Name'Length + 1);
850 C_Name (1 .. Name'Length) := Name;
851 C_Name (C_Name'Last) := ASCII.NUL;
853 Delete_File (C_Name'Address, Success);
856 ---------------------
857 -- File_Time_Stamp --
858 ---------------------
860 function File_Time_Stamp (FD : File_Descriptor) return OS_Time is
861 function File_Time (FD : File_Descriptor) return OS_Time;
862 pragma Import (C, File_Time, "__gnat_file_time_fd");
864 return File_Time (FD);
867 function File_Time_Stamp (Name : C_File_Name) return OS_Time is
868 function File_Time (Name : Address) return OS_Time;
869 pragma Import (C, File_Time, "__gnat_file_time_name");
871 return File_Time (Name);
874 function File_Time_Stamp (Name : String) return OS_Time is
875 F_Name : String (1 .. Name'Length + 1);
877 F_Name (1 .. Name'Length) := Name;
878 F_Name (F_Name'Last) := ASCII.NUL;
879 return File_Time_Stamp (F_Name'Address);
882 ---------------------------
883 -- Get_Debuggable_Suffix --
884 ---------------------------
886 function Get_Debuggable_Suffix return String_Access is
887 procedure Get_Suffix_Ptr (Length, Ptr : Address);
888 pragma Import (C, Get_Suffix_Ptr, "__gnat_get_debuggable_suffix_ptr");
890 procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
891 pragma Import (C, Strncpy, "strncpy");
893 Suffix_Ptr : Address;
894 Suffix_Length : Integer;
895 Result : String_Access;
898 Get_Suffix_Ptr (Suffix_Length'Address, Suffix_Ptr'Address);
900 Result := new String (1 .. Suffix_Length);
902 if Suffix_Length > 0 then
903 Strncpy (Result.all'Address, Suffix_Ptr, Suffix_Length);
907 end Get_Debuggable_Suffix;
909 ---------------------------
910 -- Get_Executable_Suffix --
911 ---------------------------
913 function Get_Executable_Suffix return String_Access is
914 procedure Get_Suffix_Ptr (Length, Ptr : Address);
915 pragma Import (C, Get_Suffix_Ptr, "__gnat_get_executable_suffix_ptr");
917 procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
918 pragma Import (C, Strncpy, "strncpy");
920 Suffix_Ptr : Address;
921 Suffix_Length : Integer;
922 Result : String_Access;
925 Get_Suffix_Ptr (Suffix_Length'Address, Suffix_Ptr'Address);
927 Result := new String (1 .. Suffix_Length);
929 if Suffix_Length > 0 then
930 Strncpy (Result.all'Address, Suffix_Ptr, Suffix_Length);
934 end Get_Executable_Suffix;
936 -----------------------
937 -- Get_Object_Suffix --
938 -----------------------
940 function Get_Object_Suffix return String_Access is
941 procedure Get_Suffix_Ptr (Length, Ptr : Address);
942 pragma Import (C, Get_Suffix_Ptr, "__gnat_get_object_suffix_ptr");
944 procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
945 pragma Import (C, Strncpy, "strncpy");
947 Suffix_Ptr : Address;
948 Suffix_Length : Integer;
949 Result : String_Access;
952 Get_Suffix_Ptr (Suffix_Length'Address, Suffix_Ptr'Address);
954 Result := new String (1 .. Suffix_Length);
956 if Suffix_Length > 0 then
957 Strncpy (Result.all'Address, Suffix_Ptr, Suffix_Length);
961 end Get_Object_Suffix;
963 ----------------------------------
964 -- Get_Target_Debuggable_Suffix --
965 ----------------------------------
967 function Get_Target_Debuggable_Suffix return String_Access is
968 Target_Exec_Ext_Ptr : Address;
970 (C, Target_Exec_Ext_Ptr, "__gnat_target_debuggable_extension");
972 procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
973 pragma Import (C, Strncpy, "strncpy");
975 function Strlen (Cstring : Address) return Integer;
976 pragma Import (C, Strlen, "strlen");
978 Suffix_Length : Integer;
979 Result : String_Access;
982 Suffix_Length := Strlen (Target_Exec_Ext_Ptr);
984 Result := new String (1 .. Suffix_Length);
986 if Suffix_Length > 0 then
987 Strncpy (Result.all'Address, Target_Exec_Ext_Ptr, Suffix_Length);
991 end Get_Target_Debuggable_Suffix;
993 ----------------------------------
994 -- Get_Target_Executable_Suffix --
995 ----------------------------------
997 function Get_Target_Executable_Suffix return String_Access is
998 Target_Exec_Ext_Ptr : Address;
1000 (C, Target_Exec_Ext_Ptr, "__gnat_target_executable_extension");
1002 procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
1003 pragma Import (C, Strncpy, "strncpy");
1005 function Strlen (Cstring : Address) return Integer;
1006 pragma Import (C, Strlen, "strlen");
1008 Suffix_Length : Integer;
1009 Result : String_Access;
1012 Suffix_Length := Strlen (Target_Exec_Ext_Ptr);
1014 Result := new String (1 .. Suffix_Length);
1016 if Suffix_Length > 0 then
1017 Strncpy (Result.all'Address, Target_Exec_Ext_Ptr, Suffix_Length);
1021 end Get_Target_Executable_Suffix;
1023 ------------------------------
1024 -- Get_Target_Object_Suffix --
1025 ------------------------------
1027 function Get_Target_Object_Suffix return String_Access is
1028 Target_Object_Ext_Ptr : Address;
1030 (C, Target_Object_Ext_Ptr, "__gnat_target_object_extension");
1032 procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
1033 pragma Import (C, Strncpy, "strncpy");
1035 function Strlen (Cstring : Address) return Integer;
1036 pragma Import (C, Strlen, "strlen");
1038 Suffix_Length : Integer;
1039 Result : String_Access;
1042 Suffix_Length := Strlen (Target_Object_Ext_Ptr);
1044 Result := new String (1 .. Suffix_Length);
1046 if Suffix_Length > 0 then
1047 Strncpy (Result.all'Address, Target_Object_Ext_Ptr, Suffix_Length);
1051 end Get_Target_Object_Suffix;
1057 function Getenv (Name : String) return String_Access is
1058 procedure Get_Env_Value_Ptr (Name, Length, Ptr : Address);
1059 pragma Import (C, Get_Env_Value_Ptr, "__gnat_getenv");
1061 procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
1062 pragma Import (C, Strncpy, "strncpy");
1064 Env_Value_Ptr : aliased Address;
1065 Env_Value_Length : aliased Integer;
1066 F_Name : aliased String (1 .. Name'Length + 1);
1067 Result : String_Access;
1070 F_Name (1 .. Name'Length) := Name;
1071 F_Name (F_Name'Last) := ASCII.NUL;
1074 (F_Name'Address, Env_Value_Length'Address, Env_Value_Ptr'Address);
1076 Result := new String (1 .. Env_Value_Length);
1078 if Env_Value_Length > 0 then
1079 Strncpy (Result.all'Address, Env_Value_Ptr, Env_Value_Length);
1089 function GM_Day (Date : OS_Time) return Day_Type is
1098 GM_Split (Date, Y, Mo, D, H, Mn, S);
1106 function GM_Hour (Date : OS_Time) return Hour_Type is
1115 GM_Split (Date, Y, Mo, D, H, Mn, S);
1123 function GM_Minute (Date : OS_Time) return Minute_Type is
1132 GM_Split (Date, Y, Mo, D, H, Mn, S);
1140 function GM_Month (Date : OS_Time) return Month_Type is
1149 GM_Split (Date, Y, Mo, D, H, Mn, S);
1157 function GM_Second (Date : OS_Time) return Second_Type is
1166 GM_Split (Date, Y, Mo, D, H, Mn, S);
1176 Year : out Year_Type;
1177 Month : out Month_Type;
1179 Hour : out Hour_Type;
1180 Minute : out Minute_Type;
1181 Second : out Second_Type)
1183 procedure To_GM_Time
1184 (P_Time_T, P_Year, P_Month, P_Day, P_Hours, P_Mins, P_Secs : Address);
1185 pragma Import (C, To_GM_Time, "__gnat_to_gm_time");
1187 T : OS_Time := Date;
1196 -- Use the global lock because To_GM_Time is not thread safe
1198 Locked_Processing : begin
1201 (T'Address, Y'Address, Mo'Address, D'Address,
1202 H'Address, Mn'Address, S'Address);
1203 SSL.Unlock_Task.all;
1207 SSL.Unlock_Task.all;
1209 end Locked_Processing;
1223 function GM_Year (Date : OS_Time) return Year_Type is
1232 GM_Split (Date, Y, Mo, D, H, Mn, S);
1236 ----------------------
1237 -- Is_Absolute_Path --
1238 ----------------------
1240 function Is_Absolute_Path (Name : String) return Boolean is
1241 function Is_Absolute_Path
1243 Length : Integer) return Integer;
1244 pragma Import (C, Is_Absolute_Path, "__gnat_is_absolute_path");
1246 return Is_Absolute_Path (Name'Address, Name'Length) /= 0;
1247 end Is_Absolute_Path;
1253 function Is_Directory (Name : C_File_Name) return Boolean is
1254 function Is_Directory (Name : Address) return Integer;
1255 pragma Import (C, Is_Directory, "__gnat_is_directory");
1257 return Is_Directory (Name) /= 0;
1260 function Is_Directory (Name : String) return Boolean is
1261 F_Name : String (1 .. Name'Length + 1);
1263 F_Name (1 .. Name'Length) := Name;
1264 F_Name (F_Name'Last) := ASCII.NUL;
1265 return Is_Directory (F_Name'Address);
1268 ----------------------
1269 -- Is_Readable_File --
1270 ----------------------
1272 function Is_Readable_File (Name : C_File_Name) return Boolean is
1273 function Is_Readable_File (Name : Address) return Integer;
1274 pragma Import (C, Is_Readable_File, "__gnat_is_readable_file");
1276 return Is_Readable_File (Name) /= 0;
1277 end Is_Readable_File;
1279 function Is_Readable_File (Name : String) return Boolean is
1280 F_Name : String (1 .. Name'Length + 1);
1282 F_Name (1 .. Name'Length) := Name;
1283 F_Name (F_Name'Last) := ASCII.NUL;
1284 return Is_Readable_File (F_Name'Address);
1285 end Is_Readable_File;
1287 ---------------------
1288 -- Is_Regular_File --
1289 ---------------------
1291 function Is_Regular_File (Name : C_File_Name) return Boolean is
1292 function Is_Regular_File (Name : Address) return Integer;
1293 pragma Import (C, Is_Regular_File, "__gnat_is_regular_file");
1295 return Is_Regular_File (Name) /= 0;
1296 end Is_Regular_File;
1298 function Is_Regular_File (Name : String) return Boolean is
1299 F_Name : String (1 .. Name'Length + 1);
1301 F_Name (1 .. Name'Length) := Name;
1302 F_Name (F_Name'Last) := ASCII.NUL;
1303 return Is_Regular_File (F_Name'Address);
1304 end Is_Regular_File;
1306 ----------------------
1307 -- Is_Symbolic_Link --
1308 ----------------------
1310 function Is_Symbolic_Link (Name : C_File_Name) return Boolean is
1311 function Is_Symbolic_Link (Name : Address) return Integer;
1312 pragma Import (C, Is_Symbolic_Link, "__gnat_is_symbolic_link");
1314 return Is_Symbolic_Link (Name) /= 0;
1315 end Is_Symbolic_Link;
1317 function Is_Symbolic_Link (Name : String) return Boolean is
1318 F_Name : String (1 .. Name'Length + 1);
1320 F_Name (1 .. Name'Length) := Name;
1321 F_Name (F_Name'Last) := ASCII.NUL;
1322 return Is_Symbolic_Link (F_Name'Address);
1323 end Is_Symbolic_Link;
1325 ----------------------
1326 -- Is_Writable_File --
1327 ----------------------
1329 function Is_Writable_File (Name : C_File_Name) return Boolean is
1330 function Is_Writable_File (Name : Address) return Integer;
1331 pragma Import (C, Is_Writable_File, "__gnat_is_writable_file");
1333 return Is_Writable_File (Name) /= 0;
1334 end Is_Writable_File;
1336 function Is_Writable_File (Name : String) return Boolean is
1337 F_Name : String (1 .. Name'Length + 1);
1339 F_Name (1 .. Name'Length) := Name;
1340 F_Name (F_Name'Last) := ASCII.NUL;
1341 return Is_Writable_File (F_Name'Address);
1342 end Is_Writable_File;
1344 -------------------------
1345 -- Locate_Exec_On_Path --
1346 -------------------------
1348 function Locate_Exec_On_Path
1349 (Exec_Name : String) return String_Access
1351 function Locate_Exec_On_Path (C_Exec_Name : Address) return Address;
1352 pragma Import (C, Locate_Exec_On_Path, "__gnat_locate_exec_on_path");
1354 procedure Free (Ptr : System.Address);
1355 pragma Import (C, Free, "free");
1357 C_Exec_Name : String (1 .. Exec_Name'Length + 1);
1358 Path_Addr : Address;
1360 Result : String_Access;
1363 C_Exec_Name (1 .. Exec_Name'Length) := Exec_Name;
1364 C_Exec_Name (C_Exec_Name'Last) := ASCII.NUL;
1366 Path_Addr := Locate_Exec_On_Path (C_Exec_Name'Address);
1367 Path_Len := C_String_Length (Path_Addr);
1369 if Path_Len = 0 then
1373 Result := To_Path_String_Access (Path_Addr, Path_Len);
1376 -- Always return an absolute path name
1378 if not Is_Absolute_Path (Result.all) then
1380 Absolute_Path : constant String :=
1381 Normalize_Pathname (Result.all);
1384 Result := new String'(Absolute_Path
);
1390 end Locate_Exec_On_Path
;
1392 -------------------------
1393 -- Locate_Regular_File --
1394 -------------------------
1396 function Locate_Regular_File
1397 (File_Name
: C_File_Name
;
1398 Path
: C_File_Name
) return String_Access
1400 function Locate_Regular_File
1401 (C_File_Name
, Path_Val
: Address
) return Address
;
1402 pragma Import
(C
, Locate_Regular_File
, "__gnat_locate_regular_file");
1404 procedure Free
(Ptr
: System
.Address
);
1405 pragma Import
(C
, Free
, "free");
1407 Path_Addr
: Address
;
1409 Result
: String_Access
;
1412 Path_Addr
:= Locate_Regular_File
(File_Name
, Path
);
1413 Path_Len
:= C_String_Length
(Path_Addr
);
1415 if Path_Len
= 0 then
1418 Result
:= To_Path_String_Access
(Path_Addr
, Path_Len
);
1422 end Locate_Regular_File
;
1424 function Locate_Regular_File
1425 (File_Name
: String;
1426 Path
: String) return String_Access
1428 C_File_Name
: String (1 .. File_Name
'Length + 1);
1429 C_Path
: String (1 .. Path
'Length + 1);
1430 Result
: String_Access
;
1433 C_File_Name
(1 .. File_Name
'Length) := File_Name
;
1434 C_File_Name
(C_File_Name
'Last) := ASCII
.NUL
;
1436 C_Path
(1 .. Path
'Length) := Path
;
1437 C_Path
(C_Path
'Last) := ASCII
.NUL
;
1439 Result
:= Locate_Regular_File
(C_File_Name
'Address, C_Path
'Address);
1441 -- Always return an absolute path name
1443 if Result
/= null and then not Is_Absolute_Path
(Result
.all) then
1445 Absolute_Path
: constant String := Normalize_Pathname
(Result
.all);
1448 Result
:= new String'(Absolute_Path);
1453 end Locate_Regular_File;
1455 ------------------------
1456 -- Non_Blocking_Spawn --
1457 ------------------------
1459 function Non_Blocking_Spawn
1460 (Program_Name : String;
1461 Args : Argument_List) return Process_Id
1467 Spawn_Internal (Program_Name, Args, Junk, Pid, Blocking => False);
1469 end Non_Blocking_Spawn;
1471 function Non_Blocking_Spawn
1472 (Program_Name : String;
1473 Args : Argument_List;
1474 Output_File_Descriptor : File_Descriptor;
1475 Err_To_Out : Boolean := True) return Process_Id
1477 Saved_Output : File_Descriptor;
1478 Saved_Error : File_Descriptor := Invalid_FD; -- prevent warning
1482 if Output_File_Descriptor = Invalid_FD then
1486 -- Set standard output and, if specified, error to the temporary file
1488 Saved_Output := Dup (Standout);
1489 Dup2 (Output_File_Descriptor, Standout);
1492 Saved_Error := Dup (Standerr);
1493 Dup2 (Output_File_Descriptor, Standerr);
1496 -- Spawn the program
1498 Pid := Non_Blocking_Spawn (Program_Name, Args);
1500 -- Restore the standard output and error
1502 Dup2 (Saved_Output, Standout);
1505 Dup2 (Saved_Error, Standerr);
1508 -- And close the saved standard output and error file descriptors
1510 Close (Saved_Output);
1513 Close (Saved_Error);
1517 end Non_Blocking_Spawn;
1519 function Non_Blocking_Spawn
1520 (Program_Name : String;
1521 Args : Argument_List;
1522 Output_File : String;
1523 Err_To_Out : Boolean := True) return Process_Id
1525 Output_File_Descriptor : constant File_Descriptor :=
1526 Create_Output_Text_File (Output_File);
1527 Result : Process_Id;
1530 -- Do not attempt to spawn if the output file could not be created
1532 if Output_File_Descriptor = Invalid_FD then
1536 Result := Non_Blocking_Spawn
1537 (Program_Name, Args, Output_File_Descriptor, Err_To_Out);
1539 -- Close the file just created for the output, as the file descriptor
1540 -- cannot be used anywhere, being a local value. It is safe to do
1541 -- that, as the file descriptor has been duplicated to form
1542 -- standard output and error of the spawned process.
1544 Close (Output_File_Descriptor);
1548 end Non_Blocking_Spawn;
1550 -------------------------
1551 -- Normalize_Arguments --
1552 -------------------------
1554 procedure Normalize_Arguments (Args : in out Argument_List) is
1556 procedure Quote_Argument (Arg : in out String_Access);
1557 -- Add quote around argument if it contains spaces
1559 C_Argument_Needs_Quote : Integer;
1560 pragma Import (C, C_Argument_Needs_Quote, "__gnat_argument_needs_quote");
1561 Argument_Needs_Quote : constant Boolean := C_Argument_Needs_Quote /= 0;
1563 --------------------
1564 -- Quote_Argument --
1565 --------------------
1567 procedure Quote_Argument (Arg : in out String_Access) is
1568 Res : String (1 .. Arg'Length * 2);
1570 Quote_Needed : Boolean := False;
1573 if Arg (Arg'First) /= '"' or else Arg (Arg'Last) /= '"' then
1579 for K in Arg'Range loop
1583 if Arg (K) = '"' then
1587 Quote_Needed := True;
1589 elsif Arg (K) = ' ' then
1591 Quote_Needed := True;
1599 if Quote_Needed then
1601 -- If null terminated string, put the quote before
1603 if Res (J) = ASCII.Nul then
1606 Res (J) := ASCII.Nul;
1608 -- If argument is terminated by '\
', then double it. Otherwise
1609 -- the ending quote will be taken as-is. This is quite strange
1610 -- spawn behavior from Windows, but this is what we see!
1613 if Res (J) = '\
' then
1625 Old : String_Access := Arg;
1628 Arg := new String'(Res (1 .. J));
1636 -- Start of processing for Normalize_Arguments
1639 if Argument_Needs_Quote then
1640 for K in Args'Range loop
1641 if Args (K) /= null and then Args (K)'Length /= 0 then
1642 Quote_Argument (Args (K));
1646 end Normalize_Arguments;
1648 ------------------------
1649 -- Normalize_Pathname --
1650 ------------------------
1652 function Normalize_Pathname
1654 Directory : String := "";
1655 Resolve_Links : Boolean := True;
1656 Case_Sensitive : Boolean := True) return String
1659 pragma Import (C, Max_Path, "__gnat_max_path_len
");
1660 -- Maximum length of a path name
1662 procedure Get_Current_Dir
1663 (Dir : System.Address;
1664 Length : System.Address);
1665 pragma Import (C, Get_Current_Dir, "__gnat_get_current_dir
");
1667 Path_Buffer : String (1 .. Max_Path + Max_Path + 2);
1668 End_Path : Natural := 0;
1669 Link_Buffer : String (1 .. Max_Path + 2);
1675 Max_Iterations : constant := 500;
1677 function Get_File_Names_Case_Sensitive return Integer;
1679 (C, Get_File_Names_Case_Sensitive,
1680 "__gnat_get_file_names_case_sensitive
");
1682 Fold_To_Lower_Case : constant Boolean :=
1684 and then Get_File_Names_Case_Sensitive = 0;
1687 (Path : System.Address;
1688 Buf : System.Address;
1689 Bufsiz : Integer) return Integer;
1690 pragma Import (C, Readlink, "__gnat_readlink
");
1692 function To_Canonical_File_Spec
1693 (Host_File : System.Address) return System.Address;
1695 (C, To_Canonical_File_Spec, "__gnat_to_canonical_file_spec
");
1697 The_Name : String (1 .. Name'Length + 1);
1698 Canonical_File_Addr : System.Address;
1699 Canonical_File_Len : Integer;
1701 Need_To_Check_Drive_Letter : Boolean := False;
1702 -- Set to true if Name is an absolute path that starts with "//"
1704 function Strlen (S : System.Address) return Integer;
1705 pragma Import (C, Strlen, "strlen
");
1707 function Final_Value (S : String) return String;
1708 -- Make final adjustment to the returned string.
1709 -- To compensate for non standard path name in Interix,
1710 -- if S is "/x
" or starts with "/x
", where x is a capital
1711 -- letter 'A' to 'Z', add an additional '/' at the beginning
1712 -- so that the returned value starts with "//x
".
1714 function Get_Directory (Dir : String) return String;
1715 -- If Dir is not empty, return it, adding a directory separator
1716 -- if not already present, otherwise return current working directory
1717 -- with terminating directory separator.
1723 function Final_Value (S : String) return String is
1725 -- We may need to fold S to lower case, so we need a variable
1730 -- Interix has the non standard notion of disk drive
1731 -- indicated by two '/' followed by a capital letter
1732 -- 'A' .. 'Z'. One of the two '/' may have been removed
1733 -- by Normalize_Pathname. It has to be added again.
1734 -- For other OSes, this should not make no difference.
1736 if Need_To_Check_Drive_Letter
1737 and then S'Length >= 2
1738 and then S (S'First) = '/'
1739 and then S (S'First + 1) in 'A' .. 'Z'
1740 and then (S'Length = 2 or else S (S'First + 2) = '/')
1743 Result : String (1 .. S'Length + 1);
1747 Result (2 .. Result'Last) := S;
1748 Last := Result'Last;
1750 if Fold_To_Lower_Case then
1751 System.Case_Util.To_Lower (Result);
1754 -- Remove trailing directory separator, if any
1756 if Last > 1 and then
1757 (Result (Last) = '/' or else
1758 Result (Last) = Directory_Separator)
1763 return Result (1 .. Last);
1767 if Fold_To_Lower_Case then
1768 System.Case_Util.To_Lower (S1);
1771 -- Remove trailing directory separator, if any
1776 and then (S1 (Last) = '/'
1778 S1 (Last) = Directory_Separator)
1780 -- Special case for Windows: C:\
1783 and then S1 (1) /= Directory_Separator
1784 and then S1 (2) = ':'
1793 return S1 (1 .. Last);
1801 function Get_Directory (Dir : String) return String is
1803 -- Directory given, add directory separator if needed
1805 if Dir'Length > 0 then
1806 if Dir (Dir'Last) = Directory_Separator then
1810 Result : String (1 .. Dir'Length + 1);
1812 Result (1 .. Dir'Length) := Dir;
1813 Result (Result'Length) := Directory_Separator;
1818 -- Directory name not given, get current directory
1822 Buffer : String (1 .. Max_Path + 2);
1823 Path_Len : Natural := Max_Path;
1826 Get_Current_Dir (Buffer'Address, Path_Len'Address);
1828 if Buffer (Path_Len) /= Directory_Separator then
1829 Path_Len := Path_Len + 1;
1830 Buffer (Path_Len) := Directory_Separator;
1833 -- By default, the drive letter on Windows is in upper case
1835 if On_Windows and then Path_Len >= 2 and then
1838 System.Case_Util.To_Upper (Buffer (1 .. 1));
1841 return Buffer (1 .. Path_Len);
1846 Reference_Dir : constant String := Get_Directory (Directory);
1847 -- Current directory name specified
1849 -- Start of processing for Normalize_Pathname
1852 -- Special case, if name is null, then return null
1854 if Name'Length = 0 then
1858 -- First, convert VMS file spec to Unix file spec.
1859 -- If Name is not in VMS syntax, then this is equivalent
1860 -- to put Name at the begining of Path_Buffer.
1862 VMS_Conversion : begin
1863 The_Name (1 .. Name'Length) := Name;
1864 The_Name (The_Name'Last) := ASCII.NUL;
1866 Canonical_File_Addr := To_Canonical_File_Spec (The_Name'Address);
1867 Canonical_File_Len := Strlen (Canonical_File_Addr);
1869 -- If VMS syntax conversion has failed, return an empty string
1870 -- to indicate the failure.
1872 if Canonical_File_Len = 0 then
1877 subtype Path_String is String (1 .. Canonical_File_Len);
1878 type Path_String_Access is access Path_String;
1880 function Address_To_Access is new
1881 Unchecked_Conversion (Source => Address,
1882 Target => Path_String_Access);
1884 Path_Access : constant Path_String_Access :=
1885 Address_To_Access (Canonical_File_Addr);
1888 Path_Buffer (1 .. Canonical_File_Len) := Path_Access.all;
1889 End_Path := Canonical_File_Len;
1894 -- Replace all '/' by Directory Separators (this is for Windows)
1896 if Directory_Separator /= '/' then
1897 for Index in 1 .. End_Path loop
1898 if Path_Buffer (Index) = '/' then
1899 Path_Buffer (Index) := Directory_Separator;
1904 -- Resolve directory names for Windows (formerly also VMS)
1906 -- On VMS, if we have a Unix path such as /temp/..., and TEMP is a
1907 -- logical name, we must not try to resolve this logical name, because
1908 -- it may have multiple equivalences and if resolved we will only
1909 -- get the first one.
1911 -- On Windows, if we have an absolute path starting with a directory
1912 -- separator, we need to have the drive letter appended in front.
1914 -- On Windows, Get_Current_Dir will return a suitable directory
1915 -- name (path starting with a drive letter on Windows). So we take this
1916 -- drive letter and prepend it to the current path.
1919 and then Path_Buffer (1) = Directory_Separator
1920 and then Path_Buffer (2) /= Directory_Separator
1923 Cur_Dir : String := Get_Directory ("");
1924 -- Get the current directory to get the drive letter
1927 if Cur_Dir'Length > 2
1928 and then Cur_Dir (Cur_Dir'First + 1) = ':'
1930 Path_Buffer (3 .. End_Path + 2) := Path_Buffer (1 .. End_Path);
1931 Path_Buffer (1 .. 2) :=
1932 Cur_Dir (Cur_Dir'First .. Cur_Dir'First + 1);
1933 End_Path := End_Path + 2;
1938 -- Start the conversions
1940 -- If this is not finished after Max_Iterations, give up and return an
1943 for J in 1 .. Max_Iterations loop
1945 -- If we don't have an absolute pathname, prepend the directory
1949 and then not Is_Absolute_Path (Path_Buffer (1 .. End_Path))
1952 (Reference_Dir'Last + 1 .. Reference_Dir'Length + End_Path) :=
1953 Path_Buffer (1 .. End_Path);
1954 End_Path := Reference_Dir'Length + End_Path;
1955 Path_Buffer (1 .. Reference_Dir'Length) := Reference_Dir;
1956 Last := Reference_Dir'Length;
1959 -- If name starts with "//", we may have a drive letter on Interix
1961 if Last = 1 and then End_Path >= 3 then
1962 Need_To_Check_Drive_Letter := (Path_Buffer (1 .. 2)) = "//";
1968 -- Ensure that Windows network drives are kept, e.g: \\server\drive-c
1971 and then Directory_Separator = '\'
1972 and then Path_Buffer (1 .. 2) = "\\"
1977 -- If we have traversed the full pathname, return it
1979 if Start > End_Path then
1980 return Final_Value (Path_Buffer (1 .. End_Path));
1983 -- Remove duplicate directory separators
1985 while Path_Buffer (Start) = Directory_Separator loop
1986 if Start = End_Path then
1987 return Final_Value (Path_Buffer (1 .. End_Path - 1));
1990 Path_Buffer (Start .. End_Path - 1) :=
1991 Path_Buffer (Start + 1 .. End_Path);
1992 End_Path := End_Path - 1;
1996 -- Find the end of the current field: last character or the one
1997 -- preceding the next directory separator.
1999 while Finish < End_Path
2000 and then Path_Buffer (Finish + 1) /= Directory_Separator
2002 Finish := Finish + 1;
2007 if Start = Finish and then Path_Buffer (Start) = '.' then
2008 if Start = End_Path then
2010 return (1 => Directory_Separator);
2013 if Fold_To_Lower_Case then
2014 System.Case_Util.To_Lower (Path_Buffer (1 .. Last - 1));
2017 return Path_Buffer (1 .. Last - 1);
2022 Path_Buffer (Last + 1 .. End_Path - 2) :=
2023 Path_Buffer (Last + 3 .. End_Path);
2024 End_Path := End_Path - 2;
2027 -- Remove ".." fields
2029 elsif Finish = Start + 1
2030 and then Path_Buffer (Start .. Finish) = ".."
2035 exit when Start < 1 or else
2036 Path_Buffer (Start) = Directory_Separator;
2040 if Finish = End_Path then
2041 return (1 => Directory_Separator);
2044 Path_Buffer (1 .. End_Path - Finish) :=
2045 Path_Buffer (Finish + 1 .. End_Path);
2046 End_Path := End_Path - Finish;
2051 if Finish = End_Path then
2052 return Final_Value (Path_Buffer (1 .. Start - 1));
2055 Path_Buffer (Start + 1 .. Start + End_Path - Finish - 1) :=
2056 Path_Buffer (Finish + 2 .. End_Path);
2057 End_Path := Start + End_Path - Finish - 1;
2062 -- Check if current field is a symbolic link
2064 elsif Resolve_Links then
2066 Saved : constant Character := Path_Buffer (Finish + 1);
2069 Path_Buffer (Finish + 1) := ASCII.NUL;
2070 Status := Readlink (Path_Buffer'Address,
2071 Link_Buffer'Address,
2072 Link_Buffer'Length);
2073 Path_Buffer (Finish + 1) := Saved;
2076 -- Not a symbolic link, move to the next field, if any
2081 -- Replace symbolic link with its value
2084 if Is_Absolute_Path (Link_Buffer (1 .. Status)) then
2085 Path_Buffer (Status + 1 .. End_Path - (Finish - Status)) :=
2086 Path_Buffer (Finish + 1 .. End_Path);
2087 End_Path := End_Path - (Finish - Status);
2088 Path_Buffer (1 .. Status) := Link_Buffer (1 .. Status);
2093 (Last + Status + 1 .. End_Path - Finish + Last + Status) :=
2094 Path_Buffer (Finish + 1 .. End_Path);
2095 End_Path := End_Path - Finish + Last + Status;
2096 Path_Buffer (Last + 1 .. Last + Status) :=
2097 Link_Buffer (1 .. Status);
2106 -- Too many iterations: give up
2108 -- This can happen when there is a circularity in the symbolic links: A
2109 -- is a symbolic link for B, which itself is a symbolic link, and the
2110 -- target of B or of another symbolic link target of B is A. In this
2111 -- case, we return an empty string to indicate failure to resolve.
2114 end Normalize_Pathname;
2121 (Name : C_File_Name;
2122 Fmode : Mode) return File_Descriptor
2124 function C_Open_Read
2125 (Name : C_File_Name;
2126 Fmode : Mode) return File_Descriptor;
2127 pragma Import (C, C_Open_Read, "__gnat_open_read
");
2129 return C_Open_Read (Name, Fmode);
2134 Fmode : Mode) return File_Descriptor
2136 C_Name : String (1 .. Name'Length + 1);
2138 C_Name (1 .. Name'Length) := Name;
2139 C_Name (C_Name'Last) := ASCII.NUL;
2140 return Open_Read (C_Name (C_Name'First)'Address, Fmode);
2143 ---------------------
2144 -- Open_Read_Write --
2145 ---------------------
2147 function Open_Read_Write
2148 (Name : C_File_Name;
2149 Fmode : Mode) return File_Descriptor
2151 function C_Open_Read_Write
2152 (Name : C_File_Name;
2153 Fmode : Mode) return File_Descriptor;
2154 pragma Import (C, C_Open_Read_Write, "__gnat_open_rw
");
2156 return C_Open_Read_Write (Name, Fmode);
2157 end Open_Read_Write;
2159 function Open_Read_Write
2161 Fmode : Mode) return File_Descriptor
2163 C_Name : String (1 .. Name'Length + 1);
2165 C_Name (1 .. Name'Length) := Name;
2166 C_Name (C_Name'Last) := ASCII.NUL;
2167 return Open_Read_Write (C_Name (C_Name'First)'Address, Fmode);
2168 end Open_Read_Write;
2170 --------------------
2171 -- Pid_To_Integer --
2172 --------------------
2174 function Pid_To_Integer (Pid : Process_Id) return Integer is
2176 return Integer (Pid);
2184 (FD : File_Descriptor;
2186 N : Integer) return Integer
2189 return Integer (System.CRTL.read
2190 (System.CRTL.int (FD), System.CRTL.chars (A), System.CRTL.int (N)));
2197 procedure Rename_File
2198 (Old_Name : C_File_Name;
2199 New_Name : C_File_Name;
2200 Success : out Boolean)
2202 function rename (From, To : Address) return Integer;
2203 pragma Import (C, rename, "rename
");
2206 R := rename (Old_Name, New_Name);
2210 procedure Rename_File
2213 Success : out Boolean)
2215 C_Old_Name : String (1 .. Old_Name'Length + 1);
2216 C_New_Name : String (1 .. New_Name'Length + 1);
2218 C_Old_Name (1 .. Old_Name'Length) := Old_Name;
2219 C_Old_Name (C_Old_Name'Last) := ASCII.NUL;
2220 C_New_Name (1 .. New_Name'Length) := New_Name;
2221 C_New_Name (C_New_Name'Last) := ASCII.NUL;
2222 Rename_File (C_Old_Name'Address, C_New_Name'Address, Success);
2225 -----------------------
2226 -- Set_Close_On_Exec --
2227 -----------------------
2229 procedure Set_Close_On_Exec
2230 (FD : File_Descriptor;
2231 Close_On_Exec : Boolean;
2232 Status : out Boolean)
2234 function C_Set_Close_On_Exec
2235 (FD : File_Descriptor; Close_On_Exec : System.CRTL.int)
2236 return System.CRTL.int;
2237 pragma Import (C, C_Set_Close_On_Exec, "__gnat_set_close_on_exec
");
2239 Status := C_Set_Close_On_Exec (FD, Boolean'Pos (Close_On_Exec)) = 0;
2240 end Set_Close_On_Exec;
2242 --------------------
2243 -- Set_Executable --
2244 --------------------
2246 procedure Set_Executable (Name : String) is
2247 procedure C_Set_Executable (Name : C_File_Name);
2248 pragma Import (C, C_Set_Executable, "__gnat_set_executable
");
2249 C_Name : aliased String (Name'First .. Name'Last + 1);
2251 C_Name (Name'Range) := Name;
2252 C_Name (C_Name'Last) := ASCII.NUL;
2253 C_Set_Executable (C_Name (C_Name'First)'Address);
2256 --------------------
2258 --------------------
2260 procedure Set_Read_Only (Name : String) is
2261 procedure C_Set_Read_Only (Name : C_File_Name);
2262 pragma Import (C, C_Set_Read_Only, "__gnat_set_readonly
");
2263 C_Name : aliased String (Name'First .. Name'Last + 1);
2265 C_Name (Name'Range) := Name;
2266 C_Name (C_Name'Last) := ASCII.NUL;
2267 C_Set_Read_Only (C_Name (C_Name'First)'Address);
2270 --------------------
2272 --------------------
2274 procedure Set_Writable (Name : String) is
2275 procedure C_Set_Writable (Name : C_File_Name);
2276 pragma Import (C, C_Set_Writable, "__gnat_set_writable
");
2277 C_Name : aliased String (Name'First .. Name'Last + 1);
2279 C_Name (Name'Range) := Name;
2280 C_Name (C_Name'Last) := ASCII.NUL;
2281 C_Set_Writable (C_Name (C_Name'First)'Address);
2288 procedure Setenv (Name : String; Value : String) is
2289 F_Name : String (1 .. Name'Length + 1);
2290 F_Value : String (1 .. Value'Length + 1);
2292 procedure Set_Env_Value (Name, Value : System.Address);
2293 pragma Import (C, Set_Env_Value, "__gnat_setenv
");
2296 F_Name (1 .. Name'Length) := Name;
2297 F_Name (F_Name'Last) := ASCII.NUL;
2299 F_Value (1 .. Value'Length) := Value;
2300 F_Value (F_Value'Last) := ASCII.NUL;
2302 Set_Env_Value (F_Name'Address, F_Value'Address);
2310 (Program_Name : String;
2311 Args : Argument_List) return Integer
2316 Spawn_Internal (Program_Name, Args, Result, Junk, Blocking => True);
2321 (Program_Name : String;
2322 Args : Argument_List;
2323 Success : out Boolean)
2326 Success := (Spawn (Program_Name, Args) = 0);
2330 (Program_Name : String;
2331 Args : Argument_List;
2332 Output_File_Descriptor : File_Descriptor;
2333 Return_Code : out Integer;
2334 Err_To_Out : Boolean := True)
2336 Saved_Output : File_Descriptor;
2337 Saved_Error : File_Descriptor := Invalid_FD; -- prevent compiler warning
2340 -- Set standard output and error to the temporary file
2342 Saved_Output := Dup (Standout);
2343 Dup2 (Output_File_Descriptor, Standout);
2346 Saved_Error := Dup (Standerr);
2347 Dup2 (Output_File_Descriptor, Standerr);
2350 -- Spawn the program
2352 Return_Code := Spawn (Program_Name, Args);
2354 -- Restore the standard output and error
2356 Dup2 (Saved_Output, Standout);
2359 Dup2 (Saved_Error, Standerr);
2362 -- And close the saved standard output and error file descriptors
2364 Close (Saved_Output);
2367 Close (Saved_Error);
2372 (Program_Name : String;
2373 Args : Argument_List;
2374 Output_File : String;
2375 Success : out Boolean;
2376 Return_Code : out Integer;
2377 Err_To_Out : Boolean := True)
2379 FD : File_Descriptor;
2385 FD := Create_Output_Text_File (Output_File);
2387 if FD = Invalid_FD then
2392 Spawn (Program_Name, Args, FD, Return_Code, Err_To_Out);
2394 Close (FD, Success);
2397 --------------------
2398 -- Spawn_Internal --
2399 --------------------
2401 procedure Spawn_Internal
2402 (Program_Name : String;
2403 Args : Argument_List;
2404 Result : out Integer;
2405 Pid : out Process_Id;
2409 procedure Spawn (Args : Argument_List);
2410 -- Call Spawn with given argument list
2412 N_Args : Argument_List (Args'Range);
2413 -- Normalized arguments
2419 procedure Spawn (Args : Argument_List) is
2420 type Chars is array (Positive range <>) of aliased Character;
2421 type Char_Ptr is access constant Character;
2423 Command_Len : constant Positive := Program_Name'Length + 1
2424 + Args_Length (Args);
2425 Command_Last : Natural := 0;
2426 Command : aliased Chars (1 .. Command_Len);
2427 -- Command contains all characters of the Program_Name and Args, all
2428 -- terminated by ASCII.NUL characters
2430 Arg_List_Len : constant Positive := Args'Length + 2;
2431 Arg_List_Last : Natural := 0;
2432 Arg_List : aliased array (1 .. Arg_List_Len) of Char_Ptr;
2433 -- List with pointers to NUL-terminated strings of the Program_Name
2434 -- and the Args and terminated with a null pointer. We rely on the
2435 -- default initialization for the last null pointer.
2437 procedure Add_To_Command (S : String);
2438 -- Add S and a NUL character to Command, updating Last
2440 function Portable_Spawn (Args : Address) return Integer;
2441 pragma Import (C, Portable_Spawn, "__gnat_portable_spawn
");
2443 function Portable_No_Block_Spawn (Args : Address) return Process_Id;
2445 (C, Portable_No_Block_Spawn, "__gnat_portable_no_block_spawn
");
2447 --------------------
2448 -- Add_To_Command --
2449 --------------------
2451 procedure Add_To_Command (S : String) is
2452 First : constant Natural := Command_Last + 1;
2455 Command_Last := Command_Last + S'Length;
2457 -- Move characters one at a time, because Command has aliased
2460 -- But not volatile, so why is this necessary ???
2462 for J in S'Range loop
2463 Command (First + J - S'First) := S (J);
2466 Command_Last := Command_Last + 1;
2467 Command (Command_Last) := ASCII.NUL;
2469 Arg_List_Last := Arg_List_Last + 1;
2470 Arg_List (Arg_List_Last) := Command (First)'Access;
2473 -- Start of processing for Spawn
2476 Add_To_Command (Program_Name);
2478 for J in Args'Range loop
2479 Add_To_Command (Args (J).all);
2484 Result := Portable_Spawn (Arg_List'Address);
2486 Pid := Portable_No_Block_Spawn (Arg_List'Address);
2487 Result := Boolean'Pos (Pid /= Invalid_Pid);
2491 -- Start of processing for Spawn_Internal
2494 -- Copy arguments into a local structure
2496 for K in N_Args'Range loop
2497 N_Args (K) := new String'(Args (K).all);
2500 -- Normalize those arguments
2502 Normalize_Arguments (N_Args);
2504 -- Call spawn using the normalized arguments
2508 -- Free arguments list
2510 for K in N_Args'Range loop
2515 ---------------------------
2516 -- To_Path_String_Access --
2517 ---------------------------
2519 function To_Path_String_Access
2520 (Path_Addr : Address;
2521 Path_Len : Integer) return String_Access
2523 subtype Path_String is String (1 .. Path_Len);
2524 type Path_String_Access is access Path_String;
2526 function Address_To_Access is new
2527 Unchecked_Conversion (Source => Address,
2528 Target => Path_String_Access);
2530 Path_Access : constant Path_String_Access :=
2531 Address_To_Access (Path_Addr);
2533 Return_Val : String_Access;
2536 Return_Val := new String (1 .. Path_Len);
2538 for J in 1 .. Path_Len loop
2539 Return_Val (J) := Path_Access (J);
2543 end To_Path_String_Access;
2549 procedure Wait_Process (Pid : out Process_Id; Success : out Boolean) is
2552 function Portable_Wait (S : Address) return Process_Id;
2553 pragma Import (C, Portable_Wait, "__gnat_portable_wait
");
2556 Pid := Portable_Wait (Status'Address);
2557 Success := (Status = 0);
2565 (FD : File_Descriptor;
2567 N : Integer) return Integer
2570 return Integer (System.CRTL.write
2571 (System.CRTL.int (FD), System.CRTL.chars (A), System.CRTL.int (N)));