1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
5 -- G N A T . O S _ L I B --
9 -- Copyright (C) 1995-2004 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
;
36 with System
.Soft_Links
;
37 with Unchecked_Conversion
;
38 with System
; use System
;
40 package body GNAT
.OS_Lib
is
43 -- Note: OpenVMS should be a constant, but it cannot be, because it
44 -- prevents bootstrapping on some platforms.
46 On_Windows
: constant Boolean := Directory_Separator
= '\';
48 pragma Import
(Ada
, OpenVMS
, "system__openvms");
49 -- Needed to avoid doing useless checks when non on a VMS platform (see
50 -- Normalize_Pathname).
52 package SSL
renames System
.Soft_Links
;
54 -- The following are used by Create_Temp_File
56 Current_Temp_File_Name
: String := "GNAT-TEMP-000000.TMP";
57 -- Name of the temp file last created
59 Temp_File_Name_Last_Digit
: constant Positive :=
60 Current_Temp_File_Name
'Last - 4;
61 -- Position of the last digit in Current_Temp_File_Name
63 Max_Attempts
: constant := 100;
64 -- The maximum number of attempts to create a new temp file
66 -----------------------
67 -- Local Subprograms --
68 -----------------------
70 function Args_Length
(Args
: Argument_List
) return Natural;
71 -- Returns total number of characters needed to create a string
72 -- of all Args terminated by ASCII.NUL characters
74 function C_String_Length
(S
: Address
) return Integer;
75 -- Returns the length of a C string. Does check for null address
78 procedure Spawn_Internal
79 (Program_Name
: String;
84 -- Internal routine to implement the two Spawn (blocking/non blocking)
85 -- routines. If Blocking is set to True then the spawn is blocking
86 -- otherwise it is non blocking. In this latter case the Pid contains
87 -- the process id number. The first three parameters are as in Spawn.
88 -- Note that Spawn_Internal normalizes the argument list before calling
89 -- the low level system spawn routines (see Normalize_Arguments). Note
90 -- that Normalize_Arguments is designed to do nothing if it is called
91 -- more than once, so calling Normalize_Arguments before calling one
92 -- of the spawn routines is fine.
94 function To_Path_String_Access
96 Path_Len
: Integer) return String_Access
;
97 -- Converts a C String to an Ada String. We could do this making use of
98 -- Interfaces.C.Strings but we prefer not to import that entire package
104 function "<" (X
, Y
: OS_Time
) return Boolean is
106 return Long_Integer (X
) < Long_Integer (Y
);
113 function "<=" (X
, Y
: OS_Time
) return Boolean is
115 return Long_Integer (X
) <= Long_Integer (Y
);
122 function ">" (X
, Y
: OS_Time
) return Boolean is
124 return Long_Integer (X
) > Long_Integer (Y
);
131 function ">=" (X
, Y
: OS_Time
) return Boolean is
133 return Long_Integer (X
) >= Long_Integer (Y
);
140 function Args_Length
(Args
: Argument_List
) return Natural is
144 for J
in Args
'Range loop
145 Len
:= Len
+ Args
(J
)'Length + 1; -- One extra for ASCII.NUL
151 -----------------------------
152 -- Argument_String_To_List --
153 -----------------------------
155 function Argument_String_To_List
156 (Arg_String
: String) return Argument_List_Access
158 Max_Args
: constant Integer := Arg_String
'Length;
159 New_Argv
: Argument_List
(1 .. Max_Args
);
160 New_Argc
: Natural := 0;
164 Idx
:= Arg_String
'First;
167 exit when Idx
> Arg_String
'Last;
170 Quoted
: Boolean := False;
171 Backqd
: Boolean := False;
178 -- An unquoted space is the end of an argument
180 if not (Backqd
or Quoted
)
181 and then Arg_String
(Idx
) = ' '
185 -- Start of a quoted string
187 elsif not (Backqd
or Quoted
)
188 and then Arg_String
(Idx
) = '"'
192 -- End of a quoted string and end of an argument
194 elsif (Quoted
and not Backqd
)
195 and then Arg_String
(Idx
) = '"'
200 -- Following character is backquoted
202 elsif Arg_String
(Idx
) = '\' then
205 -- Turn off backquoting after advancing one character
213 exit when Idx
> Arg_String
'Last;
218 New_Argc
:= New_Argc
+ 1;
219 New_Argv
(New_Argc
) :=
220 new String'(Arg_String (Old_Idx .. Idx - 1));
222 -- Skip extraneous spaces
224 while Idx <= Arg_String'Last and then Arg_String (Idx) = ' ' loop
230 return new Argument_List'(New_Argv
(1 .. New_Argc
));
231 end Argument_String_To_List
;
233 ---------------------
234 -- C_String_Length --
235 ---------------------
237 function C_String_Length
(S
: Address
) return Integer is
239 function Strlen
(S
: Address
) return Integer;
240 pragma Import
(C
, Strlen
, "strlen");
243 if S
= Null_Address
then
254 procedure Close
(FD
: File_Descriptor
) is
255 procedure C_Close
(FD
: File_Descriptor
);
256 pragma Import
(C
, C_Close
, "close");
261 procedure Close
(FD
: File_Descriptor
; Status
: out Boolean) is
262 function C_Close
(FD
: File_Descriptor
) return Integer;
263 pragma Import
(C
, C_Close
, "close");
265 Status
:= (C_Close
(FD
) = 0);
275 Success
: out Boolean;
276 Mode
: Copy_Mode
:= Copy
;
277 Preserve
: Attribute
:= Time_Stamps
)
279 From
: File_Descriptor
;
280 To
: File_Descriptor
;
282 Copy_Error
: exception;
283 -- Internal exception raised to signal error in copy
285 function Build_Path
(Dir
: String; File
: String) return String;
286 -- Returns pathname Dir catenated with File adding the directory
287 -- separator only if needed.
289 procedure Copy
(From
, To
: File_Descriptor
);
290 -- Read data from From and place them into To. In both cases the
291 -- operations uses the current file position. Raises Constraint_Error
292 -- if a problem occurs during the copy.
294 procedure Copy_To
(To_Name
: String);
295 -- Does a straight copy from source to designated destination file
301 function Build_Path
(Dir
: String; File
: String) return String is
302 Res
: String (1 .. Dir
'Length + File
'Length + 1);
304 Base_File_Ptr
: Integer;
305 -- The base file name is File (Base_File_Ptr + 1 .. File'Last)
307 function Is_Dirsep
(C
: Character) return Boolean;
308 pragma Inline
(Is_Dirsep
);
309 -- Returns True if C is a directory separator. On Windows we
310 -- handle both styles of directory separator.
316 function Is_Dirsep
(C
: Character) return Boolean is
318 return C
= Directory_Separator
or else C
= '/';
322 -- Find base file name
324 Base_File_Ptr
:= File
'Last;
325 while Base_File_Ptr
>= File
'First loop
326 exit when Is_Dirsep
(File
(Base_File_Ptr
));
327 Base_File_Ptr
:= Base_File_Ptr
- 1;
331 Base_File
: String renames
332 File
(Base_File_Ptr
+ 1 .. File
'Last);
335 Res
(1 .. Dir
'Length) := Dir
;
337 if Is_Dirsep
(Dir
(Dir
'Last)) then
338 Res
(Dir
'Length + 1 .. Dir
'Length + Base_File
'Length) :=
340 return Res
(1 .. Dir
'Length + Base_File
'Length);
343 Res
(Dir
'Length + 1) := Directory_Separator
;
344 Res
(Dir
'Length + 2 .. Dir
'Length + 1 + Base_File
'Length) :=
346 return Res
(1 .. Dir
'Length + 1 + Base_File
'Length);
355 procedure Copy
(From
, To
: File_Descriptor
) is
356 Buf_Size
: constant := 200_000
;
357 Buffer
: array (1 .. Buf_Size
) of Character;
361 Status_From
: Boolean;
363 -- Statuses for the calls to Close
366 if From
= Invalid_FD
or else To
= Invalid_FD
then
371 R
:= Read
(From
, Buffer
(1)'Address, Buf_Size
);
373 -- For VMS, the buffer may not be full. So, we need to try again
374 -- until there is nothing to read.
378 W
:= Write
(To
, Buffer
(1)'Address, R
);
382 -- Problem writing data, could be a disk full. Close files
383 -- without worrying about status, since we are raising a
384 -- Copy_Error exception in any case.
386 Close
(From
, Status_From
);
387 Close
(To
, Status_To
);
393 Close
(From
, Status_From
);
394 Close
(To
, Status_To
);
396 if not (Status_From
and Status_To
) then
405 procedure Copy_To
(To_Name
: String) is
407 function Copy_Attributes
408 (From
, To
: System
.Address
;
409 Mode
: Integer) return Integer;
410 pragma Import
(C
, Copy_Attributes
, "__gnat_copy_attribs");
411 -- Mode = 0 - copy only time stamps.
412 -- Mode = 1 - copy time stamps and read/write/execute attributes
414 C_From
: String (1 .. Name
'Length + 1);
415 C_To
: String (1 .. To_Name
'Length + 1);
418 From
:= Open_Read
(Name
, Binary
);
419 To
:= Create_File
(To_Name
, Binary
);
424 C_From
(1 .. Name
'Length) := Name
;
425 C_From
(C_From
'Last) := ASCII
.Nul
;
427 C_To
(1 .. To_Name
'Length) := To_Name
;
428 C_To
(C_To
'Last) := ASCII
.Nul
;
433 if Copy_Attributes
(C_From
'Address, C_To
'Address, 0) = -1 then
438 if Copy_Attributes
(C_From
'Address, C_To
'Address, 1) = -1 then
448 -- Start of processing for Copy_File
453 -- The source file must exist
455 if not Is_Regular_File
(Name
) then
459 -- The source file exists
463 -- Copy case, target file must not exist
467 -- If the target file exists, we have an error
469 if Is_Regular_File
(Pathname
) then
472 -- Case of target is a directory
474 elsif Is_Directory
(Pathname
) then
476 Dest
: constant String := Build_Path
(Pathname
, Name
);
479 -- If the target file exists, we have an error
480 -- otherwise do the copy.
482 if Is_Regular_File
(Dest
) then
489 -- Case of normal copy to file (destination does not exist)
495 -- Overwrite case, destination file may or may not exist
498 if Is_Directory
(Pathname
) then
499 Copy_To
(Build_Path
(Pathname
, Name
));
504 -- Appending case, destination file may or may not exist
508 -- Appending to existing file
510 if Is_Regular_File
(Pathname
) then
512 -- Append mode and destination file exists, append data
513 -- at the end of Pathname.
515 From
:= Open_Read
(Name
, Binary
);
516 To
:= Open_Read_Write
(Pathname
, Binary
);
517 Lseek
(To
, 0, Seek_End
);
521 -- Appending to directory, not allowed
523 elsif Is_Directory
(Pathname
) then
526 -- Appending when target file does not exist
533 -- All error cases are caught here
542 Pathname
: C_File_Name
;
543 Success
: out Boolean;
544 Mode
: Copy_Mode
:= Copy
;
545 Preserve
: Attribute
:= Time_Stamps
)
547 Ada_Name
: String_Access
:=
548 To_Path_String_Access
549 (Name
, C_String_Length
(Name
));
551 Ada_Pathname
: String_Access
:=
552 To_Path_String_Access
553 (Pathname
, C_String_Length
(Pathname
));
556 Copy_File
(Ada_Name
.all, Ada_Pathname
.all, Success
, Mode
, Preserve
);
561 ----------------------
562 -- Copy_Time_Stamps --
563 ----------------------
565 procedure Copy_Time_Stamps
(Source
, Dest
: String; Success
: out Boolean) is
567 function Copy_Attributes
568 (From
, To
: System
.Address
;
569 Mode
: Integer) return Integer;
570 pragma Import
(C
, Copy_Attributes
, "__gnat_copy_attribs");
571 -- Mode = 0 - copy only time stamps.
572 -- Mode = 1 - copy time stamps and read/write/execute attributes
575 if Is_Regular_File
(Source
) and then Is_Writable_File
(Dest
) then
577 C_Source
: String (1 .. Source
'Length + 1);
578 C_Dest
: String (1 .. Dest
'Length + 1);
580 C_Source
(1 .. C_Source
'Length) := Source
;
581 C_Source
(C_Source
'Last) := ASCII
.Nul
;
583 C_Dest
(1 .. C_Dest
'Length) := Dest
;
584 C_Dest
(C_Dest
'Last) := ASCII
.Nul
;
586 if Copy_Attributes
(C_Source
'Address, C_Dest
'Address, 0) = -1 then
596 end Copy_Time_Stamps
;
598 procedure Copy_Time_Stamps
599 (Source
, Dest
: C_File_Name
;
600 Success
: out Boolean)
602 Ada_Source
: String_Access
:=
603 To_Path_String_Access
604 (Source
, C_String_Length
(Source
));
606 Ada_Dest
: String_Access
:=
607 To_Path_String_Access
608 (Dest
, C_String_Length
(Dest
));
610 Copy_Time_Stamps
(Ada_Source
.all, Ada_Dest
.all, Success
);
613 end Copy_Time_Stamps
;
621 Fmode
: Mode
) return File_Descriptor
623 function C_Create_File
625 Fmode
: Mode
) return File_Descriptor
;
626 pragma Import
(C
, C_Create_File
, "__gnat_open_create");
629 return C_Create_File
(Name
, Fmode
);
634 Fmode
: Mode
) return File_Descriptor
636 C_Name
: String (1 .. Name
'Length + 1);
639 C_Name
(1 .. Name
'Length) := Name
;
640 C_Name
(C_Name
'Last) := ASCII
.NUL
;
641 return Create_File
(C_Name
(C_Name
'First)'Address, Fmode
);
644 ---------------------
645 -- Create_New_File --
646 ---------------------
648 function Create_New_File
650 Fmode
: Mode
) return File_Descriptor
652 function C_Create_New_File
654 Fmode
: Mode
) return File_Descriptor
;
655 pragma Import
(C
, C_Create_New_File
, "__gnat_open_new");
658 return C_Create_New_File
(Name
, Fmode
);
661 function Create_New_File
663 Fmode
: Mode
) return File_Descriptor
665 C_Name
: String (1 .. Name
'Length + 1);
668 C_Name
(1 .. Name
'Length) := Name
;
669 C_Name
(C_Name
'Last) := ASCII
.NUL
;
670 return Create_New_File
(C_Name
(C_Name
'First)'Address, Fmode
);
673 -----------------------------
674 -- Create_Output_Text_File --
675 -----------------------------
677 function Create_Output_Text_File
(Name
: String) return File_Descriptor
is
678 function C_Create_File
679 (Name
: C_File_Name
) return File_Descriptor
;
680 pragma Import
(C
, C_Create_File
, "__gnat_create_output_file");
682 C_Name
: String (1 .. Name
'Length + 1);
685 C_Name
(1 .. Name
'Length) := Name
;
686 C_Name
(C_Name
'Last) := ASCII
.NUL
;
687 return C_Create_File
(C_Name
(C_Name
'First)'Address);
688 end Create_Output_Text_File
;
690 ----------------------
691 -- Create_Temp_File --
692 ----------------------
694 procedure Create_Temp_File
695 (FD
: out File_Descriptor
;
696 Name
: out Temp_File_Name
)
698 function Open_New_Temp
699 (Name
: System
.Address
;
700 Fmode
: Mode
) return File_Descriptor
;
701 pragma Import
(C
, Open_New_Temp
, "__gnat_open_new_temp");
704 FD
:= Open_New_Temp
(Name
'Address, Binary
);
705 end Create_Temp_File
;
707 procedure Create_Temp_File
708 (FD
: out File_Descriptor
;
709 Name
: out String_Access
)
712 Attempts
: Natural := 0;
713 Current
: String (Current_Temp_File_Name
'Range);
716 -- Loop until a new temp file can be created
720 -- We need to protect global variable Current_Temp_File_Name
721 -- against concurrent access by different tasks.
725 -- Start at the last digit
727 Pos
:= Temp_File_Name_Last_Digit
;
731 -- Increment the digit by one
733 case Current_Temp_File_Name
(Pos
) is
735 Current_Temp_File_Name
(Pos
) :=
736 Character'Succ (Current_Temp_File_Name
(Pos
));
741 -- For 9, set the digit to 0 and go to the previous digit
743 Current_Temp_File_Name
(Pos
) := '0';
748 -- If it is not a digit, then there are no available
749 -- temp file names. Return Invalid_FD. There is almost
750 -- no that this code will be ever be executed, since
751 -- it would mean that there are one million temp files
752 -- in the same directory!
761 Current
:= Current_Temp_File_Name
;
763 -- We can now release the lock, because we are no longer
764 -- accessing Current_Temp_File_Name.
774 -- Attempt to create the file
776 FD
:= Create_New_File
(Current
, Binary
);
778 if FD
/= Invalid_FD
then
779 Name
:= new String'(Current);
783 if not Is_Regular_File (Current) then
785 -- If the file does not already exist and we are unable to create
786 -- it, we give up after Max_Attempts. Otherwise, we try again with
787 -- the next available file name.
789 Attempts := Attempts + 1;
791 if Attempts >= Max_Attempts then
798 end Create_Temp_File;
804 procedure Delete_File (Name : Address; Success : out Boolean) is
807 function unlink (A : Address) return Integer;
808 pragma Import (C, unlink, "unlink");
815 procedure Delete_File (Name : String; Success : out Boolean) is
816 C_Name : String (1 .. Name'Length + 1);
819 C_Name (1 .. Name'Length) := Name;
820 C_Name (C_Name'Last) := ASCII.NUL;
822 Delete_File (C_Name'Address, Success);
825 ---------------------
826 -- File_Time_Stamp --
827 ---------------------
829 function File_Time_Stamp (FD : File_Descriptor) return OS_Time is
830 function File_Time (FD : File_Descriptor) return OS_Time;
831 pragma Import (C, File_Time, "__gnat_file_time_fd");
834 return File_Time (FD);
837 function File_Time_Stamp (Name : C_File_Name) return OS_Time is
838 function File_Time (Name : Address) return OS_Time;
839 pragma Import (C, File_Time, "__gnat_file_time_name");
842 return File_Time (Name);
845 function File_Time_Stamp (Name : String) return OS_Time is
846 F_Name : String (1 .. Name'Length + 1);
849 F_Name (1 .. Name'Length) := Name;
850 F_Name (F_Name'Last) := ASCII.NUL;
851 return File_Time_Stamp (F_Name'Address);
854 ---------------------------
855 -- Get_Debuggable_Suffix --
856 ---------------------------
858 function Get_Debuggable_Suffix return String_Access is
859 procedure Get_Suffix_Ptr (Length, Ptr : Address);
860 pragma Import (C, Get_Suffix_Ptr, "__gnat_get_debuggable_suffix_ptr");
862 procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
863 pragma Import (C, Strncpy, "strncpy");
865 Suffix_Ptr : Address;
866 Suffix_Length : Integer;
867 Result : String_Access;
870 Get_Suffix_Ptr (Suffix_Length'Address, Suffix_Ptr'Address);
872 Result := new String (1 .. Suffix_Length);
874 if Suffix_Length > 0 then
875 Strncpy (Result.all'Address, Suffix_Ptr, Suffix_Length);
879 end Get_Debuggable_Suffix;
881 ---------------------------
882 -- Get_Executable_Suffix --
883 ---------------------------
885 function Get_Executable_Suffix return String_Access is
886 procedure Get_Suffix_Ptr (Length, Ptr : Address);
887 pragma Import (C, Get_Suffix_Ptr, "__gnat_get_executable_suffix_ptr");
889 procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
890 pragma Import (C, Strncpy, "strncpy");
892 Suffix_Ptr : Address;
893 Suffix_Length : Integer;
894 Result : String_Access;
897 Get_Suffix_Ptr (Suffix_Length'Address, Suffix_Ptr'Address);
899 Result := new String (1 .. Suffix_Length);
901 if Suffix_Length > 0 then
902 Strncpy (Result.all'Address, Suffix_Ptr, Suffix_Length);
906 end Get_Executable_Suffix;
908 -----------------------
909 -- Get_Object_Suffix --
910 -----------------------
912 function Get_Object_Suffix return String_Access is
913 procedure Get_Suffix_Ptr (Length, Ptr : Address);
914 pragma Import (C, Get_Suffix_Ptr, "__gnat_get_object_suffix_ptr");
916 procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
917 pragma Import (C, Strncpy, "strncpy");
919 Suffix_Ptr : Address;
920 Suffix_Length : Integer;
921 Result : String_Access;
924 Get_Suffix_Ptr (Suffix_Length'Address, Suffix_Ptr'Address);
926 Result := new String (1 .. Suffix_Length);
928 if Suffix_Length > 0 then
929 Strncpy (Result.all'Address, Suffix_Ptr, Suffix_Length);
933 end Get_Object_Suffix;
939 function Getenv (Name : String) return String_Access is
940 procedure Get_Env_Value_Ptr (Name, Length, Ptr : Address);
941 pragma Import (C, Get_Env_Value_Ptr, "__gnat_get_env_value_ptr");
943 procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
944 pragma Import (C, Strncpy, "strncpy");
946 Env_Value_Ptr : aliased Address;
947 Env_Value_Length : aliased Integer;
948 F_Name : aliased String (1 .. Name'Length + 1);
949 Result : String_Access;
952 F_Name (1 .. Name'Length) := Name;
953 F_Name (F_Name'Last) := ASCII.NUL;
956 (F_Name'Address, Env_Value_Length'Address, Env_Value_Ptr'Address);
958 Result := new String (1 .. Env_Value_Length);
960 if Env_Value_Length > 0 then
961 Strncpy (Result.all'Address, Env_Value_Ptr, Env_Value_Length);
971 function GM_Day (Date : OS_Time) return Day_Type is
980 GM_Split (Date, Y, Mo, D, H, Mn, S);
988 function GM_Hour (Date : OS_Time) return Hour_Type is
997 GM_Split (Date, Y, Mo, D, H, Mn, S);
1005 function GM_Minute (Date : OS_Time) return Minute_Type is
1014 GM_Split (Date, Y, Mo, D, H, Mn, S);
1022 function GM_Month (Date : OS_Time) return Month_Type is
1031 GM_Split (Date, Y, Mo, D, H, Mn, S);
1039 function GM_Second (Date : OS_Time) return Second_Type is
1048 GM_Split (Date, Y, Mo, D, H, Mn, S);
1058 Year : out Year_Type;
1059 Month : out Month_Type;
1061 Hour : out Hour_Type;
1062 Minute : out Minute_Type;
1063 Second : out Second_Type)
1065 procedure To_GM_Time
1066 (P_Time_T, P_Year, P_Month, P_Day, P_Hours, P_Mins, P_Secs : Address);
1067 pragma Import (C, To_GM_Time, "__gnat_to_gm_time");
1069 T : OS_Time := Date;
1078 -- Use the global lock because To_GM_Time is not thread safe.
1080 Locked_Processing : begin
1083 (T'Address, Y'Address, Mo'Address, D'Address,
1084 H'Address, Mn'Address, S'Address);
1085 SSL.Unlock_Task.all;
1089 SSL.Unlock_Task.all;
1091 end Locked_Processing;
1105 function GM_Year (Date : OS_Time) return Year_Type is
1114 GM_Split (Date, Y, Mo, D, H, Mn, S);
1118 ----------------------
1119 -- Is_Absolute_Path --
1120 ----------------------
1122 function Is_Absolute_Path (Name : String) return Boolean is
1123 function Is_Absolute_Path
1125 Length : Integer) return Integer;
1126 pragma Import (C, Is_Absolute_Path, "__gnat_is_absolute_path");
1129 return Is_Absolute_Path (Name'Address, Name'Length) /= 0;
1130 end Is_Absolute_Path;
1136 function Is_Directory (Name : C_File_Name) return Boolean is
1137 function Is_Directory (Name : Address) return Integer;
1138 pragma Import (C, Is_Directory, "__gnat_is_directory");
1141 return Is_Directory (Name) /= 0;
1144 function Is_Directory (Name : String) return Boolean is
1145 F_Name : String (1 .. Name'Length + 1);
1148 F_Name (1 .. Name'Length) := Name;
1149 F_Name (F_Name'Last) := ASCII.NUL;
1150 return Is_Directory (F_Name'Address);
1153 ---------------------
1154 -- Is_Regular_File --
1155 ---------------------
1157 function Is_Regular_File (Name : C_File_Name) return Boolean is
1158 function Is_Regular_File (Name : Address) return Integer;
1159 pragma Import (C, Is_Regular_File, "__gnat_is_regular_file");
1162 return Is_Regular_File (Name) /= 0;
1163 end Is_Regular_File;
1165 function Is_Regular_File (Name : String) return Boolean is
1166 F_Name : String (1 .. Name'Length + 1);
1169 F_Name (1 .. Name'Length) := Name;
1170 F_Name (F_Name'Last) := ASCII.NUL;
1171 return Is_Regular_File (F_Name'Address);
1172 end Is_Regular_File;
1174 ----------------------
1175 -- Is_Readable_File --
1176 ----------------------
1178 function Is_Readable_File (Name : C_File_Name) return Boolean is
1179 function Is_Readable_File (Name : Address) return Integer;
1180 pragma Import (C, Is_Readable_File, "__gnat_is_readable_file");
1183 return Is_Readable_File (Name) /= 0;
1184 end Is_Readable_File;
1186 function Is_Readable_File (Name : String) return Boolean is
1187 F_Name : String (1 .. Name'Length + 1);
1190 F_Name (1 .. Name'Length) := Name;
1191 F_Name (F_Name'Last) := ASCII.NUL;
1192 return Is_Readable_File (F_Name'Address);
1193 end Is_Readable_File;
1195 ----------------------
1196 -- Is_Writable_File --
1197 ----------------------
1199 function Is_Writable_File (Name : C_File_Name) return Boolean is
1200 function Is_Writable_File (Name : Address) return Integer;
1201 pragma Import (C, Is_Writable_File, "__gnat_is_writable_file");
1204 return Is_Writable_File (Name) /= 0;
1205 end Is_Writable_File;
1207 function Is_Writable_File (Name : String) return Boolean is
1208 F_Name : String (1 .. Name'Length + 1);
1211 F_Name (1 .. Name'Length) := Name;
1212 F_Name (F_Name'Last) := ASCII.NUL;
1213 return Is_Writable_File (F_Name'Address);
1214 end Is_Writable_File;
1216 ----------------------
1217 -- Is_Symbolic_Link --
1218 ----------------------
1220 function Is_Symbolic_Link (Name : C_File_Name) return Boolean is
1221 function Is_Symbolic_Link (Name : Address) return Integer;
1222 pragma Import (C, Is_Symbolic_Link, "__gnat_is_symbolic_link");
1225 return Is_Symbolic_Link (Name) /= 0;
1226 end Is_Symbolic_Link;
1228 function Is_Symbolic_Link (Name : String) return Boolean is
1229 F_Name : String (1 .. Name'Length + 1);
1232 F_Name (1 .. Name'Length) := Name;
1233 F_Name (F_Name'Last) := ASCII.NUL;
1234 return Is_Symbolic_Link (F_Name'Address);
1235 end Is_Symbolic_Link;
1237 -------------------------
1238 -- Locate_Exec_On_Path --
1239 -------------------------
1241 function Locate_Exec_On_Path
1242 (Exec_Name : String) return String_Access
1244 function Locate_Exec_On_Path (C_Exec_Name : Address) return Address;
1245 pragma Import (C, Locate_Exec_On_Path, "__gnat_locate_exec_on_path");
1247 procedure Free (Ptr : System.Address);
1248 pragma Import (C, Free, "free");
1250 C_Exec_Name : String (1 .. Exec_Name'Length + 1);
1251 Path_Addr : Address;
1253 Result : String_Access;
1256 C_Exec_Name (1 .. Exec_Name'Length) := Exec_Name;
1257 C_Exec_Name (C_Exec_Name'Last) := ASCII.NUL;
1259 Path_Addr := Locate_Exec_On_Path (C_Exec_Name'Address);
1260 Path_Len := C_String_Length (Path_Addr);
1262 if Path_Len = 0 then
1266 Result := To_Path_String_Access (Path_Addr, Path_Len);
1270 end Locate_Exec_On_Path;
1272 -------------------------
1273 -- Locate_Regular_File --
1274 -------------------------
1276 function Locate_Regular_File
1277 (File_Name : C_File_Name;
1278 Path : C_File_Name) return String_Access
1280 function Locate_Regular_File
1281 (C_File_Name, Path_Val : Address) return Address;
1282 pragma Import (C, Locate_Regular_File, "__gnat_locate_regular_file");
1284 procedure Free (Ptr : System.Address);
1285 pragma Import (C, Free, "free");
1287 Path_Addr : Address;
1289 Result : String_Access;
1292 Path_Addr := Locate_Regular_File (File_Name, Path);
1293 Path_Len := C_String_Length (Path_Addr);
1295 if Path_Len = 0 then
1298 Result := To_Path_String_Access (Path_Addr, Path_Len);
1302 end Locate_Regular_File;
1304 function Locate_Regular_File
1305 (File_Name : String;
1306 Path : String) return String_Access
1308 C_File_Name : String (1 .. File_Name'Length + 1);
1309 C_Path : String (1 .. Path'Length + 1);
1312 C_File_Name (1 .. File_Name'Length) := File_Name;
1313 C_File_Name (C_File_Name'Last) := ASCII.NUL;
1315 C_Path (1 .. Path'Length) := Path;
1316 C_Path (C_Path'Last) := ASCII.NUL;
1318 return Locate_Regular_File (C_File_Name'Address, C_Path'Address);
1319 end Locate_Regular_File;
1321 ------------------------
1322 -- Non_Blocking_Spawn --
1323 ------------------------
1325 function Non_Blocking_Spawn
1326 (Program_Name : String;
1327 Args : Argument_List) return Process_Id
1333 Spawn_Internal (Program_Name, Args, Junk, Pid, Blocking => False);
1335 end Non_Blocking_Spawn;
1337 -------------------------
1338 -- Normalize_Arguments --
1339 -------------------------
1341 procedure Normalize_Arguments (Args : in out Argument_List) is
1343 procedure Quote_Argument (Arg : in out String_Access);
1344 -- Add quote around argument if it contains spaces
1346 C_Argument_Needs_Quote : Integer;
1347 pragma Import (C, C_Argument_Needs_Quote, "__gnat_argument_needs_quote");
1348 Argument_Needs_Quote : constant Boolean := C_Argument_Needs_Quote /= 0;
1350 --------------------
1351 -- Quote_Argument --
1352 --------------------
1354 procedure Quote_Argument (Arg : in out String_Access) is
1355 Res : String (1 .. Arg'Length * 2);
1357 Quote_Needed : Boolean := False;
1360 if Arg (Arg'First) /= '"' or else Arg (Arg'Last) /= '"' then
1366 for K in Arg'Range loop
1370 if Arg (K) = '"' then
1374 Quote_Needed := True;
1376 elsif Arg (K) = ' ' then
1378 Quote_Needed := True;
1386 if Quote_Needed then
1388 -- If null terminated string, put the quote before
1390 if Res (J) = ASCII.Nul then
1393 Res (J) := ASCII.Nul;
1395 -- If argument is terminated by '\
', then double it. Otherwise
1396 -- the ending quote will be taken as-is. This is quite strange
1397 -- spawn behavior from Windows, but this is what we see!
1400 if Res (J) = '\
' then
1412 Old : String_Access := Arg;
1415 Arg := new String'(Res (1 .. J));
1424 if Argument_Needs_Quote then
1425 for K in Args'Range loop
1426 if Args (K) /= null and then Args (K)'Length /= 0 then
1427 Quote_Argument (Args (K));
1431 end Normalize_Arguments;
1433 ------------------------
1434 -- Normalize_Pathname --
1435 ------------------------
1437 function Normalize_Pathname
1439 Directory : String := "";
1440 Resolve_Links : Boolean := True;
1441 Case_Sensitive : Boolean := True) return String
1444 pragma Import (C, Max_Path, "__gnat_max_path_len
");
1445 -- Maximum length of a path name
1447 procedure Get_Current_Dir
1448 (Dir : System.Address;
1449 Length : System.Address);
1450 pragma Import (C, Get_Current_Dir, "__gnat_get_current_dir
");
1452 function Change_Dir (Dir_Name : String) return Integer;
1453 pragma Import (C, Change_Dir, "chdir
");
1455 Path_Buffer : String (1 .. Max_Path + Max_Path + 2);
1456 End_Path : Natural := 0;
1457 Link_Buffer : String (1 .. Max_Path + 2);
1463 Max_Iterations : constant := 500;
1465 function Get_File_Names_Case_Sensitive return Integer;
1467 (C, Get_File_Names_Case_Sensitive,
1468 "__gnat_get_file_names_case_sensitive
");
1470 Fold_To_Lower_Case : constant Boolean :=
1472 and then Get_File_Names_Case_Sensitive = 0;
1475 (Path : System.Address;
1476 Buf : System.Address;
1477 Bufsiz : Integer) return Integer;
1478 pragma Import (C, Readlink, "__gnat_readlink
");
1480 function To_Canonical_File_Spec
1481 (Host_File : System.Address) return System.Address;
1483 (C, To_Canonical_File_Spec, "__gnat_to_canonical_file_spec
");
1485 The_Name : String (1 .. Name'Length + 1);
1486 Canonical_File_Addr : System.Address;
1487 Canonical_File_Len : Integer;
1489 Need_To_Check_Drive_Letter : Boolean := False;
1490 -- Set to true if Name is an absolute path that starts with "//"
1492 function Strlen (S : System.Address) return Integer;
1493 pragma Import (C, Strlen, "strlen
");
1495 function Get_Directory (Dir : String) return String;
1496 -- If Dir is not empty, return it, adding a directory separator
1497 -- if not already present, otherwise return current working directory
1498 -- with terminating directory separator.
1500 function Final_Value (S : String) return String;
1501 -- Make final adjustment to the returned string.
1502 -- To compensate for non standard path name in Interix,
1503 -- if S is "/x
" or starts with "/x
", where x is a capital
1504 -- letter 'A' to 'Z', add an additional '/' at the beginning
1505 -- so that the returned value starts with "//x
".
1511 function Get_Directory (Dir : String) return String is
1513 -- Directory given, add directory separator if needed
1515 if Dir'Length > 0 then
1516 if Dir (Dir'Length) = Directory_Separator then
1520 Result : String (1 .. Dir'Length + 1);
1523 Result (1 .. Dir'Length) := Dir;
1524 Result (Result'Length) := Directory_Separator;
1529 -- Directory name not given, get current directory
1533 Buffer : String (1 .. Max_Path + 2);
1534 Path_Len : Natural := Max_Path;
1537 Get_Current_Dir (Buffer'Address, Path_Len'Address);
1539 if Buffer (Path_Len) /= Directory_Separator then
1540 Path_Len := Path_Len + 1;
1541 Buffer (Path_Len) := Directory_Separator;
1544 -- By default, the drive letter on Windows is in upper case
1546 if On_Windows and then Path_Len >= 2 and then
1549 System.Case_Util.To_Upper (Buffer (1 .. 1));
1552 return Buffer (1 .. Path_Len);
1557 Reference_Dir : constant String := Get_Directory (Directory);
1558 -- Current directory name specified
1564 function Final_Value (S : String) return String is
1566 -- We may need to fold S to lower case, so we need a variable
1571 -- Interix has the non standard notion of disk drive
1572 -- indicated by two '/' followed by a capital letter
1573 -- 'A' .. 'Z'. One of the two '/' may have been removed
1574 -- by Normalize_Pathname. It has to be added again.
1575 -- For other OSes, this should not make no difference.
1577 if Need_To_Check_Drive_Letter
1578 and then S'Length >= 2
1579 and then S (S'First) = '/'
1580 and then S (S'First + 1) in 'A' .. 'Z'
1581 and then (S'Length = 2 or else S (S'First + 2) = '/')
1584 Result : String (1 .. S'Length + 1);
1588 Result (2 .. Result'Last) := S;
1589 Last := Result'Last;
1591 if Fold_To_Lower_Case then
1592 System.Case_Util.To_Lower (Result);
1595 -- Remove trailing directory separator, if any
1597 if Last > 1 and then
1598 (Result (Last) = '/' or else
1599 Result (Last) = Directory_Separator)
1604 return Result (1 .. Last);
1608 if Fold_To_Lower_Case then
1609 System.Case_Util.To_Lower (S1);
1612 -- Remove trailing directory separator, if any
1617 and then (S1 (Last) = '/'
1619 S1 (Last) = Directory_Separator)
1621 -- Special case for Windows: C:\
1624 and then S1 (1) /= Directory_Separator
1625 and then S1 (2) = ':'
1634 return S1 (1 .. Last);
1638 -- Start of processing for Normalize_Pathname
1641 -- Special case, if name is null, then return null
1643 if Name'Length = 0 then
1647 -- First, convert VMS file spec to Unix file spec.
1648 -- If Name is not in VMS syntax, then this is equivalent
1649 -- to put Name at the begining of Path_Buffer.
1651 VMS_Conversion : begin
1652 The_Name (1 .. Name'Length) := Name;
1653 The_Name (The_Name'Last) := ASCII.NUL;
1655 Canonical_File_Addr := To_Canonical_File_Spec (The_Name'Address);
1656 Canonical_File_Len := Strlen (Canonical_File_Addr);
1658 -- If VMS syntax conversion has failed, return an empty string
1659 -- to indicate the failure.
1661 if Canonical_File_Len = 0 then
1666 subtype Path_String is String (1 .. Canonical_File_Len);
1667 type Path_String_Access is access Path_String;
1669 function Address_To_Access is new
1670 Unchecked_Conversion (Source => Address,
1671 Target => Path_String_Access);
1673 Path_Access : constant Path_String_Access :=
1674 Address_To_Access (Canonical_File_Addr);
1677 Path_Buffer (1 .. Canonical_File_Len) := Path_Access.all;
1678 End_Path := Canonical_File_Len;
1683 -- Replace all '/' by Directory Separators (this is for Windows)
1685 if Directory_Separator /= '/' then
1686 for Index in 1 .. End_Path loop
1687 if Path_Buffer (Index) = '/' then
1688 Path_Buffer (Index) := Directory_Separator;
1693 -- Resolve directory names for VMS and Windows
1695 -- On VMS, if we have a Unix path such as /temp/..., and TEMP is a
1696 -- logical name, we need to resolve this logical name.
1698 -- On Windows, if we have an absolute path starting with a directory
1699 -- separator, we need to have the drive letter appended in front.
1701 -- For both platforms, Get_Current_Dir will return a suitable
1702 -- directory name (logical names resolved on VMS, path starting with
1703 -- a drive letter on Windows). So we find the directory, change to it,
1704 -- call Get_Current_Dir and change the directory to the returned value.
1705 -- Then, of course, we return to the previous directory.
1707 if (OpenVMS or On_Windows)
1708 and then Path_Buffer (1) = Directory_Separator
1711 Cur_Dir : String := Get_Directory ("");
1712 -- Save the current directory, so that we can change dir back to
1713 -- it. It is not a constant, because the last character (a
1714 -- directory separator) is changed to ASCII.NUL to call the C
1717 Path : String := Path_Buffer (1 .. End_Path + 1);
1718 -- Copy of the current path. One character is added that may be
1719 -- set to ASCII.NUL to call chdir.
1721 Pos : Positive := End_Path;
1722 -- Position of the last directory separator
1725 -- Value returned by chdir
1728 -- Look for the last directory separator
1730 while Path (Pos) /= Directory_Separator loop
1734 -- Get the previous character that is not a directory separator
1736 while Pos > 1 and then Path (Pos) = Directory_Separator loop
1740 -- If we are at the start of the path, take the full path.
1741 -- It may be a file in the root directory, but it may also be
1742 -- a subdirectory of the root directory.
1748 -- Add the ASCII.NUL to be able to call the C function chdir
1749 Path (Pos + 1) := ASCII.NUL;
1751 Status := Change_Dir (Path (1 .. Pos + 1));
1753 -- If Status is not zero, then we do nothing: this is a file
1754 -- path or it is not a valid directory path.
1758 New_Dir : constant String := Get_Directory ("");
1759 -- The directory path
1761 New_Path : String (1 .. New_Dir'Length + End_Path - Pos);
1762 -- The new complete path, that is built below
1765 New_Path (1 .. New_Dir'Length) := New_Dir;
1766 New_Path (New_Dir'Length + 1 .. New_Path'Last) :=
1767 Path_Buffer (Pos + 1 .. End_Path);
1768 End_Path := New_Path'Length;
1769 Path_Buffer (1 .. End_Path) := New_Path;
1772 -- Back to where we were before
1774 Cur_Dir (Cur_Dir'Last) := ASCII.NUL;
1775 Status := Change_Dir (Cur_Dir);
1780 -- Start the conversions
1782 -- If this is not finished after Max_Iterations, give up and
1783 -- return an empty string.
1785 for J in 1 .. Max_Iterations loop
1787 -- If we don't have an absolute pathname, prepend
1788 -- the directory Reference_Dir.
1791 and then not Is_Absolute_Path (Path_Buffer (1 .. End_Path))
1794 (Reference_Dir'Last + 1 .. Reference_Dir'Length + End_Path) :=
1795 Path_Buffer (1 .. End_Path);
1796 End_Path := Reference_Dir'Length + End_Path;
1797 Path_Buffer (1 .. Reference_Dir'Length) := Reference_Dir;
1798 Last := Reference_Dir'Length;
1801 -- If name starts with "//", we may have a drive letter on Interix
1803 if Last = 1 and then End_Path >= 3 then
1804 Need_To_Check_Drive_Letter := (Path_Buffer (1 .. 2)) = "//";
1810 -- Ensure that Windows network drives are kept, e.g: \\server\drive-c
1813 and then Directory_Separator = '\'
1814 and then Path_Buffer (1 .. 2) = "\\"
1819 -- If we have traversed the full pathname, return it
1821 if Start > End_Path then
1822 return Final_Value (Path_Buffer (1 .. End_Path));
1825 -- Remove duplicate directory separators
1827 while Path_Buffer (Start) = Directory_Separator loop
1828 if Start = End_Path then
1829 return Final_Value (Path_Buffer (1 .. End_Path - 1));
1832 Path_Buffer (Start .. End_Path - 1) :=
1833 Path_Buffer (Start + 1 .. End_Path);
1834 End_Path := End_Path - 1;
1838 -- Find the end of the current field: last character
1839 -- or the one preceding the next directory separator.
1841 while Finish < End_Path
1842 and then Path_Buffer (Finish + 1) /= Directory_Separator
1844 Finish := Finish + 1;
1849 if Start = Finish and then Path_Buffer (Start) = '.' then
1850 if Start = End_Path then
1852 return (1 => Directory_Separator);
1855 if Fold_To_Lower_Case then
1856 System.Case_Util.To_Lower (Path_Buffer (1 .. Last - 1));
1859 return Path_Buffer (1 .. Last - 1);
1864 Path_Buffer (Last + 1 .. End_Path - 2) :=
1865 Path_Buffer (Last + 3 .. End_Path);
1866 End_Path := End_Path - 2;
1869 -- Remove ".." fields
1871 elsif Finish = Start + 1
1872 and then Path_Buffer (Start .. Finish) = ".."
1877 exit when Start < 1 or else
1878 Path_Buffer (Start) = Directory_Separator;
1882 if Finish = End_Path then
1883 return (1 => Directory_Separator);
1886 Path_Buffer (1 .. End_Path - Finish) :=
1887 Path_Buffer (Finish + 1 .. End_Path);
1888 End_Path := End_Path - Finish;
1893 if Finish = End_Path then
1894 return Final_Value (Path_Buffer (1 .. Start - 1));
1897 Path_Buffer (Start + 1 .. Start + End_Path - Finish - 1) :=
1898 Path_Buffer (Finish + 2 .. End_Path);
1899 End_Path := Start + End_Path - Finish - 1;
1904 -- Check if current field is a symbolic link
1906 elsif Resolve_Links then
1908 Saved : constant Character := Path_Buffer (Finish + 1);
1911 Path_Buffer (Finish + 1) := ASCII.NUL;
1912 Status := Readlink (Path_Buffer'Address,
1913 Link_Buffer'Address,
1914 Link_Buffer'Length);
1915 Path_Buffer (Finish + 1) := Saved;
1918 -- Not a symbolic link, move to the next field, if any
1923 -- Replace symbolic link with its value.
1926 if Is_Absolute_Path (Link_Buffer (1 .. Status)) then
1927 Path_Buffer (Status + 1 .. End_Path - (Finish - Status)) :=
1928 Path_Buffer (Finish + 1 .. End_Path);
1929 End_Path := End_Path - (Finish - Status);
1930 Path_Buffer (1 .. Status) := Link_Buffer (1 .. Status);
1935 (Last + Status + 1 .. End_Path - Finish + Last + Status) :=
1936 Path_Buffer (Finish + 1 .. End_Path);
1937 End_Path := End_Path - Finish + Last + Status;
1938 Path_Buffer (Last + 1 .. Last + Status) :=
1939 Link_Buffer (1 .. Status);
1948 -- Too many iterations: give up
1950 -- This can happen when there is a circularity in the symbolic links:
1951 -- A is a symbolic link for B, which itself is a symbolic link, and
1952 -- the target of B or of another symbolic link target of B is A.
1953 -- In this case, we return an empty string to indicate failure to
1957 end Normalize_Pathname;
1964 (Name : C_File_Name;
1965 Fmode : Mode) return File_Descriptor
1967 function C_Open_Read
1968 (Name : C_File_Name;
1969 Fmode : Mode) return File_Descriptor;
1970 pragma Import (C, C_Open_Read, "__gnat_open_read
");
1972 return C_Open_Read (Name, Fmode);
1977 Fmode : Mode) return File_Descriptor
1979 C_Name : String (1 .. Name'Length + 1);
1981 C_Name (1 .. Name'Length) := Name;
1982 C_Name (C_Name'Last) := ASCII.NUL;
1983 return Open_Read (C_Name (C_Name'First)'Address, Fmode);
1986 ---------------------
1987 -- Open_Read_Write --
1988 ---------------------
1990 function Open_Read_Write
1991 (Name : C_File_Name;
1992 Fmode : Mode) return File_Descriptor
1994 function C_Open_Read_Write
1995 (Name : C_File_Name;
1996 Fmode : Mode) return File_Descriptor;
1997 pragma Import (C, C_Open_Read_Write, "__gnat_open_rw
");
1999 return C_Open_Read_Write (Name, Fmode);
2000 end Open_Read_Write;
2002 function Open_Read_Write
2004 Fmode : Mode) return File_Descriptor
2006 C_Name : String (1 .. Name'Length + 1);
2008 C_Name (1 .. Name'Length) := Name;
2009 C_Name (C_Name'Last) := ASCII.NUL;
2010 return Open_Read_Write (C_Name (C_Name'First)'Address, Fmode);
2011 end Open_Read_Write;
2018 (FD : File_Descriptor;
2020 N : Integer) return Integer
2023 return Integer (System.CRTL.read
2024 (System.CRTL.int (FD), System.CRTL.chars (A), System.CRTL.int (N)));
2031 procedure Rename_File
2032 (Old_Name : C_File_Name;
2033 New_Name : C_File_Name;
2034 Success : out Boolean)
2036 function rename (From, To : Address) return Integer;
2037 pragma Import (C, rename, "rename
");
2040 R := rename (Old_Name, New_Name);
2044 procedure Rename_File
2047 Success : out Boolean)
2049 C_Old_Name : String (1 .. Old_Name'Length + 1);
2050 C_New_Name : String (1 .. New_Name'Length + 1);
2052 C_Old_Name (1 .. Old_Name'Length) := Old_Name;
2053 C_Old_Name (C_Old_Name'Last) := ASCII.NUL;
2054 C_New_Name (1 .. New_Name'Length) := New_Name;
2055 C_New_Name (C_New_Name'Last) := ASCII.NUL;
2056 Rename_File (C_Old_Name'Address, C_New_Name'Address, Success);
2063 procedure Setenv (Name : String; Value : String) is
2064 F_Name : String (1 .. Name'Length + 1);
2065 F_Value : String (1 .. Value'Length + 1);
2067 procedure Set_Env_Value (Name, Value : System.Address);
2068 pragma Import (C, Set_Env_Value, "__gnat_set_env_value
");
2071 F_Name (1 .. Name'Length) := Name;
2072 F_Name (F_Name'Last) := ASCII.NUL;
2074 F_Value (1 .. Value'Length) := Value;
2075 F_Value (F_Value'Last) := ASCII.NUL;
2077 Set_Env_Value (F_Name'Address, F_Value'Address);
2085 (Program_Name : String;
2086 Args : Argument_List) return Integer
2091 Spawn_Internal (Program_Name, Args, Result, Junk, Blocking => True);
2096 (Program_Name : String;
2097 Args : Argument_List;
2098 Success : out Boolean)
2101 Success := (Spawn (Program_Name, Args) = 0);
2104 --------------------
2105 -- Spawn_Internal --
2106 --------------------
2108 procedure Spawn_Internal
2109 (Program_Name : String;
2110 Args : Argument_List;
2111 Result : out Integer;
2112 Pid : out Process_Id;
2116 procedure Spawn (Args : Argument_List);
2119 N_Args : Argument_List (Args'Range);
2120 -- Normalized arguments
2126 procedure Spawn (Args : Argument_List) is
2127 type Chars is array (Positive range <>) of aliased Character;
2128 type Char_Ptr is access constant Character;
2130 Command_Len : constant Positive := Program_Name'Length + 1
2131 + Args_Length (Args);
2132 Command_Last : Natural := 0;
2133 Command : aliased Chars (1 .. Command_Len);
2134 -- Command contains all characters of the Program_Name and Args,
2135 -- all terminated by ASCII.NUL characters
2137 Arg_List_Len : constant Positive := Args'Length + 2;
2138 Arg_List_Last : Natural := 0;
2139 Arg_List : aliased array (1 .. Arg_List_Len) of Char_Ptr;
2140 -- List with pointers to NUL-terminated strings of the
2141 -- Program_Name and the Args and terminated with a null pointer.
2142 -- We rely on the default initialization for the last null pointer.
2144 procedure Add_To_Command (S : String);
2145 -- Add S and a NUL character to Command, updating Last
2147 function Portable_Spawn (Args : Address) return Integer;
2148 pragma Import (C, Portable_Spawn, "__gnat_portable_spawn
");
2150 function Portable_No_Block_Spawn (Args : Address) return Process_Id;
2152 (C, Portable_No_Block_Spawn, "__gnat_portable_no_block_spawn
");
2154 --------------------
2155 -- Add_To_Command --
2156 --------------------
2158 procedure Add_To_Command (S : String) is
2159 First : constant Natural := Command_Last + 1;
2162 Command_Last := Command_Last + S'Length;
2164 -- Move characters one at a time, because Command has
2165 -- aliased components.
2167 for J in S'Range loop
2168 Command (First + J - S'First) := S (J);
2171 Command_Last := Command_Last + 1;
2172 Command (Command_Last) := ASCII.NUL;
2174 Arg_List_Last := Arg_List_Last + 1;
2175 Arg_List (Arg_List_Last) := Command (First)'Access;
2178 -- Start of processing for Spawn
2181 Add_To_Command (Program_Name);
2183 for J in Args'Range loop
2184 Add_To_Command (Args (J).all);
2189 Result := Portable_Spawn (Arg_List'Address);
2191 Pid := Portable_No_Block_Spawn (Arg_List'Address);
2192 Result := Boolean'Pos (Pid /= Invalid_Pid);
2196 -- Start of processing for Spawn_Internal
2199 -- Copy arguments into a local structure
2201 for K in N_Args'Range loop
2202 N_Args (K) := new String'(Args (K).all);
2205 -- Normalize those arguments
2207 Normalize_Arguments (N_Args);
2209 -- Call spawn using the normalized arguments
2213 -- Free arguments list
2215 for K in N_Args'Range loop
2220 ---------------------------
2221 -- To_Path_String_Access --
2222 ---------------------------
2224 function To_Path_String_Access
2225 (Path_Addr : Address;
2226 Path_Len : Integer) return String_Access
2228 subtype Path_String is String (1 .. Path_Len);
2229 type Path_String_Access is access Path_String;
2231 function Address_To_Access is new
2232 Unchecked_Conversion (Source => Address,
2233 Target => Path_String_Access);
2235 Path_Access : constant Path_String_Access :=
2236 Address_To_Access (Path_Addr);
2238 Return_Val : String_Access;
2241 Return_Val := new String (1 .. Path_Len);
2243 for J in 1 .. Path_Len loop
2244 Return_Val (J) := Path_Access (J);
2248 end To_Path_String_Access;
2254 procedure Wait_Process (Pid : out Process_Id; Success : out Boolean) is
2257 function Portable_Wait (S : Address) return Process_Id;
2258 pragma Import (C, Portable_Wait, "__gnat_portable_wait
");
2261 Pid := Portable_Wait (Status'Address);
2262 Success := (Status = 0);
2270 (FD : File_Descriptor;
2272 N : Integer) return Integer
2275 return Integer (System.CRTL.write
2276 (System.CRTL.int (FD), System.CRTL.chars (A), System.CRTL.int (N)));