1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
5 -- S Y S T E M . O S _ L I B --
9 -- Copyright (C) 1995-2023, AdaCore --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. --
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
19 -- additional permissions described in the GCC Runtime Library Exception, --
20 -- version 3.1, as published by the Free Software Foundation. --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
30 ------------------------------------------------------------------------------
32 with Ada
.Unchecked_Conversion
;
33 with Ada
.Unchecked_Deallocation
;
34 with System
.Case_Util
;
36 with System
.Soft_Links
;
38 package body System
.OS_Lib
is
40 subtype size_t
is CRTL
.size_t
;
42 procedure Strncpy
(dest
, src
: System
.Address
; n
: size_t
)
45 -- Imported procedures Dup and Dup2 are used in procedures Spawn and
46 -- Non_Blocking_Spawn.
48 function Dup
(Fd
: File_Descriptor
) return File_Descriptor
;
49 pragma Import
(C
, Dup
, "__gnat_dup");
51 procedure Dup2
(Old_Fd
, New_Fd
: File_Descriptor
);
52 pragma Import
(C
, Dup2
, "__gnat_dup2");
54 function Copy_Attributes
55 (From
: System
.Address
;
57 Mode
: Integer) return Integer;
58 pragma Import
(C
, Copy_Attributes
, "__gnat_copy_attribs");
59 -- Mode = 0 - copy only time stamps.
60 -- Mode = 1 - copy time stamps and read/write/execute attributes
61 -- Mode = 2 - copy read/write/execute attributes
63 function Is_Dirsep
(C
: Character) return Boolean;
64 pragma Inline
(Is_Dirsep
);
65 -- Returns True if C is a directory separator. On Windows we
66 -- accept both \ and / as a directory separator.
68 On_Windows
: constant Boolean := Directory_Separator
= '\';
69 -- An indication that we are on Windows. Used in Normalize_Pathname, to
70 -- deal with drive letters in the beginning of absolute paths.
72 package SSL
renames System
.Soft_Links
;
74 -- The following are used by Create_Temp_File
76 First_Temp_File_Name
: constant String := "GNAT-TEMP-000000.TMP";
77 -- Used to initialize Current_Temp_File_Name and Temp_File_Name_Last_Digit
79 Current_Temp_File_Name
: String := First_Temp_File_Name
;
80 -- Name of the temp file last created
82 Temp_File_Name_Last_Digit
: constant Positive :=
83 First_Temp_File_Name
'Last - 4;
84 -- Position of the last digit in Current_Temp_File_Name
86 Max_Attempts
: constant := 100;
87 -- The maximum number of attempts to create a new temp file
89 -----------------------
90 -- Local Subprograms --
91 -----------------------
93 function Args_Length
(Args
: Argument_List
) return Natural;
94 -- Returns total number of characters needed to create a string of all Args
95 -- terminated by ASCII.NUL characters.
97 procedure Create_Temp_File_Internal
98 (FD
: out File_Descriptor
;
99 Name
: out String_Access
;
101 -- Internal routine to implement two Create_Temp_File routines. If Stdout
102 -- is set to True the created descriptor is stdout-compatible, otherwise
103 -- it might not be depending on the OS. The first two parameters are as
104 -- in Create_Temp_File.
106 function C_String_Length
(S
: Address
) return Integer;
107 -- Returns the length of C (null-terminated) string at S, or 0 for
110 procedure Spawn_Internal
111 (Program_Name
: String;
112 Args
: Argument_List
;
113 Result
: out Integer;
114 Pid
: out Process_Id
;
116 -- Internal routine to implement the two Spawn (blocking/non blocking)
117 -- routines. If Blocking is set to True then the spawn is blocking
118 -- otherwise it is non blocking. In this latter case the Pid contains the
119 -- process id number. The first three parameters are as in Spawn. Note that
120 -- Spawn_Internal normalizes the argument list before calling the low level
121 -- system spawn routines (see Normalize_Arguments).
123 -- Note: Normalize_Arguments is designed to do nothing if it is called more
124 -- than once, so calling Normalize_Arguments before calling one of the
125 -- spawn routines is fine.
127 function To_Path_String_Access
128 (Path_Addr
: Address
;
129 Path_Len
: Integer) return String_Access
;
130 -- Converts a C String to an Ada String. We could do this making use of
131 -- Interfaces.C.Strings but we prefer not to import that entire package
137 function Args_Length
(Args
: Argument_List
) return Natural is
141 for J
in Args
'Range loop
142 Len
:= Len
+ Args
(J
)'Length + 1; -- One extra for ASCII.NUL
148 -----------------------------
149 -- Argument_String_To_List --
150 -----------------------------
152 function Argument_String_To_List
153 (Arg_String
: String) return Argument_List_Access
155 Max_Args
: constant Integer := Arg_String
'Length;
157 Backslash_Is_Sep
: constant Boolean := Directory_Separator
= '\';
158 -- Whether '\' is a directory separator (as on Windows), or a way to
159 -- quote special characters.
161 Backqd
: Boolean := False;
163 New_Argc
: Natural := 0;
164 New_Argv
: Argument_List
(1 .. Max_Args
);
165 Quoted
: Boolean := False;
167 Cleaned
: String (1 .. Arg_String
'Length);
168 Cleaned_Idx
: Natural;
169 -- A cleaned up version of the argument. This function is taking
170 -- backslash escapes when computing the bounds for arguments. It
171 -- is then removing the extra backslashes from the argument.
174 Idx
:= Arg_String
'First;
177 -- Skip extraneous spaces
179 while Idx
<= Arg_String
'Last and then Arg_String
(Idx
) = ' ' loop
183 exit when Idx
> Arg_String
'Last;
185 Cleaned_Idx
:= Cleaned
'First;
190 -- An unquoted space is the end of an argument
192 if not (Backqd
or Quoted
) and then Arg_String
(Idx
) = ' ' then
195 -- Start of a quoted string
197 elsif not (Backqd
or Quoted
) and then Arg_String
(Idx
) = '"' then
199 Cleaned
(Cleaned_Idx
) := Arg_String
(Idx
);
200 Cleaned_Idx
:= Cleaned_Idx
+ 1;
202 -- End of a quoted string and end of an argument
204 elsif (Quoted
and not Backqd
) and then Arg_String
(Idx
) = '"' then
205 Cleaned
(Cleaned_Idx
) := Arg_String
(Idx
);
206 Cleaned_Idx
:= Cleaned_Idx
+ 1;
210 -- Turn off backquoting after advancing one character
214 Cleaned
(Cleaned_Idx
) := Arg_String
(Idx
);
215 Cleaned_Idx
:= Cleaned_Idx
+ 1;
217 -- Following character is backquoted
219 elsif not Backslash_Is_Sep
and then Arg_String
(Idx
) = '\' then
223 Cleaned
(Cleaned_Idx
) := Arg_String
(Idx
);
224 Cleaned_Idx
:= Cleaned_Idx
+ 1;
228 exit when Idx
> Arg_String
'Last;
233 New_Argc
:= New_Argc
+ 1;
234 New_Argv
(New_Argc
) :=
235 new String'(Cleaned (Cleaned'First .. Cleaned_Idx - 1));
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
247 if S
= Null_Address
then
250 return Integer (CRTL
.strlen
(S
));
258 procedure Close
(FD
: File_Descriptor
) is
260 Discard
: constant int
:= close
(int
(FD
));
265 procedure Close
(FD
: File_Descriptor
; Status
: out Boolean) is
268 Status
:= (close
(int
(FD
)) = 0);
278 Success
: out Boolean;
279 Mode
: Copy_Mode
:= Copy
;
280 Preserve
: Attribute
:= Time_Stamps
)
282 From
: File_Descriptor
;
283 To
: File_Descriptor
;
285 Copy_Error
: exception;
286 -- Internal exception raised to signal error in copy
288 function Build_Path
(Dir
: String; File
: String) return String;
289 -- Returns pathname Dir concatenated with File adding the directory
290 -- separator only if needed.
292 procedure Copy
(From
: File_Descriptor
; To
: File_Descriptor
);
293 -- Read data from From and place them into To. In both cases the
294 -- operations uses the current file position. Raises Constraint_Error
295 -- if a problem occurs during the copy.
297 procedure Copy_To
(To_Name
: String);
298 -- Does a straight copy from source to designated destination file
304 function Build_Path
(Dir
: String; File
: String) return String is
305 Base_File_Ptr
: Integer;
306 -- The base file name is File (Base_File_Ptr + 1 .. File'Last)
308 Res
: String (1 .. Dir
'Length + File
'Length + 1);
310 -- Start of processing for Build_Path
313 -- Find base file name
315 Base_File_Ptr
:= File
'Last;
316 while Base_File_Ptr
>= File
'First loop
317 exit when Is_Dirsep
(File
(Base_File_Ptr
));
318 Base_File_Ptr
:= Base_File_Ptr
- 1;
322 Base_File
: String renames
323 File
(Base_File_Ptr
+ 1 .. File
'Last);
326 Res
(1 .. Dir
'Length) := Dir
;
328 if Is_Dirsep
(Dir
(Dir
'Last)) then
329 Res
(Dir
'Length + 1 .. Dir
'Length + Base_File
'Length) :=
331 return Res
(1 .. Dir
'Length + Base_File
'Length);
334 Res
(Dir
'Length + 1) := Directory_Separator
;
335 Res
(Dir
'Length + 2 .. Dir
'Length + 1 + Base_File
'Length) :=
337 return Res
(1 .. Dir
'Length + 1 + Base_File
'Length);
346 procedure Copy
(From
: File_Descriptor
; To
: File_Descriptor
) is
347 Buf_Size
: constant := 200_000
;
348 type Buf
is array (1 .. Buf_Size
) of Character;
349 type Buf_Ptr
is access Buf
;
355 Status_From
: Boolean;
357 -- Statuses for the calls to Close
359 procedure Free
is new Ada
.Unchecked_Deallocation
(Buf
, Buf_Ptr
);
362 -- Check for invalid descriptors, making sure that we do not
363 -- accidentally leave an open file descriptor around.
365 if From
= Invalid_FD
then
366 if To
/= Invalid_FD
then
367 Close
(To
, Status_To
);
372 elsif To
= Invalid_FD
then
373 Close
(From
, Status_From
);
377 -- Allocate the buffer on the heap
382 R
:= Read
(From
, Buffer
(1)'Address, Buf_Size
);
384 -- On some systems, the buffer may not be full. So, we need to try
385 -- again until there is nothing to read.
389 W
:= Write
(To
, Buffer
(1)'Address, R
);
393 -- Problem writing data, could be a disk full. Close files
394 -- without worrying about status, since we are raising a
395 -- Copy_Error exception in any case.
397 Close
(From
, Status_From
);
398 Close
(To
, Status_To
);
406 Close
(From
, Status_From
);
407 Close
(To
, Status_To
);
411 if not (Status_From
and Status_To
) then
420 procedure Copy_To
(To_Name
: String) is
421 C_From
: String (1 .. Name
'Length + 1);
422 C_To
: String (1 .. To_Name
'Length + 1);
425 From
:= Open_Read
(Name
, Binary
);
427 -- Do not clobber destination file if source file could not be opened
429 if From
/= Invalid_FD
then
430 To
:= Create_File
(To_Name
, Binary
);
437 C_From
(1 .. Name
'Length) := Name
;
438 C_From
(C_From
'Last) := ASCII
.NUL
;
440 C_To
(1 .. To_Name
'Length) := To_Name
;
441 C_To
(C_To
'Last) := ASCII
.NUL
;
445 if Copy_Attributes
(C_From
'Address, C_To
'Address, 0) = -1 then
450 if Copy_Attributes
(C_From
'Address, C_To
'Address, 1) = -1 then
459 -- Start of processing for Copy_File
464 -- The source file must exist
466 if not Is_Regular_File
(Name
) then
470 -- The source file exists
474 -- Copy case, target file must not exist
478 -- If the target file exists, we have an error
480 if Is_Regular_File
(Pathname
) then
483 -- Case of target is a directory
485 elsif Is_Directory
(Pathname
) then
487 Dest
: constant String := Build_Path
(Pathname
, Name
);
490 -- If target file exists, we have an error, else do copy
492 if Is_Regular_File
(Dest
) then
499 -- Case of normal copy to file (destination does not exist)
505 -- Overwrite case (destination file may or may not exist)
508 if Is_Directory
(Pathname
) then
509 Copy_To
(Build_Path
(Pathname
, Name
));
514 -- Append case (destination file may or may not exist)
518 -- Appending to existing file
520 if Is_Regular_File
(Pathname
) then
522 -- Append mode and destination file exists, append data at the
523 -- end of Pathname. But if we fail to open source file, do not
524 -- touch destination file at all.
526 From
:= Open_Read
(Name
, Binary
);
528 if From
= Invalid_FD
then
531 To
:= Open_Read_Write
(Pathname
, Binary
);
532 Lseek
(To
, 0, Seek_End
);
536 -- Appending to directory, not allowed
538 elsif Is_Directory
(Pathname
) then
541 -- Appending when target file does not exist
548 -- All error cases are caught here
557 Pathname
: C_File_Name
;
558 Success
: out Boolean;
559 Mode
: Copy_Mode
:= Copy
;
560 Preserve
: Attribute
:= Time_Stamps
)
562 Ada_Name
: String_Access
:=
563 To_Path_String_Access
564 (Name
, C_String_Length
(Name
));
565 Ada_Pathname
: String_Access
:=
566 To_Path_String_Access
567 (Pathname
, C_String_Length
(Pathname
));
570 Copy_File
(Ada_Name
.all, Ada_Pathname
.all, Success
, Mode
, Preserve
);
575 --------------------------
576 -- Copy_File_Attributes --
577 --------------------------
579 procedure Copy_File_Attributes
582 Success
: out Boolean;
583 Copy_Timestamp
: Boolean := True;
584 Copy_Permissions
: Boolean := True)
586 F
: aliased String (1 .. From
'Length + 1);
587 T
: aliased String (1 .. To
'Length + 1);
592 if Copy_Timestamp
then
593 if Copy_Permissions
then
599 if Copy_Permissions
then
603 return; -- nothing to do
607 F
(1 .. From
'Length) := From
;
608 F
(F
'Last) := ASCII
.NUL
;
610 T
(1 .. To
'Length) := To
;
611 T
(T
'Last) := ASCII
.NUL
;
613 Success
:= Copy_Attributes
(F
'Address, T
'Address, Mode
) /= -1;
614 end Copy_File_Attributes
;
616 ----------------------
617 -- Copy_Time_Stamps --
618 ----------------------
620 procedure Copy_Time_Stamps
623 Success
: out Boolean)
626 if Is_Regular_File
(Source
) and then Is_Writable_File
(Dest
) then
628 C_Source
: String (1 .. Source
'Length + 1);
629 C_Dest
: String (1 .. Dest
'Length + 1);
632 C_Source
(1 .. Source
'Length) := Source
;
633 C_Source
(C_Source
'Last) := ASCII
.NUL
;
635 C_Dest
(1 .. Dest
'Length) := Dest
;
636 C_Dest
(C_Dest
'Last) := ASCII
.NUL
;
638 if Copy_Attributes
(C_Source
'Address, C_Dest
'Address, 0) = -1 then
648 end Copy_Time_Stamps
;
650 procedure Copy_Time_Stamps
651 (Source
: C_File_Name
;
653 Success
: out Boolean)
655 Ada_Source
: String_Access
:=
656 To_Path_String_Access
657 (Source
, C_String_Length
(Source
));
658 Ada_Dest
: String_Access
:=
659 To_Path_String_Access
660 (Dest
, C_String_Length
(Dest
));
663 Copy_Time_Stamps
(Ada_Source
.all, Ada_Dest
.all, Success
);
666 end Copy_Time_Stamps
;
674 Fmode
: Mode
) return File_Descriptor
676 function C_Create_File
678 Fmode
: Mode
) return File_Descriptor
;
679 pragma Import
(C
, C_Create_File
, "__gnat_open_create");
681 return C_Create_File
(Name
, Fmode
);
686 Fmode
: Mode
) return File_Descriptor
688 C_Name
: String (1 .. Name
'Length + 1);
690 C_Name
(1 .. Name
'Length) := Name
;
691 C_Name
(C_Name
'Last) := ASCII
.NUL
;
692 return Create_File
(C_Name
(C_Name
'First)'Address, Fmode
);
695 ---------------------
696 -- Create_New_File --
697 ---------------------
699 function Create_New_File
701 Fmode
: Mode
) return File_Descriptor
703 function C_Create_New_File
705 Fmode
: Mode
) return File_Descriptor
;
706 pragma Import
(C
, C_Create_New_File
, "__gnat_open_new");
708 return C_Create_New_File
(Name
, Fmode
);
711 function Create_New_File
713 Fmode
: Mode
) return File_Descriptor
715 C_Name
: String (1 .. Name
'Length + 1);
717 C_Name
(1 .. Name
'Length) := Name
;
718 C_Name
(C_Name
'Last) := ASCII
.NUL
;
719 return Create_New_File
(C_Name
(C_Name
'First)'Address, Fmode
);
722 -----------------------------
723 -- Create_Output_Text_File --
724 -----------------------------
726 function Create_Output_Text_File
(Name
: String) return File_Descriptor
is
727 function C_Create_File
(Name
: C_File_Name
) return File_Descriptor
;
728 pragma Import
(C
, C_Create_File
, "__gnat_create_output_file");
730 C_Name
: String (1 .. Name
'Length + 1);
733 C_Name
(1 .. Name
'Length) := Name
;
734 C_Name
(C_Name
'Last) := ASCII
.NUL
;
735 return C_Create_File
(C_Name
(C_Name
'First)'Address);
736 end Create_Output_Text_File
;
738 ----------------------
739 -- Create_Temp_File --
740 ----------------------
742 procedure Create_Temp_File
743 (FD
: out File_Descriptor
;
744 Name
: out Temp_File_Name
)
746 function Open_New_Temp
747 (Name
: System
.Address
;
748 Fmode
: Mode
) return File_Descriptor
;
749 pragma Import
(C
, Open_New_Temp
, "__gnat_open_new_temp");
752 FD
:= Open_New_Temp
(Name
'Address, Binary
);
753 end Create_Temp_File
;
755 procedure Create_Temp_File
756 (FD
: out File_Descriptor
;
757 Name
: out String_Access
)
760 Create_Temp_File_Internal
(FD
, Name
, Stdout
=> False);
761 end Create_Temp_File
;
763 -----------------------------
764 -- Create_Temp_Output_File --
765 -----------------------------
767 procedure Create_Temp_Output_File
768 (FD
: out File_Descriptor
;
769 Name
: out String_Access
)
772 Create_Temp_File_Internal
(FD
, Name
, Stdout
=> True);
773 end Create_Temp_Output_File
;
775 -------------------------------
776 -- Create_Temp_File_Internal --
777 -------------------------------
779 procedure Create_Temp_File_Internal
780 (FD
: out File_Descriptor
;
781 Name
: out String_Access
;
785 Attempts
: Natural := 0;
786 Current
: String (Current_Temp_File_Name
'Range);
788 function Create_New_Output_Text_File
789 (Name
: String) return File_Descriptor
;
790 -- Similar to Create_Output_Text_File, except it fails if the file
791 -- already exists. We need this behavior to ensure we don't accidentally
792 -- open a temp file that has just been created by a concurrently running
793 -- process. There is no point exposing this function, as it's generally
794 -- not particularly useful.
796 ---------------------------------
797 -- Create_New_Output_Text_File --
798 ---------------------------------
800 function Create_New_Output_Text_File
801 (Name
: String) return File_Descriptor
803 function C_Create_File
(Name
: C_File_Name
) return File_Descriptor
;
804 pragma Import
(C
, C_Create_File
, "__gnat_create_output_file_new");
806 C_Name
: String (1 .. Name
'Length + 1);
809 C_Name
(1 .. Name
'Length) := Name
;
810 C_Name
(C_Name
'Last) := ASCII
.NUL
;
811 return C_Create_File
(C_Name
(C_Name
'First)'Address);
812 end Create_New_Output_Text_File
;
814 -- Start of processing for Create_Temp_File_Internal
817 -- Loop until a new temp file can be created
822 -- We need to protect global variable Current_Temp_File_Name
823 -- against concurrent access by different tasks.
827 -- Start at the last digit
829 Pos
:= Temp_File_Name_Last_Digit
;
833 -- Increment the digit by one
835 case Current_Temp_File_Name
(Pos
) is
837 Current_Temp_File_Name
(Pos
) :=
838 Character'Succ (Current_Temp_File_Name
(Pos
));
843 -- For 9, set the digit to 0 and go to the previous digit
845 Current_Temp_File_Name
(Pos
) := '0';
850 -- If it is not a digit, then there are no available
851 -- temp file names. Return Invalid_FD. There is almost no
852 -- chance that this code will be ever be executed, since
853 -- it would mean that there are one million temp files in
854 -- the same directory.
863 Current
:= Current_Temp_File_Name
;
865 -- We can now release the lock, because we are no longer accessing
866 -- Current_Temp_File_Name.
876 -- Attempt to create the file
879 FD
:= Create_New_Output_Text_File
(Current
);
881 FD
:= Create_New_File
(Current
, Binary
);
884 if FD
/= Invalid_FD
then
885 Name
:= new String'(Current);
889 if not Is_Regular_File (Current) then
891 -- If the file does not already exist and we are unable to create
892 -- it, we give up after Max_Attempts. Otherwise, we try again with
893 -- the next available file name.
895 Attempts := Attempts + 1;
897 if Attempts >= Max_Attempts then
904 end Create_Temp_File_Internal;
906 -------------------------
907 -- Current_Time_String --
908 -------------------------
910 function Current_Time_String return String is
911 subtype S23 is String (1 .. 23);
912 -- Holds current time in ISO 8601 format YYYY-MM-DD HH:MM:SS.SS + NUL
914 procedure Current_Time_String (Time : System.Address);
915 pragma Import (C, Current_Time_String, "__gnat_current_time_string");
916 -- Puts current time into Time in above ISO 8601 format
918 Result23 : aliased S23;
919 -- Current time in ISO 8601 format
922 Current_Time_String (Result23'Address);
923 return Result23 (1 .. 19);
924 end Current_Time_String;
930 procedure Delete_File (Name : Address; Success : out Boolean) is
933 R := System.CRTL.unlink (Name);
937 procedure Delete_File (Name : String; Success : out Boolean) is
938 C_Name : String (1 .. Name'Length + 1);
940 C_Name (1 .. Name'Length) := Name;
941 C_Name (C_Name'Last) := ASCII.NUL;
942 Delete_File (C_Name'Address, Success);
949 function Errno_Message
950 (Err : Integer := Errno;
951 Default : String := "") return String
953 function strerror (errnum : Integer) return System.Address;
954 pragma Import (C, strerror, "strerror");
956 C_Msg : constant System.Address := strerror (Err);
959 if C_Msg = Null_Address then
960 if Default /= "" then
964 -- Note: for bootstrap reasons, it is impractical
965 -- to use Integer'Image here.
971 Buf : String (1 .. 20);
972 -- Buffer large enough to hold image of largest Integer values
979 Character'Val (Character'Pos ('0') + Val mod 10);
990 return "errno = " & Buf (First .. Buf'Last);
996 Msg : String (1 .. Integer (CRTL.strlen (C_Msg)));
997 for Msg'Address use C_Msg;
998 pragma Import (Ada, Msg);
1005 ---------------------
1006 -- File_Time_Stamp --
1007 ---------------------
1009 function File_Time_Stamp (FD : File_Descriptor) return OS_Time is
1010 function File_Time (FD : File_Descriptor) return OS_Time;
1011 pragma Import (C, File_Time, "__gnat_file_time_fd");
1013 return File_Time (FD);
1014 end File_Time_Stamp;
1016 function File_Time_Stamp (Name : C_File_Name) return OS_Time is
1017 function File_Time (Name : Address) return OS_Time;
1018 pragma Import (C, File_Time, "__gnat_file_time_name");
1020 return File_Time (Name);
1021 end File_Time_Stamp;
1023 function File_Time_Stamp (Name : String) return OS_Time is
1024 F_Name : String (1 .. Name'Length + 1);
1026 F_Name (1 .. Name'Length) := Name;
1027 F_Name (F_Name'Last) := ASCII.NUL;
1028 return File_Time_Stamp (F_Name'Address);
1029 end File_Time_Stamp;
1031 ---------------------------
1032 -- Get_Debuggable_Suffix --
1033 ---------------------------
1035 function Get_Debuggable_Suffix return String_Access is
1036 procedure Get_Suffix_Ptr (Length, Ptr : Address);
1037 pragma Import (C, Get_Suffix_Ptr, "__gnat_get_debuggable_suffix_ptr");
1039 Result : String_Access;
1040 Suffix_Length : Integer;
1041 Suffix_Ptr : Address;
1044 Get_Suffix_Ptr (Suffix_Length'Address, Suffix_Ptr'Address);
1045 Result := new String (1 .. Suffix_Length);
1047 if Suffix_Length > 0 then
1048 Strncpy (Result.all'Address, Suffix_Ptr, size_t (Suffix_Length));
1052 end Get_Debuggable_Suffix;
1054 ---------------------------
1055 -- Get_Executable_Suffix --
1056 ---------------------------
1058 function Get_Executable_Suffix return String_Access is
1059 procedure Get_Suffix_Ptr (Length, Ptr : Address);
1060 pragma Import (C, Get_Suffix_Ptr, "__gnat_get_executable_suffix_ptr");
1062 Result : String_Access;
1063 Suffix_Length : Integer;
1064 Suffix_Ptr : Address;
1067 Get_Suffix_Ptr (Suffix_Length'Address, Suffix_Ptr'Address);
1068 Result := new String (1 .. Suffix_Length);
1070 if Suffix_Length > 0 then
1071 Strncpy (Result.all'Address, Suffix_Ptr, size_t (Suffix_Length));
1075 end Get_Executable_Suffix;
1077 -----------------------
1078 -- Get_Object_Suffix --
1079 -----------------------
1081 function Get_Object_Suffix return String_Access is
1082 procedure Get_Suffix_Ptr (Length, Ptr : Address);
1083 pragma Import (C, Get_Suffix_Ptr, "__gnat_get_object_suffix_ptr");
1085 Result : String_Access;
1086 Suffix_Length : Integer;
1087 Suffix_Ptr : Address;
1090 Get_Suffix_Ptr (Suffix_Length'Address, Suffix_Ptr'Address);
1091 Result := new String (1 .. Suffix_Length);
1093 if Suffix_Length > 0 then
1094 Strncpy (Result.all'Address, Suffix_Ptr, size_t (Suffix_Length));
1098 end Get_Object_Suffix;
1100 ----------------------------------
1101 -- Get_Target_Debuggable_Suffix --
1102 ----------------------------------
1104 function Get_Target_Debuggable_Suffix return String_Access is
1105 Target_Exec_Ext_Ptr : Address;
1107 (C, Target_Exec_Ext_Ptr, "__gnat_target_debuggable_extension");
1109 Result : String_Access;
1110 Suffix_Length : Integer;
1113 Suffix_Length := Integer (CRTL.strlen (Target_Exec_Ext_Ptr));
1114 Result := new String (1 .. Suffix_Length);
1116 if Suffix_Length > 0 then
1118 (Result.all'Address, Target_Exec_Ext_Ptr, size_t (Suffix_Length));
1122 end Get_Target_Debuggable_Suffix;
1124 ----------------------------------
1125 -- Get_Target_Executable_Suffix --
1126 ----------------------------------
1128 function Get_Target_Executable_Suffix return String_Access is
1129 Target_Exec_Ext_Ptr : Address;
1131 (C, Target_Exec_Ext_Ptr, "__gnat_target_executable_extension");
1133 Result : String_Access;
1134 Suffix_Length : Integer;
1137 Suffix_Length := Integer (CRTL.strlen (Target_Exec_Ext_Ptr));
1138 Result := new String (1 .. Suffix_Length);
1140 if Suffix_Length > 0 then
1142 (Result.all'Address, Target_Exec_Ext_Ptr, size_t (Suffix_Length));
1146 end Get_Target_Executable_Suffix;
1148 ------------------------------
1149 -- Get_Target_Object_Suffix --
1150 ------------------------------
1152 function Get_Target_Object_Suffix return String_Access is
1153 Target_Object_Ext_Ptr : Address;
1155 (C, Target_Object_Ext_Ptr, "__gnat_target_object_extension");
1157 Result : String_Access;
1158 Suffix_Length : Integer;
1161 Suffix_Length := Integer (CRTL.strlen (Target_Object_Ext_Ptr));
1162 Result := new String (1 .. Suffix_Length);
1164 if Suffix_Length > 0 then
1166 (Result.all'Address, Target_Object_Ext_Ptr, size_t (Suffix_Length));
1170 end Get_Target_Object_Suffix;
1176 function Getenv (Name : String) return String_Access is
1177 procedure Get_Env_Value_Ptr (Name, Length, Ptr : Address);
1178 pragma Import (C, Get_Env_Value_Ptr, "__gnat_getenv");
1180 Env_Value_Ptr : aliased Address;
1181 Env_Value_Length : aliased Integer;
1182 F_Name : aliased String (1 .. Name'Length + 1);
1183 Result : String_Access;
1186 F_Name (1 .. Name'Length) := Name;
1187 F_Name (F_Name'Last) := ASCII.NUL;
1190 (F_Name'Address, Env_Value_Length'Address, Env_Value_Ptr'Address);
1192 Result := new String (1 .. Env_Value_Length);
1194 if Env_Value_Length > 0 then
1196 (Result.all'Address, Env_Value_Ptr, size_t (Env_Value_Length));
1206 function GM_Day (Date : OS_Time) return Day_Type is
1216 GM_Split (Date, Y, Mo, D, H, Mn, S);
1224 function GM_Hour (Date : OS_Time) return Hour_Type is
1234 GM_Split (Date, Y, Mo, D, H, Mn, S);
1242 function GM_Minute (Date : OS_Time) return Minute_Type is
1252 GM_Split (Date, Y, Mo, D, H, Mn, S);
1260 function GM_Month (Date : OS_Time) return Month_Type is
1270 GM_Split (Date, Y, Mo, D, H, Mn, S);
1278 function GM_Second (Date : OS_Time) return Second_Type is
1288 GM_Split (Date, Y, Mo, D, H, Mn, S);
1298 Year : out Year_Type;
1299 Month : out Month_Type;
1301 Hour : out Hour_Type;
1302 Minute : out Minute_Type;
1303 Second : out Second_Type)
1305 procedure To_GM_Time
1306 (P_OS_Time : Address;
1313 pragma Import (C, To_GM_Time, "__gnat_to_gm_time");
1315 T : OS_Time := Date;
1324 -- Special case Invalid_Time which is handled differently between
1325 -- Windows and Linux: Linux will set to 1 second before 1970-01-01
1326 -- while Windows will set the time to 1970-01-01 with Second set to -1,
1327 -- which is not a valid value.
1329 if Date = Invalid_Time then
1339 -- Use the global lock because To_GM_Time is not thread safe
1341 Locked_Processing : begin
1344 (P_OS_Time => T'Address,
1345 P_Year => Y'Address,
1346 P_Month => Mo'Address,
1348 P_Hours => H'Address,
1349 P_Mins => Mn'Address,
1350 P_Secs => S'Address);
1351 SSL.Unlock_Task.all;
1355 SSL.Unlock_Task.all;
1357 end Locked_Processing;
1362 -- May happen if To_GM_Time fails
1384 Minute : Minute_Type;
1385 Second : Second_Type) return OS_Time
1387 procedure To_OS_Time
1388 (P_OS_Time : Address;
1395 pragma Import (C, To_OS_Time, "__gnat_to_os_time");
1401 (P_OS_Time => Result'Address,
1402 P_Year => Year - 1900,
1403 P_Month => Month - 1,
1415 function GM_Year (Date : OS_Time) return Year_Type is
1425 GM_Split (Date, Y, Mo, D, H, Mn, S);
1429 ----------------------
1430 -- Is_Absolute_Path --
1431 ----------------------
1433 function Is_Absolute_Path (Name : String) return Boolean is
1434 function Is_Absolute_Path
1436 Length : Integer) return Integer;
1437 pragma Import (C, Is_Absolute_Path, "__gnat_is_absolute_path");
1439 return Is_Absolute_Path (Name'Address, Name'Length) /= 0;
1440 end Is_Absolute_Path;
1446 function Is_Dirsep (C : Character) return Boolean is
1448 return C = Directory_Separator or else C = '/';
1455 function Is_Directory (Name : C_File_Name) return Boolean is
1456 function Is_Directory (Name : Address) return Integer;
1457 pragma Import (C, Is_Directory, "__gnat_is_directory");
1459 return Is_Directory (Name) /= 0;
1462 function Is_Directory (Name : String) return Boolean is
1463 F_Name : String (1 .. Name'Length + 1);
1465 F_Name (1 .. Name'Length) := Name;
1466 F_Name (F_Name'Last) := ASCII.NUL;
1467 return Is_Directory (F_Name'Address);
1470 -----------------------------
1471 -- Is_Read_Accessible_File --
1472 -----------------------------
1474 function Is_Read_Accessible_File (Name : String) return Boolean is
1475 function Is_Read_Accessible_File (Name : Address) return Integer;
1477 (C, Is_Read_Accessible_File, "__gnat_is_read_accessible_file");
1478 F_Name : String (1 .. Name'Length + 1);
1481 F_Name (1 .. Name'Length) := Name;
1482 F_Name (F_Name'Last) := ASCII.NUL;
1483 return Is_Read_Accessible_File (F_Name'Address) /= 0;
1484 end Is_Read_Accessible_File;
1486 ----------------------------
1487 -- Is_Owner_Readable_File --
1488 ----------------------------
1490 function Is_Owner_Readable_File (Name : C_File_Name) return Boolean is
1491 function Is_Readable_File (Name : Address) return Integer;
1492 pragma Import (C, Is_Readable_File, "__gnat_is_readable_file");
1494 return Is_Readable_File (Name) /= 0;
1495 end Is_Owner_Readable_File;
1497 function Is_Owner_Readable_File (Name : String) return Boolean is
1498 F_Name : String (1 .. Name'Length + 1);
1500 F_Name (1 .. Name'Length) := Name;
1501 F_Name (F_Name'Last) := ASCII.NUL;
1502 return Is_Owner_Readable_File (F_Name'Address);
1503 end Is_Owner_Readable_File;
1505 ------------------------
1506 -- Is_Executable_File --
1507 ------------------------
1509 function Is_Executable_File (Name : C_File_Name) return Boolean is
1510 function Is_Executable_File (Name : Address) return Integer;
1511 pragma Import (C, Is_Executable_File, "__gnat_is_executable_file");
1513 return Is_Executable_File (Name) /= 0;
1514 end Is_Executable_File;
1516 function Is_Executable_File (Name : String) return Boolean is
1517 F_Name : String (1 .. Name'Length + 1);
1519 F_Name (1 .. Name'Length) := Name;
1520 F_Name (F_Name'Last) := ASCII.NUL;
1521 return Is_Executable_File (F_Name'Address);
1522 end Is_Executable_File;
1524 ---------------------
1525 -- Is_Regular_File --
1526 ---------------------
1528 function Is_Regular_File (Name : C_File_Name) return Boolean is
1529 function Is_Regular_File (Name : Address) return Integer;
1530 pragma Import (C, Is_Regular_File, "__gnat_is_regular_file");
1532 return Is_Regular_File (Name) /= 0;
1533 end Is_Regular_File;
1535 function Is_Regular_File (Name : String) return Boolean is
1536 F_Name : String (1 .. Name'Length + 1);
1538 F_Name (1 .. Name'Length) := Name;
1539 F_Name (F_Name'Last) := ASCII.NUL;
1540 return Is_Regular_File (F_Name'Address);
1541 end Is_Regular_File;
1543 ----------------------
1544 -- Is_Symbolic_Link --
1545 ----------------------
1547 function Is_Symbolic_Link (Name : C_File_Name) return Boolean is
1548 function Is_Symbolic_Link (Name : Address) return Integer;
1549 pragma Import (C, Is_Symbolic_Link, "__gnat_is_symbolic_link");
1551 return Is_Symbolic_Link (Name) /= 0;
1552 end Is_Symbolic_Link;
1554 function Is_Symbolic_Link (Name : String) return Boolean is
1555 F_Name : String (1 .. Name'Length + 1);
1557 F_Name (1 .. Name'Length) := Name;
1558 F_Name (F_Name'Last) := ASCII.NUL;
1559 return Is_Symbolic_Link (F_Name'Address);
1560 end Is_Symbolic_Link;
1562 ------------------------------
1563 -- Is_Write_Accessible_File --
1564 ------------------------------
1566 function Is_Write_Accessible_File (Name : String) return Boolean is
1567 function Is_Write_Accessible_File (Name : Address) return Integer;
1569 (C, Is_Write_Accessible_File, "__gnat_is_write_accessible_file");
1570 F_Name : String (1 .. Name'Length + 1);
1573 F_Name (1 .. Name'Length) := Name;
1574 F_Name (F_Name'Last) := ASCII.NUL;
1575 return Is_Write_Accessible_File (F_Name'Address) /= 0;
1576 end Is_Write_Accessible_File;
1578 ----------------------------
1579 -- Is_Owner_Writable_File --
1580 ----------------------------
1582 function Is_Owner_Writable_File (Name : C_File_Name) return Boolean is
1583 function Is_Writable_File (Name : Address) return Integer;
1584 pragma Import (C, Is_Writable_File, "__gnat_is_writable_file");
1586 return Is_Writable_File (Name) /= 0;
1587 end Is_Owner_Writable_File;
1589 function Is_Owner_Writable_File (Name : String) return Boolean is
1590 F_Name : String (1 .. Name'Length + 1);
1592 F_Name (1 .. Name'Length) := Name;
1593 F_Name (F_Name'Last) := ASCII.NUL;
1594 return Is_Owner_Writable_File (F_Name'Address);
1595 end Is_Owner_Writable_File;
1601 procedure Kill (Pid : Process_Id; Hard_Kill : Boolean := True) is
1602 SIGKILL : constant := 9;
1603 SIGINT : constant := 2;
1605 procedure C_Kill (Pid : Process_Id; Sig_Num : Integer);
1606 pragma Import (C, C_Kill, "__gnat_kill");
1609 if Pid /= Invalid_Pid then
1611 C_Kill (Pid, SIGKILL);
1613 C_Kill (Pid, SIGINT);
1618 -----------------------
1619 -- Kill_Process_Tree --
1620 -----------------------
1622 procedure Kill_Process_Tree
1623 (Pid : Process_Id; Hard_Kill : Boolean := True)
1625 SIGKILL : constant := 9;
1626 SIGINT : constant := 2;
1628 procedure C_Kill_PT (Pid : Process_Id; Sig_Num : Integer);
1629 pragma Import (C, C_Kill_PT, "__gnat_killprocesstree");
1633 C_Kill_PT (Pid, SIGKILL);
1635 C_Kill_PT (Pid, SIGINT);
1637 end Kill_Process_Tree;
1639 -------------------------
1640 -- Locate_Exec_On_Path --
1641 -------------------------
1643 function Locate_Exec_On_Path
1644 (Exec_Name : String) return String_Access
1646 function Locate_Exec_On_Path (C_Exec_Name : Address) return Address;
1647 pragma Import (C, Locate_Exec_On_Path, "__gnat_locate_exec_on_path");
1649 C_Exec_Name : String (1 .. Exec_Name'Length + 1);
1650 Path_Addr : Address;
1652 Result : String_Access;
1655 C_Exec_Name (1 .. Exec_Name'Length) := Exec_Name;
1656 C_Exec_Name (C_Exec_Name'Last) := ASCII.NUL;
1658 Path_Addr := Locate_Exec_On_Path (C_Exec_Name'Address);
1659 Path_Len := C_String_Length (Path_Addr);
1661 if Path_Len = 0 then
1665 Result := To_Path_String_Access (Path_Addr, Path_Len);
1666 CRTL.free (Path_Addr);
1668 -- Always return an absolute path name
1670 if not Is_Absolute_Path (Result.all) then
1672 Absolute_Path : constant String :=
1673 Normalize_Pathname (Result.all, Resolve_Links => False);
1676 Result := new String'(Absolute_Path
);
1682 end Locate_Exec_On_Path
;
1684 -------------------------
1685 -- Locate_Regular_File --
1686 -------------------------
1688 function Locate_Regular_File
1689 (File_Name
: C_File_Name
;
1690 Path
: C_File_Name
) return String_Access
1692 function Locate_Regular_File
1693 (C_File_Name
, Path_Val
: Address
) return Address
;
1694 pragma Import
(C
, Locate_Regular_File
, "__gnat_locate_regular_file");
1696 Path_Addr
: Address
;
1698 Result
: String_Access
;
1701 Path_Addr
:= Locate_Regular_File
(File_Name
, Path
);
1702 Path_Len
:= C_String_Length
(Path_Addr
);
1704 if Path_Len
= 0 then
1708 Result
:= To_Path_String_Access
(Path_Addr
, Path_Len
);
1709 CRTL
.free
(Path_Addr
);
1712 end Locate_Regular_File
;
1714 function Locate_Regular_File
1715 (File_Name
: String;
1716 Path
: String) return String_Access
1718 C_File_Name
: String (1 .. File_Name
'Length + 1);
1719 C_Path
: String (1 .. Path
'Length + 1);
1720 Result
: String_Access
;
1723 C_File_Name
(1 .. File_Name
'Length) := File_Name
;
1724 C_File_Name
(C_File_Name
'Last) := ASCII
.NUL
;
1726 C_Path
(1 .. Path
'Length) := Path
;
1727 C_Path
(C_Path
'Last) := ASCII
.NUL
;
1729 Result
:= Locate_Regular_File
(C_File_Name
'Address, C_Path
'Address);
1731 -- Always return an absolute path name
1733 if Result
/= null and then not Is_Absolute_Path
(Result
.all) then
1735 Absolute_Path
: constant String := Normalize_Pathname
(Result
.all);
1738 Result
:= new String'(Absolute_Path);
1743 end Locate_Regular_File;
1745 ------------------------
1746 -- Non_Blocking_Spawn --
1747 ------------------------
1749 function Non_Blocking_Spawn
1750 (Program_Name : String;
1751 Args : Argument_List) return Process_Id
1754 pragma Warnings (Off, Junk);
1758 Spawn_Internal (Program_Name, Args, Junk, Pid, Blocking => False);
1760 end Non_Blocking_Spawn;
1762 function Non_Blocking_Spawn
1763 (Program_Name : String;
1764 Args : Argument_List;
1765 Output_File_Descriptor : File_Descriptor;
1766 Err_To_Out : Boolean := True) return Process_Id
1769 Saved_Error : File_Descriptor := Invalid_FD; -- prevent warning
1770 Saved_Output : File_Descriptor;
1773 if Output_File_Descriptor = Invalid_FD then
1777 -- Set standard output and, if specified, error to the temporary file
1779 Saved_Output := Dup (Standout);
1780 Dup2 (Output_File_Descriptor, Standout);
1783 Saved_Error := Dup (Standerr);
1784 Dup2 (Output_File_Descriptor, Standerr);
1787 -- Spawn the program
1789 Pid := Non_Blocking_Spawn (Program_Name, Args);
1791 -- Restore the standard output and error
1793 Dup2 (Saved_Output, Standout);
1796 Dup2 (Saved_Error, Standerr);
1799 -- And close the saved standard output and error file descriptors
1801 Close (Saved_Output);
1804 Close (Saved_Error);
1808 end Non_Blocking_Spawn;
1810 function Non_Blocking_Spawn
1811 (Program_Name : String;
1812 Args : Argument_List;
1813 Output_File : String;
1814 Err_To_Out : Boolean := True) return Process_Id
1816 Output_File_Descriptor : constant File_Descriptor :=
1817 Create_Output_Text_File (Output_File);
1818 Result : Process_Id;
1821 -- Do not attempt to spawn if the output file could not be created
1823 if Output_File_Descriptor = Invalid_FD then
1829 (Program_Name, Args, Output_File_Descriptor, Err_To_Out);
1831 -- Close the file just created for the output, as the file descriptor
1832 -- cannot be used anywhere, being a local value. It is safe to do
1833 -- that, as the file descriptor has been duplicated to form
1834 -- standard output and error of the spawned process.
1836 Close (Output_File_Descriptor);
1840 end Non_Blocking_Spawn;
1842 function Non_Blocking_Spawn
1843 (Program_Name : String;
1844 Args : Argument_List;
1845 Stdout_File : String;
1846 Stderr_File : String) return Process_Id
1848 Stderr_FD : constant File_Descriptor :=
1849 Create_Output_Text_File (Stderr_File);
1850 Stdout_FD : constant File_Descriptor :=
1851 Create_Output_Text_File (Stdout_File);
1853 Result : Process_Id;
1854 Saved_Error : File_Descriptor;
1855 Saved_Output : File_Descriptor;
1857 Dummy_Status : Boolean;
1860 -- Do not attempt to spawn if the output files could not be created
1862 if Stdout_FD = Invalid_FD or else Stderr_FD = Invalid_FD then
1866 -- Set standard output and error to the specified files
1868 Saved_Output := Dup (Standout);
1869 Dup2 (Stdout_FD, Standout);
1871 Saved_Error := Dup (Standerr);
1872 Dup2 (Stderr_FD, Standerr);
1874 Set_Close_On_Exec (Saved_Output, True, Dummy_Status);
1875 Set_Close_On_Exec (Saved_Error, True, Dummy_Status);
1877 -- Close the files just created for the output, as the file descriptors
1878 -- cannot be used anywhere, being local values. It is safe to do that,
1879 -- as the file descriptors have been duplicated to form standard output
1880 -- and standard error of the spawned process.
1885 -- Spawn the program
1887 Result := Non_Blocking_Spawn (Program_Name, Args);
1889 -- Restore the standard output and error
1891 Dup2 (Saved_Output, Standout);
1892 Dup2 (Saved_Error, Standerr);
1894 -- And close the saved standard output and error file descriptors
1896 Close (Saved_Output);
1897 Close (Saved_Error);
1900 end Non_Blocking_Spawn;
1902 -------------------------------
1903 -- Non_Blocking_Wait_Process --
1904 -------------------------------
1906 procedure Non_Blocking_Wait_Process
1907 (Pid : out Process_Id; Success : out Boolean)
1911 function Portable_No_Block_Wait (S : Address) return Process_Id;
1913 (C, Portable_No_Block_Wait, "__gnat_portable_no_block_wait");
1916 Pid := Portable_No_Block_Wait (Status'Address);
1917 Success := (Status = 0);
1922 end Non_Blocking_Wait_Process;
1924 -------------------------
1925 -- Normalize_Arguments --
1926 -------------------------
1928 procedure Normalize_Arguments (Args : in out Argument_List) is
1929 procedure Quote_Argument (Arg : in out String_Access);
1930 -- Add quote around argument if it contains spaces (or HT characters)
1932 C_Argument_Needs_Quote : Integer;
1933 pragma Import (C, C_Argument_Needs_Quote, "__gnat_argument_needs_quote");
1934 Argument_Needs_Quote : constant Boolean := C_Argument_Needs_Quote /= 0;
1936 --------------------
1937 -- Quote_Argument --
1938 --------------------
1940 procedure Quote_Argument (Arg : in out String_Access) is
1942 Quote_Needed : Boolean := False;
1943 Res : String (1 .. Arg'Length * 2 + 2);
1946 if Arg (Arg'First) /= '"' or else Arg (Arg'Last) /= '"' then
1952 for K in Arg'Range loop
1956 if Arg (K) = '"' then
1960 Quote_Needed := True;
1962 elsif Arg (K) = ' ' or else Arg (K) = ASCII.HT then
1964 Quote_Needed := True;
1971 if Quote_Needed then
1973 -- Case of null terminated string
1975 if Res (J) = ASCII.NUL then
1977 -- If the string ends with \, double it
1979 pragma Annotate (CodePeer, Modified, Res (J - 1));
1981 if Res (J - 1) = '\' then
1986 -- Put a quote just before the null at the end
1990 Res (J) := ASCII.NUL;
1992 -- If argument is terminated by '\
', then double it. Otherwise
1993 -- the ending quote will be taken as-is. This is quite strange
1994 -- spawn behavior from Windows, but this is what we see.
1997 if Res (J) = '\
' then
2009 Old : String_Access := Arg;
2012 Arg := new String'(Res (1 .. J));
2020 -- Start of processing for Normalize_Arguments
2023 if Argument_Needs_Quote then
2024 for K in Args'Range loop
2025 if Args (K) /= null and then Args (K)'Length /= 0 then
2026 Quote_Argument (Args (K));
2030 end Normalize_Arguments;
2032 ------------------------
2033 -- Normalize_Pathname --
2034 ------------------------
2036 function Normalize_Pathname
2038 Directory : String := "";
2039 Resolve_Links : Boolean := True;
2040 Case_Sensitive : Boolean := True) return String
2042 procedure Get_Current_Dir
2043 (Dir : System.Address;
2044 Length : System.Address);
2045 pragma Import (C, Get_Current_Dir, "__gnat_get_current_dir
");
2047 function Get_File_Names_Case_Sensitive return Integer;
2049 (C, Get_File_Names_Case_Sensitive,
2050 "__gnat_get_file_names_case_sensitive
");
2053 pragma Import (C, Max_Path, "__gnat_max_path_len
");
2054 -- Maximum length of a path name
2057 (Path : System.Address;
2058 Buf : System.Address;
2059 Bufsiz : size_t) return Integer;
2060 pragma Import (C, Readlink, "__gnat_readlink
");
2062 Fold_To_Lower_Case : constant Boolean :=
2064 and then Get_File_Names_Case_Sensitive = 0;
2066 Cur_Dir_Len : Natural := 0;
2067 End_Path : Natural := Name'Length;
2068 Last : Positive := 1;
2069 Path_Buffer : String (1 .. End_Path + 2 * Max_Path + 4);
2070 -- We need to potentially store in this buffer the following elements:
2071 -- the path itself, the current directory if the path is relative,
2072 -- and additional fragments up to Max_Path in length in case
2073 -- there are any symlinks.
2075 function Final_Value (S : String) return String;
2076 -- Make final adjustment to the returned string. This function strips
2077 -- trailing directory separators, and folds returned string to lower
2078 -- case if required.
2080 procedure Fill_Directory (Drive_Only : Boolean := False);
2081 -- Fill Cur_Dir and Cur_Dir_Len with Directory and ending directory
2082 -- separator or with current directory if Directory is not defined.
2083 -- If Drive_Only is True takes only Drive letter with colon and
2084 -- directory separator from Directory parameter or from current
2085 -- directory if Directory parameter is empty.
2087 function Is_With_Drive (Name : String) return Boolean;
2088 pragma Inline (Is_With_Drive);
2089 -- Returns True only if the Name is including a drive
2092 function Missed_Drive_Letter (Name : String) return Boolean;
2093 -- Missed drive letter at start of the normalized pathname
2099 function Is_With_Drive (Name : String) return Boolean is
2101 return Name'Length > 1
2102 and then Name (Name'First + 1) = ':'
2103 and then (Name (Name'First) in 'a' .. 'z'
2104 or else Name (Name'First) in 'A' .. 'Z');
2107 -------------------------
2108 -- Missed_Drive_Letter --
2109 -------------------------
2111 function Missed_Drive_Letter (Name : String) return Boolean is
2114 and then not Is_With_Drive (Name)
2115 and then (Name'Length < 2 -- not \\name case
2116 or else Name (Name'First)
2117 /= Directory_Separator
2118 or else Name (Name'First + 1)
2119 /= Directory_Separator);
2120 end Missed_Drive_Letter;
2126 function Final_Value (S : String) return String is
2128 -- We may need to fold S to lower case, so we need a variable
2133 if Fold_To_Lower_Case then
2134 System.Case_Util.To_Lower (S1);
2137 -- Remove trailing directory separator, if any
2141 if Last > 1 and then Is_Dirsep (S1 (Last))
2143 (On_Windows -- Special case for Windows: C:\
2145 and then S1 (1) /= Directory_Separator
2146 and then S1 (2) = ':')
2151 -- And ensure that there is a trailing directory separator if the
2152 -- path contains only a drive letter.
2156 and then S1 (1) /= Directory_Separator
2157 and then S1 (2) = ':'
2159 return S1 (1 .. Last) & Directory_Separator;
2161 return S1 (1 .. Last);
2165 --------------------
2166 -- Fill_Directory --
2167 --------------------
2169 procedure Fill_Directory (Drive_Only : Boolean := False) is
2171 if Drive_Only and then Is_With_Drive (Directory) then
2172 Path_Buffer (1 .. 3) :=
2173 Directory (Directory'First .. Directory'First + 2);
2175 elsif Directory = ""
2176 or else not Is_Absolute_Path (Directory)
2177 or else Missed_Drive_Letter (Directory)
2179 -- Directory name not given or it is not absolute or without drive
2180 -- letter on Windows, get current directory.
2182 Cur_Dir_Len := Max_Path;
2184 Get_Current_Dir (Path_Buffer'Address, Cur_Dir_Len'Address);
2186 if Cur_Dir_Len = 0 then
2187 raise Program_Error;
2190 if not Resolve_Links then
2191 Last := Cur_Dir_Len;
2194 if not Drive_Only and then Directory /= "" then
2195 if On_Windows and then Is_Absolute_Path (Directory) then
2196 -- Drive letter taken from current directory but directory
2197 -- itself taken from Directory parameter.
2199 Path_Buffer (3 .. Directory'Length + 2) := Directory;
2200 Cur_Dir_Len := Directory'Length + 2;
2204 -- Append relative Directory to current directory
2207 (Cur_Dir_Len + 1 .. Cur_Dir_Len + Directory'Length) :=
2209 Cur_Dir_Len := Cur_Dir_Len + Directory'Length;
2213 elsif Directory'Length >= Path_Buffer'Length then
2214 raise Constraint_Error with "Directory name to big
";
2217 Path_Buffer (1 .. Directory'Length) := Directory;
2218 Cur_Dir_Len := Directory'Length;
2222 -- When we need only drive letter from current directory on
2226 Last := Cur_Dir_Len;
2228 elsif not Is_Dirsep (Path_Buffer (Cur_Dir_Len)) then
2229 Cur_Dir_Len := Cur_Dir_Len + 1;
2230 Path_Buffer (Cur_Dir_Len) := Directory_Separator;
2236 Max_Iterations : constant := 500;
2238 Link_Buffer : String (1 .. Max_Path + 2);
2244 -- Start of processing for Normalize_Pathname
2247 -- Special case, return null if name is null
2249 if End_Path = 0 then
2253 if Is_Absolute_Path (Name) then
2254 if Missed_Drive_Letter (Name) then
2255 Fill_Directory (Drive_Only => True);
2257 -- Take only drive letter part with colon
2259 End_Path := End_Path + 2;
2260 Path_Buffer (3 .. End_Path) := Name;
2263 Path_Buffer (1 .. End_Path) := Name;
2267 -- If this is a relative pathname, prepend current directory
2269 Path_Buffer (Cur_Dir_Len + 1 .. Cur_Dir_Len + End_Path) := Name;
2270 End_Path := Cur_Dir_Len + End_Path;
2273 -- Special handling for Windows:
2274 -- * Replace all '/' by '\'
2275 -- * Check the drive letter
2276 -- * Remove all double-quotes
2279 -- Replace all '/' by '\'
2281 for Index in 1 .. End_Path loop
2282 if Path_Buffer (Index) = '/' then
2283 Path_Buffer (Index) := Directory_Separator;
2287 -- Ensure drive letter is upper-case
2289 pragma Assert (Path_Buffer (2) = ':');
2291 if Path_Buffer (1) in 'a' .. 'z' then
2292 System.Case_Util.To_Upper (Path_Buffer (1 .. 1));
2295 -- Remove all double-quotes that are possibly part of the
2296 -- path but can cause problems with other methods.
2302 Index := Path_Buffer'First;
2303 for Current in Path_Buffer'First .. End_Path loop
2304 if Path_Buffer (Current) /= '"' then
2305 Path_Buffer (Index) := Path_Buffer (Current);
2310 End_Path := Index - 1;
2314 -- Start the conversions
2316 -- If this is not finished after Max_Iterations, give up and return an
2319 for J in 1 .. Max_Iterations loop
2323 -- Ensure that Windows UNC path is preserved, e.g: \\server\drive-c
2326 and then Directory_Separator = '\
'
2327 and then Path_Buffer (1 .. 2) = "\\"
2332 -- If we have traversed the full pathname, return it
2334 if Start > End_Path then
2335 return Final_Value (Path_Buffer (1 .. End_Path));
2338 -- Remove duplicate directory separators
2340 while Path_Buffer (Start) = Directory_Separator loop
2341 if Start = End_Path then
2342 return Final_Value (Path_Buffer (1 .. End_Path - 1));
2345 Path_Buffer (Start .. End_Path - 1) :=
2346 Path_Buffer (Start + 1 .. End_Path);
2347 End_Path := End_Path - 1;
2351 -- Find the end of the current field: last character or the one
2352 -- preceding the next directory separator.
2354 while Finish < End_Path
2355 and then Path_Buffer (Finish + 1) /= Directory_Separator
2357 Finish := Finish + 1;
2362 if Start = Finish and then Path_Buffer (Start) = '.' then
2363 if Start = End_Path then
2365 return (1 => Directory_Separator);
2367 if Fold_To_Lower_Case then
2368 System.Case_Util.To_Lower (Path_Buffer (1 .. Last - 1));
2371 return Path_Buffer (1 .. Last - 1);
2375 Path_Buffer (Last + 1 .. End_Path - 2) :=
2376 Path_Buffer (Last + 3 .. End_Path);
2377 End_Path := End_Path - 2;
2380 -- Remove ".." fields
2382 elsif Finish = Start + 1
2383 and then Path_Buffer (Start .. Finish) = ".."
2389 and then Path_Buffer (Start) /= Directory_Separator
2399 if Finish = End_Path then
2400 return (1 => Directory_Separator);
2403 Path_Buffer (1 .. End_Path - Finish) :=
2404 Path_Buffer (Finish + 1 .. End_Path);
2405 End_Path := End_Path - Finish;
2410 if Finish = End_Path then
2411 return Final_Value (Path_Buffer (1 .. Start - 1));
2414 Path_Buffer (Start + 1 .. Start + End_Path - Finish - 1) :=
2415 Path_Buffer (Finish + 2 .. End_Path);
2416 End_Path := Start + End_Path - Finish - 1;
2421 -- Check if current field is a symbolic link
2423 elsif Resolve_Links then
2425 Saved : constant Character := Path_Buffer (Finish + 1);
2428 Path_Buffer (Finish + 1) := ASCII.NUL;
2431 (Path => Path_Buffer'Address,
2432 Buf => Link_Buffer'Address,
2433 Bufsiz => Link_Buffer'Length);
2434 Path_Buffer (Finish + 1) := Saved;
2437 -- Not a symbolic link, move to the next field, if any
2442 -- Replace symbolic link with its value
2445 if Is_Absolute_Path (Link_Buffer (1 .. Status)) then
2446 Path_Buffer (Status + 1 .. End_Path - (Finish - Status)) :=
2447 Path_Buffer (Finish + 1 .. End_Path);
2448 End_Path := End_Path - (Finish - Status);
2449 Path_Buffer (1 .. Status) := Link_Buffer (1 .. Status);
2454 (Last + Status + 1 .. End_Path - Finish + Last + Status) :=
2455 Path_Buffer (Finish + 1 .. End_Path);
2456 End_Path := End_Path - Finish + Last + Status;
2457 Path_Buffer (Last + 1 .. Last + Status) :=
2458 Link_Buffer (1 .. Status);
2467 -- Too many iterations: give up
2469 -- This can happen when there is a circularity in the symbolic links: A
2470 -- is a symbolic link for B, which itself is a symbolic link, and the
2471 -- target of B or of another symbolic link target of B is A. In this
2472 -- case, we return an empty string to indicate failure to resolve.
2475 end Normalize_Pathname;
2481 function Open_Append
2482 (Name : C_File_Name;
2483 Fmode : Mode) return File_Descriptor
2485 function C_Open_Append
2486 (Name : C_File_Name;
2487 Fmode : Mode) return File_Descriptor;
2488 pragma Import (C, C_Open_Append, "__gnat_open_append");
2490 return C_Open_Append (Name, Fmode);
2493 function Open_Append
2495 Fmode : Mode) return File_Descriptor
2497 C_Name : String (1 .. Name'Length + 1);
2499 C_Name (1 .. Name'Length) := Name;
2500 C_Name (C_Name'Last) := ASCII.NUL;
2501 return Open_Append (C_Name (C_Name'First)'Address, Fmode);
2509 (Name : C_File_Name;
2510 Fmode : Mode) return File_Descriptor
2512 function C_Open_Read
2513 (Name : C_File_Name;
2514 Fmode : Mode) return File_Descriptor;
2515 pragma Import (C, C_Open_Read, "__gnat_open_read");
2517 return C_Open_Read (Name, Fmode);
2522 Fmode : Mode) return File_Descriptor
2524 C_Name : String (1 .. Name'Length + 1);
2526 C_Name (1 .. Name'Length) := Name;
2527 C_Name (C_Name'Last) := ASCII.NUL;
2528 return Open_Read (C_Name (C_Name'First)'Address, Fmode);
2531 ---------------------
2532 -- Open_Read_Write --
2533 ---------------------
2535 function Open_Read_Write
2536 (Name : C_File_Name;
2537 Fmode : Mode) return File_Descriptor
2539 function C_Open_Read_Write
2540 (Name : C_File_Name;
2541 Fmode : Mode) return File_Descriptor;
2542 pragma Import (C, C_Open_Read_Write, "__gnat_open_rw");
2544 return C_Open_Read_Write (Name, Fmode);
2545 end Open_Read_Write;
2547 function Open_Read_Write
2549 Fmode : Mode) return File_Descriptor
2551 C_Name : String (1 .. Name'Length + 1);
2553 C_Name (1 .. Name'Length) := Name;
2554 C_Name (C_Name'Last) := ASCII.NUL;
2555 return Open_Read_Write (C_Name (C_Name'First)'Address, Fmode);
2556 end Open_Read_Write;
2562 procedure OS_Exit (Status : Integer) is
2564 OS_Exit_Ptr (Status);
2565 raise Program_Error;
2568 ---------------------
2569 -- OS_Exit_Default --
2570 ---------------------
2572 procedure OS_Exit_Default (Status : Integer) is
2573 procedure GNAT_OS_Exit (Status : Integer);
2574 pragma Import (C, GNAT_OS_Exit, "__gnat_os_exit");
2575 pragma No_Return (GNAT_OS_Exit);
2577 GNAT_OS_Exit (Status);
2578 end OS_Exit_Default;
2580 --------------------
2581 -- Pid_To_Integer --
2582 --------------------
2584 function Pid_To_Integer (Pid : Process_Id) return Integer is
2586 return Integer (Pid);
2594 (FD : File_Descriptor;
2596 N : Integer) return Integer
2600 Integer (System.CRTL.read
2601 (System.CRTL.int (FD),
2602 System.CRTL.chars (A),
2603 System.CRTL.size_t (N)));
2610 procedure Rename_File
2611 (Old_Name : C_File_Name;
2612 New_Name : C_File_Name;
2613 Success : out Boolean)
2615 function rename (From, To : Address) return Integer;
2616 pragma Import (C, rename, "__gnat_rename");
2620 R := rename (Old_Name, New_Name);
2624 procedure Rename_File
2627 Success : out Boolean)
2629 C_Old_Name : String (1 .. Old_Name'Length + 1);
2630 C_New_Name : String (1 .. New_Name'Length + 1);
2633 C_Old_Name (1 .. Old_Name'Length) := Old_Name;
2634 C_Old_Name (C_Old_Name'Last) := ASCII.NUL;
2635 C_New_Name (1 .. New_Name'Length) := New_Name;
2636 C_New_Name (C_New_Name'Last) := ASCII.NUL;
2637 Rename_File (C_Old_Name'Address, C_New_Name'Address, Success);
2640 -----------------------
2641 -- Set_Close_On_Exec --
2642 -----------------------
2644 procedure Set_Close_On_Exec
2645 (FD : File_Descriptor;
2646 Close_On_Exec : Boolean;
2647 Status : out Boolean)
2649 function C_Set_Close_On_Exec
2650 (FD : File_Descriptor; Close_On_Exec : System.CRTL.int)
2651 return System.CRTL.int;
2652 pragma Import (C, C_Set_Close_On_Exec, "__gnat_set_close_on_exec");
2654 Status := C_Set_Close_On_Exec (FD, Boolean'Pos (Close_On_Exec)) = 0;
2655 end Set_Close_On_Exec;
2657 --------------------
2658 -- Set_Executable --
2659 --------------------
2661 procedure Set_Executable (Name : String; Mode : Positive := S_Owner) is
2662 procedure C_Set_Executable (Name : C_File_Name; Mode : Integer);
2663 pragma Import (C, C_Set_Executable, "__gnat_set_executable");
2664 C_Name : aliased String (Name'First .. Name'Last + 1);
2667 C_Name (Name'Range) := Name;
2668 C_Name (C_Name'Last) := ASCII.NUL;
2669 C_Set_Executable (C_Name (C_Name'First)'Address, Mode);
2672 -------------------------------------
2673 -- Set_File_Last_Modify_Time_Stamp --
2674 -------------------------------------
2676 procedure Set_File_Last_Modify_Time_Stamp (Name : String; Time : OS_Time) is
2677 procedure C_Set_File_Time (Name : C_File_Name; Time : OS_Time);
2678 pragma Import (C, C_Set_File_Time, "__gnat_set_file_time_name");
2679 C_Name : aliased String (Name'First .. Name'Last + 1);
2682 C_Name (Name'Range) := Name;
2683 C_Name (C_Name'Last) := ASCII.NUL;
2684 C_Set_File_Time (C_Name'Address, Time);
2685 end Set_File_Last_Modify_Time_Stamp;
2687 ----------------------
2688 -- Set_Non_Readable --
2689 ----------------------
2691 procedure Set_Non_Readable (Name : String) is
2692 procedure C_Set_Non_Readable (Name : C_File_Name);
2693 pragma Import (C, C_Set_Non_Readable, "__gnat_set_non_readable");
2694 C_Name : aliased String (Name'First .. Name'Last + 1);
2697 C_Name (Name'Range) := Name;
2698 C_Name (C_Name'Last) := ASCII.NUL;
2699 C_Set_Non_Readable (C_Name (C_Name'First)'Address);
2700 end Set_Non_Readable;
2702 ----------------------
2703 -- Set_Non_Writable --
2704 ----------------------
2706 procedure Set_Non_Writable (Name : String) is
2707 procedure C_Set_Non_Writable (Name : C_File_Name);
2708 pragma Import (C, C_Set_Non_Writable, "__gnat_set_non_writable");
2709 C_Name : aliased String (Name'First .. Name'Last + 1);
2712 C_Name (Name'Range) := Name;
2713 C_Name (C_Name'Last) := ASCII.NUL;
2714 C_Set_Non_Writable (C_Name (C_Name'First)'Address);
2715 end Set_Non_Writable;
2721 procedure Set_Readable (Name : String) is
2722 procedure C_Set_Readable (Name : C_File_Name);
2723 pragma Import (C, C_Set_Readable, "__gnat_set_readable");
2724 C_Name : aliased String (Name'First .. Name'Last + 1);
2727 C_Name (Name'Range) := Name;
2728 C_Name (C_Name'Last) := ASCII.NUL;
2729 C_Set_Readable (C_Name (C_Name'First)'Address);
2732 --------------------
2734 --------------------
2736 procedure Set_Writable (Name : String) is
2737 procedure C_Set_Writable (Name : C_File_Name);
2738 pragma Import (C, C_Set_Writable, "__gnat_set_writable");
2739 C_Name : aliased String (Name'First .. Name'Last + 1);
2742 C_Name (Name'Range) := Name;
2743 C_Name (C_Name'Last) := ASCII.NUL;
2744 C_Set_Writable (C_Name (C_Name'First)'Address);
2751 procedure Setenv (Name : String; Value : String) is
2752 F_Name : String (1 .. Name'Length + 1);
2753 F_Value : String (1 .. Value'Length + 1);
2755 procedure Set_Env_Value (Name, Value : System.Address);
2756 pragma Import (C, Set_Env_Value, "__gnat_setenv");
2759 F_Name (1 .. Name'Length) := Name;
2760 F_Name (F_Name'Last) := ASCII.NUL;
2762 F_Value (1 .. Value'Length) := Value;
2763 F_Value (F_Value'Last) := ASCII.NUL;
2765 Set_Env_Value (F_Name'Address, F_Value'Address);
2773 (Program_Name : String;
2774 Args : Argument_List) return Integer
2777 pragma Warnings (Off, Junk);
2781 Spawn_Internal (Program_Name, Args, Result, Junk, Blocking => True);
2786 (Program_Name : String;
2787 Args : Argument_List;
2788 Success : out Boolean)
2791 Success := (Spawn (Program_Name, Args) = 0);
2795 (Program_Name : String;
2796 Args : Argument_List;
2797 Output_File_Descriptor : File_Descriptor;
2798 Return_Code : out Integer;
2799 Err_To_Out : Boolean := True)
2801 Saved_Error : File_Descriptor := Invalid_FD; -- prevent compiler warning
2802 Saved_Output : File_Descriptor;
2805 -- Set standard output and error to the temporary file
2807 Saved_Output := Dup (Standout);
2808 Dup2 (Output_File_Descriptor, Standout);
2811 Saved_Error := Dup (Standerr);
2812 Dup2 (Output_File_Descriptor, Standerr);
2815 -- Spawn the program
2817 Return_Code := Spawn (Program_Name, Args);
2819 -- Restore the standard output and error
2821 Dup2 (Saved_Output, Standout);
2824 Dup2 (Saved_Error, Standerr);
2827 -- And close the saved standard output and error file descriptors
2829 Close (Saved_Output);
2832 Close (Saved_Error);
2837 (Program_Name : String;
2838 Args : Argument_List;
2839 Output_File : String;
2840 Success : out Boolean;
2841 Return_Code : out Integer;
2842 Err_To_Out : Boolean := True)
2844 FD : File_Descriptor;
2850 FD := Create_Output_Text_File (Output_File);
2852 if FD = Invalid_FD then
2857 Spawn (Program_Name, Args, FD, Return_Code, Err_To_Out);
2859 Close (FD, Success);
2862 --------------------
2863 -- Spawn_Internal --
2864 --------------------
2866 procedure Spawn_Internal
2867 (Program_Name : String;
2868 Args : Argument_List;
2869 Result : out Integer;
2870 Pid : out Process_Id;
2873 procedure Spawn (Args : Argument_List);
2874 -- Call Spawn with given argument list
2876 N_Args : Argument_List (Args'Range);
2877 -- Normalized arguments
2883 procedure Spawn (Args : Argument_List) is
2884 type Chars is array (Positive range <>) of aliased Character;
2885 type Char_Ptr is access constant Character;
2887 Command_Len : constant Positive :=
2888 Program_Name'Length + 1 + Args_Length (Args);
2889 Command_Last : Natural := 0;
2890 Command : aliased Chars (1 .. Command_Len);
2891 -- Command contains all characters of the Program_Name and Args, all
2892 -- terminated by ASCII.NUL characters.
2894 Arg_List_Len : constant Positive := Args'Length + 2;
2895 Arg_List_Last : Natural := 0;
2896 Arg_List : aliased array (1 .. Arg_List_Len) of Char_Ptr;
2897 -- List with pointers to NUL-terminated strings of the Program_Name
2898 -- and the Args and terminated with a null pointer. We rely on the
2899 -- default initialization for the last null pointer.
2901 procedure Add_To_Command (S : String);
2902 -- Add S and a NUL character to Command, updating Last
2904 function Portable_Spawn (Args : Address) return Integer;
2905 pragma Import (C, Portable_Spawn, "__gnat_portable_spawn");
2907 function Portable_No_Block_Spawn (Args : Address) return Process_Id;
2909 (C, Portable_No_Block_Spawn, "__gnat_portable_no_block_spawn");
2911 --------------------
2912 -- Add_To_Command --
2913 --------------------
2915 procedure Add_To_Command (S : String) is
2916 First : constant Natural := Command_Last + 1;
2919 Command_Last := Command_Last + S'Length;
2921 -- Move characters one at a time, because Command has aliased
2924 -- But not volatile, so why is this necessary ???
2926 for J in S'Range loop
2927 Command (First + J - S'First) := S (J);
2930 Command_Last := Command_Last + 1;
2931 Command (Command_Last) := ASCII.NUL;
2933 Arg_List_Last := Arg_List_Last + 1;
2934 Arg_List (Arg_List_Last) := Command (First)'Access;
2937 -- Start of processing for Spawn
2940 Add_To_Command (Program_Name);
2942 for J in Args'Range loop
2943 Add_To_Command (Args (J).all);
2948 Result := Portable_Spawn (Arg_List'Address);
2950 Pid := Portable_No_Block_Spawn (Arg_List'Address);
2951 Result := Boolean'Pos (Pid /= Invalid_Pid);
2955 -- Start of processing for Spawn_Internal
2958 -- Copy arguments into a local structure
2960 for K in N_Args'Range loop
2961 N_Args (K) := new String'(Args
(K
).all);
2964 -- Normalize those arguments
2966 Normalize_Arguments
(N_Args
);
2968 -- Call spawn using the normalized arguments
2972 -- Free arguments list
2974 for K
in N_Args
'Range loop
2983 function To_Ada
(Time
: time_t
) return OS_Time
is
2985 return OS_Time
(Time
);
2988 ---------------------------
2989 -- To_Path_String_Access --
2990 ---------------------------
2992 function To_Path_String_Access
2993 (Path_Addr
: Address
;
2994 Path_Len
: Integer) return String_Access
2996 subtype Path_String
is String (1 .. Path_Len
);
2997 type Path_String_Access
is access Path_String
;
2999 function Address_To_Access
is new Ada
.Unchecked_Conversion
3000 (Source
=> Address
, Target
=> Path_String_Access
);
3002 Path_Access
: constant Path_String_Access
:=
3003 Address_To_Access
(Path_Addr
);
3005 Return_Val
: String_Access
;
3008 Return_Val
:= new String (1 .. Path_Len
);
3010 for J
in 1 .. Path_Len
loop
3011 Return_Val
(J
) := Path_Access
(J
);
3015 end To_Path_String_Access
;
3021 function To_C
(Time
: OS_Time
) return time_t
is
3023 return time_t
(Time
);
3030 procedure Wait_Process
(Pid
: out Process_Id
; Success
: out Boolean) is
3033 function Portable_Wait
(S
: Address
) return Process_Id
;
3034 pragma Import
(C
, Portable_Wait
, "__gnat_portable_wait");
3037 Pid
:= Portable_Wait
(Status
'Address);
3038 Success
:= (Status
= 0);
3046 (FD
: File_Descriptor
;
3048 N
: Integer) return Integer
3052 Integer (System
.CRTL
.write
3053 (System
.CRTL
.int
(FD
),
3054 System
.CRTL
.chars
(A
),
3055 System
.CRTL
.size_t
(N
)));