1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
5 -- G N A T . O S _ L I B --
9 -- Copyright (C) 1995-2003 Ada Core Technologies, Inc. --
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, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, 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
;
35 with System
.Soft_Links
;
36 with Unchecked_Conversion
;
37 with System
; use System
;
39 package body GNAT
.OS_Lib
is
41 package SSL
renames System
.Soft_Links
;
43 -- The following are used by Create_Temp_File
45 Current_Temp_File_Name
: String := "GNAT-TEMP-000000.TMP";
46 -- Name of the temp file last created
48 Temp_File_Name_Last_Digit
: constant Positive :=
49 Current_Temp_File_Name
'Last - 4;
50 -- Position of the last digit in Current_Temp_File_Name
52 Max_Attempts
: constant := 100;
53 -- The maximum number of attempts to create a new temp file
55 -----------------------
56 -- Local Subprograms --
57 -----------------------
59 function Args_Length
(Args
: Argument_List
) return Natural;
60 -- Returns total number of characters needed to create a string
61 -- of all Args terminated by ASCII.NUL characters
63 function C_String_Length
(S
: Address
) return Integer;
64 -- Returns the length of a C string. Does check for null address
67 procedure Spawn_Internal
68 (Program_Name
: String;
73 -- Internal routine to implement the two Spawn (blocking/non blocking)
74 -- routines. If Blocking is set to True then the spawn is blocking
75 -- otherwise it is non blocking. In this latter case the Pid contains
76 -- the process id number. The first three parameters are as in Spawn.
77 -- Note that Spawn_Internal normalizes the argument list before calling
78 -- the low level system spawn routines (see Normalize_Arguments). Note
79 -- that Normalize_Arguments is designed to do nothing if it is called
80 -- more than once, so calling Normalize_Arguments before calling one
81 -- of the spawn routines is fine.
83 function To_Path_String_Access
87 -- Converts a C String to an Ada String. We could do this making use of
88 -- Interfaces.C.Strings but we prefer not to import that entire package
94 function "<" (X
, Y
: OS_Time
) return Boolean is
96 return Long_Integer (X
) < Long_Integer (Y
);
103 function "<=" (X
, Y
: OS_Time
) return Boolean is
105 return Long_Integer (X
) <= Long_Integer (Y
);
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 Args_Length
(Args
: Argument_List
) return Natural is
134 for J
in Args
'Range loop
135 Len
:= Len
+ Args
(J
)'Length + 1; -- One extra for ASCII.NUL
141 -----------------------------
142 -- Argument_String_To_List --
143 -----------------------------
145 function Argument_String_To_List
146 (Arg_String
: String)
147 return Argument_List_Access
149 Max_Args
: constant Integer := Arg_String
'Length;
150 New_Argv
: Argument_List
(1 .. Max_Args
);
151 New_Argc
: Natural := 0;
155 Idx
:= Arg_String
'First;
158 exit when Idx
> Arg_String
'Last;
161 Quoted
: Boolean := False;
162 Backqd
: Boolean := False;
169 -- An unquoted space is the end of an argument
171 if not (Backqd
or Quoted
)
172 and then Arg_String
(Idx
) = ' '
176 -- Start of a quoted string
178 elsif not (Backqd
or Quoted
)
179 and then Arg_String
(Idx
) = '"'
183 -- End of a quoted string and end of an argument
185 elsif (Quoted
and not Backqd
)
186 and then Arg_String
(Idx
) = '"'
191 -- Following character is backquoted
193 elsif Arg_String
(Idx
) = '\' then
196 -- Turn off backquoting after advancing one character
204 exit when Idx
> Arg_String
'Last;
209 New_Argc
:= New_Argc
+ 1;
210 New_Argv
(New_Argc
) :=
211 new String'(Arg_String (Old_Idx .. Idx - 1));
213 -- Skip extraneous spaces
215 while Idx <= Arg_String'Last and then Arg_String (Idx) = ' ' loop
221 return new Argument_List'(New_Argv
(1 .. New_Argc
));
222 end Argument_String_To_List
;
224 ---------------------
225 -- C_String_Length --
226 ---------------------
228 function C_String_Length
(S
: Address
) return Integer is
230 function Strlen
(S
: Address
) return Integer;
231 pragma Import
(C
, Strlen
, "strlen");
234 if S
= Null_Address
then
245 procedure Close
(FD
: File_Descriptor
) is
246 procedure C_Close
(FD
: File_Descriptor
);
247 pragma Import
(C
, C_Close
, "close");
252 procedure Close
(FD
: File_Descriptor
; Status
: out Boolean) is
253 function C_Close
(FD
: File_Descriptor
) return Integer;
254 pragma Import
(C
, C_Close
, "close");
256 Status
:= (C_Close
(FD
) = 0);
266 Success
: out Boolean;
267 Mode
: Copy_Mode
:= Copy
;
268 Preserve
: Attribute
:= Time_Stamps
)
270 From
: File_Descriptor
;
271 To
: File_Descriptor
;
273 Copy_Error
: exception;
274 -- Internal exception raised to signal error in copy
276 function Build_Path
(Dir
: String; File
: String) return String;
277 -- Returns pathname Dir catenated with File adding the directory
278 -- separator only if needed.
280 procedure Copy
(From
, To
: File_Descriptor
);
281 -- Read data from From and place them into To. In both cases the
282 -- operations uses the current file position. Raises Constraint_Error
283 -- if a problem occurs during the copy.
285 procedure Copy_To
(To_Name
: String);
286 -- Does a straight copy from source to designated destination file
292 function Build_Path
(Dir
: String; File
: String) return String is
293 Res
: String (1 .. Dir
'Length + File
'Length + 1);
295 Base_File_Ptr
: Integer;
296 -- The base file name is File (Base_File_Ptr + 1 .. File'Last)
298 function Is_Dirsep
(C
: Character) return Boolean;
299 pragma Inline
(Is_Dirsep
);
300 -- Returns True if C is a directory separator. On Windows we
301 -- handle both styles of directory separator.
307 function Is_Dirsep
(C
: Character) return Boolean is
309 return C
= Directory_Separator
or else C
= '/';
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
, To
: File_Descriptor
) is
347 Buf_Size
: constant := 200_000
;
348 Buffer
: array (1 .. Buf_Size
) of Character;
352 Status_From
: Boolean;
354 -- Statuses for the calls to Close
357 if From
= Invalid_FD
or else To
= Invalid_FD
then
362 R
:= Read
(From
, Buffer
(1)'Address, Buf_Size
);
364 -- For VMS, the buffer may not be full. So, we need to try again
365 -- until there is nothing to read.
369 W
:= Write
(To
, Buffer
(1)'Address, R
);
373 -- Problem writing data, could be a disk full. Close files
374 -- without worrying about status, since we are raising a
375 -- Copy_Error exception in any case.
377 Close
(From
, Status_From
);
378 Close
(To
, Status_To
);
384 Close
(From
, Status_From
);
385 Close
(To
, Status_To
);
387 if not (Status_From
and Status_To
) then
396 procedure Copy_To
(To_Name
: String) is
398 function Copy_Attributes
399 (From
, To
: System
.Address
;
402 pragma Import
(C
, Copy_Attributes
, "__gnat_copy_attribs");
403 -- Mode = 0 - copy only time stamps.
404 -- Mode = 1 - copy time stamps and read/write/execute attributes
406 C_From
: String (1 .. Name
'Length + 1);
407 C_To
: String (1 .. To_Name
'Length + 1);
410 From
:= Open_Read
(Name
, Binary
);
411 To
:= Create_File
(To_Name
, Binary
);
416 C_From
(1 .. Name
'Length) := Name
;
417 C_From
(C_From
'Last) := ASCII
.Nul
;
419 C_To
(1 .. To_Name
'Length) := To_Name
;
420 C_To
(C_To
'Last) := ASCII
.Nul
;
425 if Copy_Attributes
(C_From
'Address, C_To
'Address, 0) = -1 then
430 if Copy_Attributes
(C_From
'Address, C_To
'Address, 1) = -1 then
440 -- Start of processing for Copy_File
445 -- The source file must exist
447 if not Is_Regular_File
(Name
) then
451 -- The source file exists
455 -- Copy case, target file must not exist
459 -- If the target file exists, we have an error
461 if Is_Regular_File
(Pathname
) then
464 -- Case of target is a directory
466 elsif Is_Directory
(Pathname
) then
468 Dest
: constant String := Build_Path
(Pathname
, Name
);
471 -- If the target file exists, we have an error
472 -- otherwise do the copy.
474 if Is_Regular_File
(Dest
) then
481 -- Case of normal copy to file (destination does not exist)
487 -- Overwrite case, destination file may or may not exist
490 if Is_Directory
(Pathname
) then
491 Copy_To
(Build_Path
(Pathname
, Name
));
496 -- Appending case, destination file may or may not exist
500 -- Appending to existing file
502 if Is_Regular_File
(Pathname
) then
504 -- Append mode and destination file exists, append data
505 -- at the end of Pathname.
507 From
:= Open_Read
(Name
, Binary
);
508 To
:= Open_Read_Write
(Pathname
, Binary
);
509 Lseek
(To
, 0, Seek_End
);
513 -- Appending to directory, not allowed
515 elsif Is_Directory
(Pathname
) then
518 -- Appending when target file does not exist
525 -- All error cases are caught here
534 Pathname
: C_File_Name
;
535 Success
: out Boolean;
536 Mode
: Copy_Mode
:= Copy
;
537 Preserve
: Attribute
:= Time_Stamps
)
539 Ada_Name
: String_Access
:=
540 To_Path_String_Access
541 (Name
, C_String_Length
(Name
));
543 Ada_Pathname
: String_Access
:=
544 To_Path_String_Access
545 (Pathname
, C_String_Length
(Pathname
));
548 Copy_File
(Ada_Name
.all, Ada_Pathname
.all, Success
, Mode
, Preserve
);
553 ----------------------
554 -- Copy_Time_Stamps --
555 ----------------------
557 procedure Copy_Time_Stamps
(Source
, Dest
: String; Success
: out Boolean) is
559 function Copy_Attributes
560 (From
, To
: System
.Address
;
563 pragma Import
(C
, Copy_Attributes
, "__gnat_copy_attribs");
564 -- Mode = 0 - copy only time stamps.
565 -- Mode = 1 - copy time stamps and read/write/execute attributes
568 if Is_Regular_File
(Source
) and then Is_Writable_File
(Dest
) then
570 C_Source
: String (1 .. Source
'Length + 1);
571 C_Dest
: String (1 .. Dest
'Length + 1);
573 C_Source
(1 .. C_Source
'Length) := Source
;
574 C_Source
(C_Source
'Last) := ASCII
.Nul
;
576 C_Dest
(1 .. C_Dest
'Length) := Dest
;
577 C_Dest
(C_Dest
'Last) := ASCII
.Nul
;
579 if Copy_Attributes
(C_Source
'Address, C_Dest
'Address, 0) = -1 then
589 end Copy_Time_Stamps
;
591 procedure Copy_Time_Stamps
592 (Source
, Dest
: C_File_Name
;
593 Success
: out Boolean)
595 Ada_Source
: String_Access
:=
596 To_Path_String_Access
597 (Source
, C_String_Length
(Source
));
599 Ada_Dest
: String_Access
:=
600 To_Path_String_Access
601 (Dest
, C_String_Length
(Dest
));
603 Copy_Time_Stamps
(Ada_Source
.all, Ada_Dest
.all, Success
);
606 end Copy_Time_Stamps
;
615 return File_Descriptor
617 function C_Create_File
620 return File_Descriptor
;
621 pragma Import
(C
, C_Create_File
, "__gnat_open_create");
624 return C_Create_File
(Name
, Fmode
);
630 return File_Descriptor
632 C_Name
: String (1 .. Name
'Length + 1);
635 C_Name
(1 .. Name
'Length) := Name
;
636 C_Name
(C_Name
'Last) := ASCII
.NUL
;
637 return Create_File
(C_Name
(C_Name
'First)'Address, Fmode
);
640 ---------------------
641 -- Create_New_File --
642 ---------------------
644 function Create_New_File
647 return File_Descriptor
649 function C_Create_New_File
652 return File_Descriptor
;
653 pragma Import
(C
, C_Create_New_File
, "__gnat_open_new");
656 return C_Create_New_File
(Name
, Fmode
);
659 function Create_New_File
662 return File_Descriptor
664 C_Name
: String (1 .. Name
'Length + 1);
667 C_Name
(1 .. Name
'Length) := Name
;
668 C_Name
(C_Name
'Last) := ASCII
.NUL
;
669 return Create_New_File
(C_Name
(C_Name
'First)'Address, Fmode
);
672 ----------------------
673 -- Create_Temp_File --
674 ----------------------
676 procedure Create_Temp_File
677 (FD
: out File_Descriptor
;
678 Name
: out Temp_File_Name
)
680 function Open_New_Temp
681 (Name
: System
.Address
;
683 return File_Descriptor
;
684 pragma Import
(C
, Open_New_Temp
, "__gnat_open_new_temp");
687 FD
:= Open_New_Temp
(Name
'Address, Binary
);
688 end Create_Temp_File
;
690 procedure Create_Temp_File
691 (FD
: out File_Descriptor
;
692 Name
: out String_Access
)
695 Attempts
: Natural := 0;
696 Current
: String (Current_Temp_File_Name
'Range);
699 -- Loop until a new temp file can be created
703 -- We need to protect global variable Current_Temp_File_Name
704 -- against concurrent access by different tasks.
708 -- Start at the last digit
710 Pos
:= Temp_File_Name_Last_Digit
;
714 -- Increment the digit by one
716 case Current_Temp_File_Name
(Pos
) is
718 Current_Temp_File_Name
(Pos
) :=
719 Character'Succ (Current_Temp_File_Name
(Pos
));
724 -- For 9, set the digit to 0 and go to the previous digit
726 Current_Temp_File_Name
(Pos
) := '0';
731 -- If it is not a digit, then there are no available
732 -- temp file names. Return Invalid_FD. There is almost
733 -- no that this code will be ever be executed, since
734 -- it would mean that there are one million temp files
735 -- in the same directory!
744 Current
:= Current_Temp_File_Name
;
746 -- We can now release the lock, because we are no longer
747 -- accessing Current_Temp_File_Name.
757 -- Attempt to create the file
759 FD
:= Create_New_File
(Current
, Binary
);
761 if FD
/= Invalid_FD
then
762 Name
:= new String'(Current);
766 if not Is_Regular_File (Current) then
768 -- If the file does not already exist and we are unable to create
769 -- it, we give up after Max_Attempts. Otherwise, we try again with
770 -- the next available file name.
772 Attempts := Attempts + 1;
774 if Attempts >= Max_Attempts then
781 end Create_Temp_File;
787 procedure Delete_File (Name : Address; Success : out Boolean) is
790 function unlink (A : Address) return Integer;
791 pragma Import (C, unlink, "unlink");
798 procedure Delete_File (Name : String; Success : out Boolean) is
799 C_Name : String (1 .. Name'Length + 1);
802 C_Name (1 .. Name'Length) := Name;
803 C_Name (C_Name'Last) := ASCII.NUL;
805 Delete_File (C_Name'Address, Success);
808 ---------------------
809 -- File_Time_Stamp --
810 ---------------------
812 function File_Time_Stamp (FD : File_Descriptor) return OS_Time is
813 function File_Time (FD : File_Descriptor) return OS_Time;
814 pragma Import (C, File_Time, "__gnat_file_time_fd");
817 return File_Time (FD);
820 function File_Time_Stamp (Name : C_File_Name) return OS_Time is
821 function File_Time (Name : Address) return OS_Time;
822 pragma Import (C, File_Time, "__gnat_file_time_name");
825 return File_Time (Name);
828 function File_Time_Stamp (Name : String) return OS_Time is
829 F_Name : String (1 .. Name'Length + 1);
832 F_Name (1 .. Name'Length) := Name;
833 F_Name (F_Name'Last) := ASCII.NUL;
834 return File_Time_Stamp (F_Name'Address);
837 ---------------------------
838 -- Get_Debuggable_Suffix --
839 ---------------------------
841 function Get_Debuggable_Suffix return String_Access is
842 procedure Get_Suffix_Ptr (Length, Ptr : Address);
843 pragma Import (C, Get_Suffix_Ptr, "__gnat_get_debuggable_suffix_ptr");
845 procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
846 pragma Import (C, Strncpy, "strncpy");
848 Suffix_Ptr : Address;
849 Suffix_Length : Integer;
850 Result : String_Access;
853 Get_Suffix_Ptr (Suffix_Length'Address, Suffix_Ptr'Address);
855 Result := new String (1 .. Suffix_Length);
857 if Suffix_Length > 0 then
858 Strncpy (Result.all'Address, Suffix_Ptr, Suffix_Length);
862 end Get_Debuggable_Suffix;
864 ---------------------------
865 -- Get_Executable_Suffix --
866 ---------------------------
868 function Get_Executable_Suffix return String_Access is
869 procedure Get_Suffix_Ptr (Length, Ptr : Address);
870 pragma Import (C, Get_Suffix_Ptr, "__gnat_get_executable_suffix_ptr");
872 procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
873 pragma Import (C, Strncpy, "strncpy");
875 Suffix_Ptr : Address;
876 Suffix_Length : Integer;
877 Result : String_Access;
880 Get_Suffix_Ptr (Suffix_Length'Address, Suffix_Ptr'Address);
882 Result := new String (1 .. Suffix_Length);
884 if Suffix_Length > 0 then
885 Strncpy (Result.all'Address, Suffix_Ptr, Suffix_Length);
889 end Get_Executable_Suffix;
891 -----------------------
892 -- Get_Object_Suffix --
893 -----------------------
895 function Get_Object_Suffix return String_Access is
896 procedure Get_Suffix_Ptr (Length, Ptr : Address);
897 pragma Import (C, Get_Suffix_Ptr, "__gnat_get_object_suffix_ptr");
899 procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
900 pragma Import (C, Strncpy, "strncpy");
902 Suffix_Ptr : Address;
903 Suffix_Length : Integer;
904 Result : String_Access;
907 Get_Suffix_Ptr (Suffix_Length'Address, Suffix_Ptr'Address);
909 Result := new String (1 .. Suffix_Length);
911 if Suffix_Length > 0 then
912 Strncpy (Result.all'Address, Suffix_Ptr, Suffix_Length);
916 end Get_Object_Suffix;
922 function Getenv (Name : String) return String_Access is
923 procedure Get_Env_Value_Ptr (Name, Length, Ptr : Address);
924 pragma Import (C, Get_Env_Value_Ptr, "__gnat_get_env_value_ptr");
926 procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
927 pragma Import (C, Strncpy, "strncpy");
929 Env_Value_Ptr : aliased Address;
930 Env_Value_Length : aliased Integer;
931 F_Name : aliased String (1 .. Name'Length + 1);
932 Result : String_Access;
935 F_Name (1 .. Name'Length) := Name;
936 F_Name (F_Name'Last) := ASCII.NUL;
939 (F_Name'Address, Env_Value_Length'Address, Env_Value_Ptr'Address);
941 Result := new String (1 .. Env_Value_Length);
943 if Env_Value_Length > 0 then
944 Strncpy (Result.all'Address, Env_Value_Ptr, Env_Value_Length);
954 function GM_Day (Date : OS_Time) return Day_Type is
963 GM_Split (Date, Y, Mo, D, H, Mn, S);
971 function GM_Hour (Date : OS_Time) return Hour_Type is
980 GM_Split (Date, Y, Mo, D, H, Mn, S);
988 function GM_Minute (Date : OS_Time) return Minute_Type is
997 GM_Split (Date, Y, Mo, D, H, Mn, S);
1005 function GM_Month (Date : OS_Time) return Month_Type is
1014 GM_Split (Date, Y, Mo, D, H, Mn, S);
1022 function GM_Second (Date : OS_Time) return Second_Type is
1031 GM_Split (Date, Y, Mo, D, H, Mn, S);
1041 Year : out Year_Type;
1042 Month : out Month_Type;
1044 Hour : out Hour_Type;
1045 Minute : out Minute_Type;
1046 Second : out Second_Type)
1048 procedure To_GM_Time
1049 (P_Time_T, P_Year, P_Month, P_Day, P_Hours, P_Mins, P_Secs : Address);
1050 pragma Import (C, To_GM_Time, "__gnat_to_gm_time");
1052 T : OS_Time := Date;
1061 -- Use the global lock because To_GM_Time is not thread safe.
1063 Locked_Processing : begin
1066 (T'Address, Y'Address, Mo'Address, D'Address,
1067 H'Address, Mn'Address, S'Address);
1068 SSL.Unlock_Task.all;
1072 SSL.Unlock_Task.all;
1074 end Locked_Processing;
1088 function GM_Year (Date : OS_Time) return Year_Type is
1097 GM_Split (Date, Y, Mo, D, H, Mn, S);
1101 ----------------------
1102 -- Is_Absolute_Path --
1103 ----------------------
1105 function Is_Absolute_Path (Name : String) return Boolean is
1106 function Is_Absolute_Path (Name : Address) return Integer;
1107 pragma Import (C, Is_Absolute_Path, "__gnat_is_absolute_path");
1109 F_Name : String (1 .. Name'Length + 1);
1112 F_Name (1 .. Name'Length) := Name;
1113 F_Name (F_Name'Last) := ASCII.NUL;
1115 return Is_Absolute_Path (F_Name'Address) /= 0;
1116 end Is_Absolute_Path;
1122 function Is_Directory (Name : C_File_Name) return Boolean is
1123 function Is_Directory (Name : Address) return Integer;
1124 pragma Import (C, Is_Directory, "__gnat_is_directory");
1127 return Is_Directory (Name) /= 0;
1130 function Is_Directory (Name : String) return Boolean is
1131 F_Name : String (1 .. Name'Length + 1);
1134 F_Name (1 .. Name'Length) := Name;
1135 F_Name (F_Name'Last) := ASCII.NUL;
1136 return Is_Directory (F_Name'Address);
1139 ---------------------
1140 -- Is_Regular_File --
1141 ---------------------
1143 function Is_Regular_File (Name : C_File_Name) return Boolean is
1144 function Is_Regular_File (Name : Address) return Integer;
1145 pragma Import (C, Is_Regular_File, "__gnat_is_regular_file");
1148 return Is_Regular_File (Name) /= 0;
1149 end Is_Regular_File;
1151 function Is_Regular_File (Name : String) return Boolean is
1152 F_Name : String (1 .. Name'Length + 1);
1155 F_Name (1 .. Name'Length) := Name;
1156 F_Name (F_Name'Last) := ASCII.NUL;
1157 return Is_Regular_File (F_Name'Address);
1158 end Is_Regular_File;
1160 ----------------------
1161 -- Is_Readable_File --
1162 ----------------------
1164 function Is_Readable_File (Name : C_File_Name) return Boolean is
1165 function Is_Readable_File (Name : Address) return Integer;
1166 pragma Import (C, Is_Readable_File, "__gnat_is_readable_file");
1169 return Is_Readable_File (Name) /= 0;
1170 end Is_Readable_File;
1172 function Is_Readable_File (Name : String) return Boolean is
1173 F_Name : String (1 .. Name'Length + 1);
1176 F_Name (1 .. Name'Length) := Name;
1177 F_Name (F_Name'Last) := ASCII.NUL;
1178 return Is_Readable_File (F_Name'Address);
1179 end Is_Readable_File;
1181 ----------------------
1182 -- Is_Writable_File --
1183 ----------------------
1185 function Is_Writable_File (Name : C_File_Name) return Boolean is
1186 function Is_Writable_File (Name : Address) return Integer;
1187 pragma Import (C, Is_Writable_File, "__gnat_is_writable_file");
1190 return Is_Writable_File (Name) /= 0;
1191 end Is_Writable_File;
1193 function Is_Writable_File (Name : String) return Boolean is
1194 F_Name : String (1 .. Name'Length + 1);
1197 F_Name (1 .. Name'Length) := Name;
1198 F_Name (F_Name'Last) := ASCII.NUL;
1199 return Is_Writable_File (F_Name'Address);
1200 end Is_Writable_File;
1202 ----------------------
1203 -- Is_Symbolic_Link --
1204 ----------------------
1206 function Is_Symbolic_Link (Name : C_File_Name) return Boolean is
1207 function Is_Symbolic_Link (Name : Address) return Integer;
1208 pragma Import (C, Is_Symbolic_Link, "__gnat_is_symbolic_link");
1211 return Is_Symbolic_Link (Name) /= 0;
1212 end Is_Symbolic_Link;
1214 function Is_Symbolic_Link (Name : String) return Boolean is
1215 F_Name : String (1 .. Name'Length + 1);
1218 F_Name (1 .. Name'Length) := Name;
1219 F_Name (F_Name'Last) := ASCII.NUL;
1220 return Is_Symbolic_Link (F_Name'Address);
1221 end Is_Symbolic_Link;
1223 -------------------------
1224 -- Locate_Exec_On_Path --
1225 -------------------------
1227 function Locate_Exec_On_Path
1228 (Exec_Name : String)
1229 return String_Access
1231 function Locate_Exec_On_Path (C_Exec_Name : Address) return Address;
1232 pragma Import (C, Locate_Exec_On_Path, "__gnat_locate_exec_on_path");
1234 procedure Free (Ptr : System.Address);
1235 pragma Import (C, Free, "free");
1237 C_Exec_Name : String (1 .. Exec_Name'Length + 1);
1238 Path_Addr : Address;
1240 Result : String_Access;
1243 C_Exec_Name (1 .. Exec_Name'Length) := Exec_Name;
1244 C_Exec_Name (C_Exec_Name'Last) := ASCII.NUL;
1246 Path_Addr := Locate_Exec_On_Path (C_Exec_Name'Address);
1247 Path_Len := C_String_Length (Path_Addr);
1249 if Path_Len = 0 then
1253 Result := To_Path_String_Access (Path_Addr, Path_Len);
1257 end Locate_Exec_On_Path;
1259 -------------------------
1260 -- Locate_Regular_File --
1261 -------------------------
1263 function Locate_Regular_File
1264 (File_Name : C_File_Name;
1266 return String_Access
1268 function Locate_Regular_File
1269 (C_File_Name, Path_Val : Address) return Address;
1270 pragma Import (C, Locate_Regular_File, "__gnat_locate_regular_file");
1272 procedure Free (Ptr : System.Address);
1273 pragma Import (C, Free, "free");
1275 Path_Addr : Address;
1277 Result : String_Access;
1280 Path_Addr := Locate_Regular_File (File_Name, Path);
1281 Path_Len := C_String_Length (Path_Addr);
1283 if Path_Len = 0 then
1286 Result := To_Path_String_Access (Path_Addr, Path_Len);
1290 end Locate_Regular_File;
1292 function Locate_Regular_File
1293 (File_Name : String;
1295 return String_Access
1297 C_File_Name : String (1 .. File_Name'Length + 1);
1298 C_Path : String (1 .. Path'Length + 1);
1301 C_File_Name (1 .. File_Name'Length) := File_Name;
1302 C_File_Name (C_File_Name'Last) := ASCII.NUL;
1304 C_Path (1 .. Path'Length) := Path;
1305 C_Path (C_Path'Last) := ASCII.NUL;
1307 return Locate_Regular_File (C_File_Name'Address, C_Path'Address);
1308 end Locate_Regular_File;
1310 ------------------------
1311 -- Non_Blocking_Spawn --
1312 ------------------------
1314 function Non_Blocking_Spawn
1315 (Program_Name : String;
1316 Args : Argument_List)
1323 Spawn_Internal (Program_Name, Args, Junk, Pid, Blocking => False);
1325 end Non_Blocking_Spawn;
1327 -------------------------
1328 -- Normalize_Arguments --
1329 -------------------------
1331 procedure Normalize_Arguments (Args : in out Argument_List) is
1333 procedure Quote_Argument (Arg : in out String_Access);
1334 -- Add quote around argument if it contains spaces
1336 C_Argument_Needs_Quote : Integer;
1337 pragma Import (C, C_Argument_Needs_Quote, "__gnat_argument_needs_quote");
1338 Argument_Needs_Quote : constant Boolean := C_Argument_Needs_Quote /= 0;
1340 --------------------
1341 -- Quote_Argument --
1342 --------------------
1344 procedure Quote_Argument (Arg : in out String_Access) is
1345 Res : String (1 .. Arg'Length * 2);
1347 Quote_Needed : Boolean := False;
1350 if Arg (Arg'First) /= '"' or else Arg (Arg'Last) /= '"' then
1356 for K in Arg'Range loop
1360 if Arg (K) = '"' then
1364 Quote_Needed := True;
1366 elsif Arg (K) = ' ' then
1368 Quote_Needed := True;
1376 if Quote_Needed then
1378 -- If null terminated string, put the quote before
1380 if Res (J) = ASCII.Nul then
1383 Res (J) := ASCII.Nul;
1385 -- If argument is terminated by '\
', then double it. Otherwise
1386 -- the ending quote will be taken as-is. This is quite strange
1387 -- spawn behavior from Windows, but this is what we see!
1390 if Res (J) = '\
' then
1402 Old : String_Access := Arg;
1405 Arg := new String'(Res (1 .. J));
1414 if Argument_Needs_Quote then
1415 for K in Args'Range loop
1416 if Args (K) /= null and then Args (K)'Length /= 0 then
1417 Quote_Argument (Args (K));
1421 end Normalize_Arguments;
1423 ------------------------
1424 -- Normalize_Pathname --
1425 ------------------------
1427 function Normalize_Pathname
1429 Directory : String := "";
1430 Resolve_Links : Boolean := True;
1431 Case_Sensitive : Boolean := True)
1435 pragma Import (C, Max_Path, "__gnat_max_path_len
");
1436 -- Maximum length of a path name
1438 procedure Get_Current_Dir
1439 (Dir : System.Address;
1440 Length : System.Address);
1441 pragma Import (C, Get_Current_Dir, "__gnat_get_current_dir
");
1443 function Change_Dir (Dir_Name : String) return Integer;
1444 pragma Import (C, Change_Dir, "chdir
");
1446 Path_Buffer : String (1 .. Max_Path + Max_Path + 2);
1447 End_Path : Natural := 0;
1448 Link_Buffer : String (1 .. Max_Path + 2);
1454 Max_Iterations : constant := 500;
1456 function Get_File_Names_Case_Sensitive return Integer;
1458 (C, Get_File_Names_Case_Sensitive,
1459 "__gnat_get_file_names_case_sensitive
");
1461 Fold_To_Lower_Case : constant Boolean :=
1463 and then Get_File_Names_Case_Sensitive = 0;
1466 (Path : System.Address;
1467 Buf : System.Address;
1470 pragma Import (C, Readlink, "__gnat_readlink
");
1472 function To_Canonical_File_Spec
1473 (Host_File : System.Address)
1474 return System.Address;
1476 (C, To_Canonical_File_Spec, "__gnat_to_canonical_file_spec
");
1478 The_Name : String (1 .. Name'Length + 1);
1479 Canonical_File_Addr : System.Address;
1480 Canonical_File_Len : Integer;
1482 Need_To_Check_Drive_Letter : Boolean := False;
1483 -- Set to true if Name is an absolute path that starts with "//"
1485 function Strlen (S : System.Address) return Integer;
1486 pragma Import (C, Strlen, "strlen
");
1488 function Get_Directory (Dir : String) return String;
1489 -- If Dir is not empty, return it, adding a directory separator
1490 -- if not already present, otherwise return current working directory
1491 -- with terminating directory separator.
1493 function Final_Value (S : String) return String;
1494 -- Make final adjustment to the returned string.
1495 -- To compensate for non standard path name in Interix,
1496 -- if S is "/x
" or starts with "/x
", where x is a capital
1497 -- letter 'A' to 'Z', add an additional '/' at the beginning
1498 -- so that the returned value starts with "//x
".
1504 function Get_Directory (Dir : String) return String is
1506 -- Directory given, add directory separator if needed
1508 if Dir'Length > 0 then
1509 if Dir (Dir'Length) = Directory_Separator then
1513 Result : String (1 .. Dir'Length + 1);
1516 Result (1 .. Dir'Length) := Dir;
1517 Result (Result'Length) := Directory_Separator;
1522 -- Directory name not given, get current directory
1526 Buffer : String (1 .. Max_Path + 2);
1527 Path_Len : Natural := Max_Path;
1530 Get_Current_Dir (Buffer'Address, Path_Len'Address);
1532 if Buffer (Path_Len) /= Directory_Separator then
1533 Path_Len := Path_Len + 1;
1534 Buffer (Path_Len) := Directory_Separator;
1537 return Buffer (1 .. Path_Len);
1542 Reference_Dir : constant String := Get_Directory (Directory);
1543 -- Current directory name specified
1549 function Final_Value (S : String) return String is
1551 -- We may need to fold S to lower case, so we need a variable
1554 -- Interix has the non standard notion of disk drive
1555 -- indicated by two '/' followed by a capital letter
1556 -- 'A' .. 'Z'. One of the two '/' may have been removed
1557 -- by Normalize_Pathname. It has to be added again.
1558 -- For other OSes, this should not make no difference.
1560 if Need_To_Check_Drive_Letter
1561 and then S'Length >= 2
1562 and then S (S'First) = '/'
1563 and then S (S'First + 1) in 'A' .. 'Z'
1564 and then (S'Length = 2 or else S (S'First + 2) = '/')
1567 Result : String (1 .. S'Length + 1);
1571 Result (2 .. Result'Last) := S;
1573 if Fold_To_Lower_Case then
1574 System.Case_Util.To_Lower (Result);
1583 if Fold_To_Lower_Case then
1584 System.Case_Util.To_Lower (S1);
1593 -- Start of processing for Normalize_Pathname
1596 -- Special case, if name is null, then return null
1598 if Name'Length = 0 then
1602 -- First, convert VMS file spec to Unix file spec.
1603 -- If Name is not in VMS syntax, then this is equivalent
1604 -- to put Name at the begining of Path_Buffer.
1606 VMS_Conversion : begin
1607 The_Name (1 .. Name'Length) := Name;
1608 The_Name (The_Name'Last) := ASCII.NUL;
1610 Canonical_File_Addr := To_Canonical_File_Spec (The_Name'Address);
1611 Canonical_File_Len := Strlen (Canonical_File_Addr);
1613 -- If VMS syntax conversion has failed, return an empty string
1614 -- to indicate the failure.
1616 if Canonical_File_Len = 0 then
1621 subtype Path_String is String (1 .. Canonical_File_Len);
1622 type Path_String_Access is access Path_String;
1624 function Address_To_Access is new
1625 Unchecked_Conversion (Source => Address,
1626 Target => Path_String_Access);
1628 Path_Access : constant Path_String_Access :=
1629 Address_To_Access (Canonical_File_Addr);
1632 Path_Buffer (1 .. Canonical_File_Len) := Path_Access.all;
1633 End_Path := Canonical_File_Len;
1638 -- Replace all '/' by Directory Separators (this is for Windows)
1640 if Directory_Separator /= '/' then
1641 for Index in 1 .. End_Path loop
1642 if Path_Buffer (Index) = '/' then
1643 Path_Buffer (Index) := Directory_Separator;
1648 -- Resolving logical names from VMS.
1649 -- If we have a Unix path on VMS such as /temp/..., and TEMP is a
1650 -- logical name, we need to resolve this logical name.
1651 -- As we have no means to know if we are on VMS, we need to do that
1652 -- for absolute paths starting with '/'.
1653 -- We find the directory, change to it, get the current directory,
1654 -- and change the directory to this value.
1656 if Path_Buffer (1) = '/' then
1658 Cur_Dir : String := Get_Directory ("");
1659 -- Save the current directory, so that we can change dir back to
1660 -- it. It is not a constant, because the last character (a
1661 -- directory separator) is changed to ASCII.NUL to call the C
1664 Path : String := Path_Buffer (1 .. End_Path + 1);
1665 -- Copy of the current path. One character is added that may be
1666 -- set to ASCII.NUL to call chdir.
1668 Pos : Positive := End_Path;
1669 -- Position of the last directory separator ('/')
1672 -- Value returned by chdir
1675 -- Look for the last '/'
1677 while Path (Pos) /= '/' loop
1681 -- Get the previous character that is not a '/'
1683 while Pos > 1 and then Path (Pos) = '/' loop
1687 -- If we are at the start of the path, take the full path.
1688 -- It may be a file in the root directory, but it may also be
1689 -- a subdirectory of the root directory.
1695 -- Add the ASCII.NUL to be able to call the C function chdir
1696 Path (Pos + 1) := ASCII.NUL;
1698 Status := Change_Dir (Path (1 .. Pos + 1));
1700 -- If Status is not zero, then we do nothing: this is a file
1701 -- path or it is not a valid directory path.
1705 New_Dir : constant String := Get_Directory ("");
1706 -- The directory path
1708 New_Path : String (1 .. New_Dir'Length + End_Path - Pos);
1709 -- The new complete path, that is built below
1712 New_Path (1 .. New_Dir'Length) := New_Dir;
1713 New_Path (New_Dir'Length + 1 .. New_Path'Last) :=
1714 Path_Buffer (Pos + 1 .. End_Path);
1715 End_Path := New_Path'Length;
1716 Path_Buffer (1 .. End_Path) := New_Path;
1719 -- Back to where we were before
1721 Cur_Dir (Cur_Dir'Last) := ASCII.NUL;
1722 Status := Change_Dir (Cur_Dir);
1727 -- Start the conversions
1729 -- If this is not finished after Max_Iterations, give up and
1730 -- return an empty string.
1732 for J in 1 .. Max_Iterations loop
1734 -- If we don't have an absolute pathname, prepend
1735 -- the directory Reference_Dir.
1738 and then not Is_Absolute_Path (Path_Buffer (1 .. End_Path))
1741 (Reference_Dir'Last + 1 .. Reference_Dir'Length + End_Path) :=
1742 Path_Buffer (1 .. End_Path);
1743 End_Path := Reference_Dir'Length + End_Path;
1744 Path_Buffer (1 .. Reference_Dir'Length) := Reference_Dir;
1745 Last := Reference_Dir'Length;
1748 -- If name starts with "//", we may have a drive letter on Interix
1750 if Last = 1 and then End_Path >= 3 then
1751 Need_To_Check_Drive_Letter := (Path_Buffer (1 .. 2)) = "//";
1757 -- Ensure that Windows network drives are kept, e.g: \\server\drive-c
1760 and then Directory_Separator = '\'
1761 and then Path_Buffer (1 .. 2) = "\\"
1766 -- If we have traversed the full pathname, return it
1768 if Start > End_Path then
1769 return Final_Value (Path_Buffer (1 .. End_Path));
1772 -- Remove duplicate directory separators
1774 while Path_Buffer (Start) = Directory_Separator loop
1775 if Start = End_Path then
1776 return Final_Value (Path_Buffer (1 .. End_Path - 1));
1779 Path_Buffer (Start .. End_Path - 1) :=
1780 Path_Buffer (Start + 1 .. End_Path);
1781 End_Path := End_Path - 1;
1785 -- Find the end of the current field: last character
1786 -- or the one preceding the next directory separator.
1788 while Finish < End_Path
1789 and then Path_Buffer (Finish + 1) /= Directory_Separator
1791 Finish := Finish + 1;
1796 if Start = Finish and then Path_Buffer (Start) = '.' then
1797 if Start = End_Path then
1799 return (1 => Directory_Separator);
1802 if Fold_To_Lower_Case then
1803 System.Case_Util.To_Lower (Path_Buffer (1 .. Last - 1));
1806 return Path_Buffer (1 .. Last - 1);
1811 Path_Buffer (Last + 1 .. End_Path - 2) :=
1812 Path_Buffer (Last + 3 .. End_Path);
1813 End_Path := End_Path - 2;
1816 -- Remove ".." fields
1818 elsif Finish = Start + 1
1819 and then Path_Buffer (Start .. Finish) = ".."
1824 exit when Start < 1 or else
1825 Path_Buffer (Start) = Directory_Separator;
1829 if Finish = End_Path then
1830 return (1 => Directory_Separator);
1833 Path_Buffer (1 .. End_Path - Finish) :=
1834 Path_Buffer (Finish + 1 .. End_Path);
1835 End_Path := End_Path - Finish;
1840 if Finish = End_Path then
1841 return Final_Value (Path_Buffer (1 .. Start - 1));
1844 Path_Buffer (Start + 1 .. Start + End_Path - Finish - 1) :=
1845 Path_Buffer (Finish + 2 .. End_Path);
1846 End_Path := Start + End_Path - Finish - 1;
1851 -- Check if current field is a symbolic link
1853 elsif Resolve_Links then
1855 Saved : constant Character := Path_Buffer (Finish + 1);
1858 Path_Buffer (Finish + 1) := ASCII.NUL;
1859 Status := Readlink (Path_Buffer'Address,
1860 Link_Buffer'Address,
1861 Link_Buffer'Length);
1862 Path_Buffer (Finish + 1) := Saved;
1865 -- Not a symbolic link, move to the next field, if any
1870 -- Replace symbolic link with its value.
1873 if Is_Absolute_Path (Link_Buffer (1 .. Status)) then
1874 Path_Buffer (Status + 1 .. End_Path - (Finish - Status)) :=
1875 Path_Buffer (Finish + 1 .. End_Path);
1876 End_Path := End_Path - (Finish - Status);
1877 Path_Buffer (1 .. Status) := Link_Buffer (1 .. Status);
1882 (Last + Status + 1 .. End_Path - Finish + Last + Status) :=
1883 Path_Buffer (Finish + 1 .. End_Path);
1884 End_Path := End_Path - Finish + Last + Status;
1885 Path_Buffer (Last + 1 .. Last + Status) :=
1886 Link_Buffer (1 .. Status);
1895 -- Too many iterations: give up
1897 -- This can happen when there is a circularity in the symbolic links:
1898 -- A is a symbolic link for B, which itself is a symbolic link, and
1899 -- the target of B or of another symbolic link target of B is A.
1900 -- In this case, we return an empty string to indicate failure to
1904 end Normalize_Pathname;
1911 (Name : C_File_Name;
1913 return File_Descriptor
1915 function C_Open_Read
1916 (Name : C_File_Name;
1918 return File_Descriptor;
1919 pragma Import (C, C_Open_Read, "__gnat_open_read
");
1922 return C_Open_Read (Name, Fmode);
1928 return File_Descriptor
1930 C_Name : String (1 .. Name'Length + 1);
1933 C_Name (1 .. Name'Length) := Name;
1934 C_Name (C_Name'Last) := ASCII.NUL;
1935 return Open_Read (C_Name (C_Name'First)'Address, Fmode);
1938 ---------------------
1939 -- Open_Read_Write --
1940 ---------------------
1942 function Open_Read_Write
1943 (Name : C_File_Name;
1945 return File_Descriptor
1947 function C_Open_Read_Write
1948 (Name : C_File_Name;
1950 return File_Descriptor;
1951 pragma Import (C, C_Open_Read_Write, "__gnat_open_rw
");
1954 return C_Open_Read_Write (Name, Fmode);
1955 end Open_Read_Write;
1957 function Open_Read_Write
1960 return File_Descriptor
1962 C_Name : String (1 .. Name'Length + 1);
1965 C_Name (1 .. Name'Length) := Name;
1966 C_Name (C_Name'Last) := ASCII.NUL;
1967 return Open_Read_Write (C_Name (C_Name'First)'Address, Fmode);
1968 end Open_Read_Write;
1974 procedure Rename_File
1975 (Old_Name : C_File_Name;
1976 New_Name : C_File_Name;
1977 Success : out Boolean)
1979 function rename (From, To : Address) return Integer;
1980 pragma Import (C, rename, "rename
");
1985 R := rename (Old_Name, New_Name);
1989 procedure Rename_File
1992 Success : out Boolean)
1994 C_Old_Name : String (1 .. Old_Name'Length + 1);
1995 C_New_Name : String (1 .. New_Name'Length + 1);
1998 C_Old_Name (1 .. Old_Name'Length) := Old_Name;
1999 C_Old_Name (C_Old_Name'Last) := ASCII.NUL;
2001 C_New_Name (1 .. New_Name'Length) := New_Name;
2002 C_New_Name (C_New_Name'Last) := ASCII.NUL;
2004 Rename_File (C_Old_Name'Address, C_New_Name'Address, Success);
2011 procedure Setenv (Name : String; Value : String) is
2012 F_Name : String (1 .. Name'Length + 1);
2013 F_Value : String (1 .. Value'Length + 1);
2015 procedure Set_Env_Value (Name, Value : System.Address);
2016 pragma Import (C, Set_Env_Value, "__gnat_set_env_value
");
2019 F_Name (1 .. Name'Length) := Name;
2020 F_Name (F_Name'Last) := ASCII.NUL;
2022 F_Value (1 .. Value'Length) := Value;
2023 F_Value (F_Value'Last) := ASCII.NUL;
2025 Set_Env_Value (F_Name'Address, F_Value'Address);
2033 (Program_Name : String;
2034 Args : Argument_List)
2041 Spawn_Internal (Program_Name, Args, Result, Junk, Blocking => True);
2046 (Program_Name : String;
2047 Args : Argument_List;
2048 Success : out Boolean)
2051 Success := (Spawn (Program_Name, Args) = 0);
2054 --------------------
2055 -- Spawn_Internal --
2056 --------------------
2058 procedure Spawn_Internal
2059 (Program_Name : String;
2060 Args : Argument_List;
2061 Result : out Integer;
2062 Pid : out Process_Id;
2066 procedure Spawn (Args : Argument_List);
2069 N_Args : Argument_List (Args'Range);
2070 -- Normalized arguments
2076 procedure Spawn (Args : Argument_List) is
2077 type Chars is array (Positive range <>) of aliased Character;
2078 type Char_Ptr is access constant Character;
2080 Command_Len : constant Positive := Program_Name'Length + 1
2081 + Args_Length (Args);
2082 Command_Last : Natural := 0;
2083 Command : aliased Chars (1 .. Command_Len);
2084 -- Command contains all characters of the Program_Name and Args,
2085 -- all terminated by ASCII.NUL characters
2087 Arg_List_Len : constant Positive := Args'Length + 2;
2088 Arg_List_Last : Natural := 0;
2089 Arg_List : aliased array (1 .. Arg_List_Len) of Char_Ptr;
2090 -- List with pointers to NUL-terminated strings of the
2091 -- Program_Name and the Args and terminated with a null pointer.
2092 -- We rely on the default initialization for the last null pointer.
2094 procedure Add_To_Command (S : String);
2095 -- Add S and a NUL character to Command, updating Last
2097 function Portable_Spawn (Args : Address) return Integer;
2098 pragma Import (C, Portable_Spawn, "__gnat_portable_spawn
");
2100 function Portable_No_Block_Spawn (Args : Address) return Process_Id;
2102 (C, Portable_No_Block_Spawn, "__gnat_portable_no_block_spawn
");
2104 --------------------
2105 -- Add_To_Command --
2106 --------------------
2108 procedure Add_To_Command (S : String) is
2109 First : constant Natural := Command_Last + 1;
2112 Command_Last := Command_Last + S'Length;
2114 -- Move characters one at a time, because Command has
2115 -- aliased components.
2117 for J in S'Range loop
2118 Command (First + J - S'First) := S (J);
2121 Command_Last := Command_Last + 1;
2122 Command (Command_Last) := ASCII.NUL;
2124 Arg_List_Last := Arg_List_Last + 1;
2125 Arg_List (Arg_List_Last) := Command (First)'Access;
2128 -- Start of processing for Spawn
2131 Add_To_Command (Program_Name);
2133 for J in Args'Range loop
2134 Add_To_Command (Args (J).all);
2139 Result := Portable_Spawn (Arg_List'Address);
2141 Pid := Portable_No_Block_Spawn (Arg_List'Address);
2142 Result := Boolean'Pos (Pid /= Invalid_Pid);
2146 -- Start of processing for Spawn_Internal
2149 -- Copy arguments into a local structure
2151 for K in N_Args'Range loop
2152 N_Args (K) := new String'(Args (K).all);
2155 -- Normalize those arguments
2157 Normalize_Arguments (N_Args);
2159 -- Call spawn using the normalized arguments
2163 -- Free arguments list
2165 for K in N_Args'Range loop
2170 ---------------------------
2171 -- To_Path_String_Access --
2172 ---------------------------
2174 function To_Path_String_Access
2175 (Path_Addr : Address;
2177 return String_Access
2179 subtype Path_String is String (1 .. Path_Len);
2180 type Path_String_Access is access Path_String;
2182 function Address_To_Access is new
2183 Unchecked_Conversion (Source => Address,
2184 Target => Path_String_Access);
2186 Path_Access : constant Path_String_Access :=
2187 Address_To_Access (Path_Addr);
2189 Return_Val : String_Access;
2192 Return_Val := new String (1 .. Path_Len);
2194 for J in 1 .. Path_Len loop
2195 Return_Val (J) := Path_Access (J);
2199 end To_Path_String_Access;
2205 procedure Wait_Process (Pid : out Process_Id; Success : out Boolean) is
2208 function Portable_Wait (S : Address) return Process_Id;
2209 pragma Import (C, Portable_Wait, "__gnat_portable_wait
");
2212 Pid := Portable_Wait (Status'Address);
2213 Success := (Status = 0);