1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
5 -- G N A T . O S _ L I B --
11 -- Copyright (C) 1995-2001 Ada Core Technologies, Inc. --
13 -- GNAT is free software; you can redistribute it and/or modify it under --
14 -- terms of the GNU General Public License as published by the Free Soft- --
15 -- ware Foundation; either version 2, or (at your option) any later ver- --
16 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
17 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
18 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
19 -- for more details. You should have received a copy of the GNU General --
20 -- Public License distributed with GNAT; see file COPYING. If not, write --
21 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
22 -- MA 02111-1307, USA. --
24 -- As a special exception, if other files instantiate generics from this --
25 -- unit, or you link this unit with other files to produce an executable, --
26 -- this unit does not by itself cause the resulting executable to be --
27 -- covered by the GNU General Public License. This exception does not --
28 -- however invalidate any other reasons why the executable file might be --
29 -- covered by the GNU Public License. --
31 -- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
33 ------------------------------------------------------------------------------
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 -----------------------
44 -- Local Subprograms --
45 -----------------------
47 function Args_Length (Args : Argument_List) return Natural;
48 -- Returns total number of characters needed to create a string
49 -- of all Args terminated by ASCII.NUL characters
51 function C_String_Length (S : Address) return Integer;
52 -- Returns the length of a C string. Does check for null address
55 procedure Spawn_Internal
56 (Program_Name : String;
61 -- Internal routine to implement the to Spawn (blocking and non blocking)
62 -- routines. If Blocking is set to True then the spawn is blocking
63 -- otherwise it is non blocking. In this latter case the Pid contains
64 -- the process id number. The first three parameters are as in Spawn.
66 function To_Path_String_Access
70 -- Converts a C String to an Ada String. We could do this making use of
71 -- Interfaces.C.Strings but we prefer not to import that entire package
77 function Args_Length (Args : Argument_List) return Natural is
81 for J in Args'Range loop
82 Len := Len + Args (J)'Length + 1; -- One extra for ASCII.NUL
88 -----------------------------
89 -- Argument_String_To_List --
90 -----------------------------
92 function Argument_String_To_List
94 return Argument_List_Access
96 Max_Args : Integer := Arg_String'Length;
97 New_Argv : Argument_List (1 .. Max_Args);
98 New_Argc : Natural := 0;
102 Idx := Arg_String'First;
106 Quoted : Boolean := False;
107 Backqd : Boolean := False;
114 -- A vanilla space is the end of an argument
116 if not Backqd and then not Quoted
117 and then Arg_String (Idx) = ' '
121 -- Start of a quoted string
123 elsif not Backqd and then not Quoted
124 and then Arg_String (Idx) = '"'
128 -- End of a quoted string and end of an argument
130 elsif not Backqd and then Quoted
131 and then Arg_String (Idx) = '"'
136 -- Following character is backquoted
138 elsif Arg_String (Idx) = '\' then
141 -- Turn off backquoting after advancing one character
149 exit when Idx > Arg_String'Last;
154 New_Argc := New_Argc + 1;
155 New_Argv (New_Argc) :=
156 new String'(Arg_String (Old_Idx .. Idx - 1));
158 -- Skip extraneous spaces
160 while Idx <= Arg_String'Last and then Arg_String (Idx) = ' ' loop
165 exit when Idx > Arg_String'Last;
168 return new Argument_List'(New_Argv (1 .. New_Argc));
169 end Argument_String_To_List;
171 ---------------------
172 -- C_String_Length --
173 ---------------------
175 function C_String_Length (S : Address) return Integer is
176 function Strlen (S : Address) return Integer;
177 pragma Import (C, Strlen, "strlen");
180 if S = Null_Address then
194 return File_Descriptor
196 function C_Create_File
199 return File_Descriptor;
200 pragma Import (C, C_Create_File, "__gnat_open_create");
203 return C_Create_File (Name, Fmode);
209 return File_Descriptor
211 C_Name : String (1 .. Name'Length + 1);
214 C_Name (1 .. Name'Length) := Name;
215 C_Name (C_Name'Last) := ASCII.NUL;
216 return Create_File (C_Name (C_Name'First)'Address, Fmode);
219 ---------------------
220 -- Create_New_File --
221 ---------------------
223 function Create_New_File
226 return File_Descriptor
228 function C_Create_New_File
231 return File_Descriptor;
232 pragma Import (C, C_Create_New_File, "__gnat_open_new");
235 return C_Create_New_File (Name, Fmode);
238 function Create_New_File
241 return File_Descriptor
243 C_Name : String (1 .. Name'Length + 1);
246 C_Name (1 .. Name'Length) := Name;
247 C_Name (C_Name'Last) := ASCII.NUL;
248 return Create_New_File (C_Name (C_Name'First)'Address, Fmode);
251 ----------------------
252 -- Create_Temp_File --
253 ----------------------
255 procedure Create_Temp_File
256 (FD : out File_Descriptor;
257 Name : out Temp_File_Name)
259 function Open_New_Temp
260 (Name : System.Address;
262 return File_Descriptor;
263 pragma Import (C, Open_New_Temp, "__gnat_open_new_temp");
266 FD := Open_New_Temp (Name'Address, Binary);
267 end Create_Temp_File;
273 procedure Delete_File (Name : Address; Success : out Boolean) is
276 function unlink (A : Address) return Integer;
277 pragma Import (C, unlink, "unlink");
284 procedure Delete_File (Name : String; Success : out Boolean) is
285 C_Name : String (1 .. Name'Length + 1);
288 C_Name (1 .. Name'Length) := Name;
289 C_Name (C_Name'Last) := ASCII.NUL;
291 Delete_File (C_Name'Address, Success);
294 ---------------------
295 -- File_Time_Stamp --
296 ---------------------
298 function File_Time_Stamp (FD : File_Descriptor) return OS_Time is
299 function File_Time (FD : File_Descriptor) return OS_Time;
300 pragma Import (C, File_Time, "__gnat_file_time_fd");
303 return File_Time (FD);
306 function File_Time_Stamp (Name : C_File_Name) return OS_Time is
307 function File_Time (Name : Address) return OS_Time;
308 pragma Import (C, File_Time, "__gnat_file_time_name");
311 return File_Time (Name);
314 function File_Time_Stamp (Name : String) return OS_Time is
315 F_Name : String (1 .. Name'Length + 1);
318 F_Name (1 .. Name'Length) := Name;
319 F_Name (F_Name'Last) := ASCII.NUL;
320 return File_Time_Stamp (F_Name'Address);
323 ---------------------------
324 -- Get_Debuggable_Suffix --
325 ---------------------------
327 function Get_Debuggable_Suffix return String_Access is
328 procedure Get_Suffix_Ptr (Length, Ptr : Address);
329 pragma Import (C, Get_Suffix_Ptr, "__gnat_get_debuggable_suffix_ptr");
331 procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
332 pragma Import (C, Strncpy, "strncpy");
334 Suffix_Ptr : Address;
335 Suffix_Length : Integer;
336 Result : String_Access;
339 Get_Suffix_Ptr (Suffix_Length'Address, Suffix_Ptr'Address);
341 Result := new String (1 .. Suffix_Length);
343 if Suffix_Length > 0 then
344 Strncpy (Result.all'Address, Suffix_Ptr, Suffix_Length);
348 end Get_Debuggable_Suffix;
350 ---------------------------
351 -- Get_Executable_Suffix --
352 ---------------------------
354 function Get_Executable_Suffix return String_Access is
355 procedure Get_Suffix_Ptr (Length, Ptr : Address);
356 pragma Import (C, Get_Suffix_Ptr, "__gnat_get_executable_suffix_ptr");
358 procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
359 pragma Import (C, Strncpy, "strncpy");
361 Suffix_Ptr : Address;
362 Suffix_Length : Integer;
363 Result : String_Access;
366 Get_Suffix_Ptr (Suffix_Length'Address, Suffix_Ptr'Address);
368 Result := new String (1 .. Suffix_Length);
370 if Suffix_Length > 0 then
371 Strncpy (Result.all'Address, Suffix_Ptr, Suffix_Length);
375 end Get_Executable_Suffix;
377 -----------------------
378 -- Get_Object_Suffix --
379 -----------------------
381 function Get_Object_Suffix return String_Access is
382 procedure Get_Suffix_Ptr (Length, Ptr : Address);
383 pragma Import (C, Get_Suffix_Ptr, "__gnat_get_object_suffix_ptr");
385 procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
386 pragma Import (C, Strncpy, "strncpy");
388 Suffix_Ptr : Address;
389 Suffix_Length : Integer;
390 Result : String_Access;
393 Get_Suffix_Ptr (Suffix_Length'Address, Suffix_Ptr'Address);
395 Result := new String (1 .. Suffix_Length);
397 if Suffix_Length > 0 then
398 Strncpy (Result.all'Address, Suffix_Ptr, Suffix_Length);
402 end Get_Object_Suffix;
408 function Getenv (Name : String) return String_Access is
409 procedure Get_Env_Value_Ptr (Name, Length, Ptr : Address);
410 pragma Import (C, Get_Env_Value_Ptr, "__gnat_get_env_value_ptr");
412 procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
413 pragma Import (C, Strncpy, "strncpy");
415 Env_Value_Ptr : Address;
416 Env_Value_Length : Integer;
417 F_Name : String (1 .. Name'Length + 1);
418 Result : String_Access;
421 F_Name (1 .. Name'Length) := Name;
422 F_Name (F_Name'Last) := ASCII.NUL;
425 (F_Name'Address, Env_Value_Length'Address, Env_Value_Ptr'Address);
427 Result := new String (1 .. Env_Value_Length);
429 if Env_Value_Length > 0 then
430 Strncpy (Result.all'Address, Env_Value_Ptr, Env_Value_Length);
440 function GM_Day (Date : OS_Time) return Day_Type is
449 GM_Split (Date, Y, Mo, D, H, Mn, S);
457 function GM_Hour (Date : OS_Time) return Hour_Type is
466 GM_Split (Date, Y, Mo, D, H, Mn, S);
474 function GM_Minute (Date : OS_Time) return Minute_Type is
483 GM_Split (Date, Y, Mo, D, H, Mn, S);
491 function GM_Month (Date : OS_Time) return Month_Type is
500 GM_Split (Date, Y, Mo, D, H, Mn, S);
508 function GM_Second (Date : OS_Time) return Second_Type is
517 GM_Split (Date, Y, Mo, D, H, Mn, S);
527 Year : out Year_Type;
528 Month : out Month_Type;
530 Hour : out Hour_Type;
531 Minute : out Minute_Type;
532 Second : out Second_Type)
535 (P_Time_T, P_Year, P_Month, P_Day, P_Hours, P_Mins, P_Secs : Address);
536 pragma Import (C, To_GM_Time, "__gnat_to_gm_time");
547 -- Use the global lock because To_GM_Time is not thread safe.
549 Locked_Processing : begin
552 (T'Address, Y'Address, Mo'Address, D'Address,
553 H'Address, Mn'Address, S'Address);
560 end Locked_Processing;
574 function GM_Year (Date : OS_Time) return Year_Type is
583 GM_Split (Date, Y, Mo, D, H, Mn, S);
587 ----------------------
588 -- Is_Absolute_Path --
589 ----------------------
591 function Is_Absolute_Path (Name : String) return Boolean is
592 function Is_Absolute_Path (Name : Address) return Integer;
593 pragma Import (C, Is_Absolute_Path, "__gnat_is_absolute_path");
595 F_Name : String (1 .. Name'Length + 1);
598 F_Name (1 .. Name'Length) := Name;
599 F_Name (F_Name'Last) := ASCII.NUL;
601 return Is_Absolute_Path (F_Name'Address) /= 0;
602 end Is_Absolute_Path;
608 function Is_Directory (Name : C_File_Name) return Boolean is
609 function Is_Directory (Name : Address) return Integer;
610 pragma Import (C, Is_Directory, "__gnat_is_directory");
613 return Is_Directory (Name) /= 0;
616 function Is_Directory (Name : String) return Boolean is
617 F_Name : String (1 .. Name'Length + 1);
620 F_Name (1 .. Name'Length) := Name;
621 F_Name (F_Name'Last) := ASCII.NUL;
622 return Is_Directory (F_Name'Address);
625 ---------------------
626 -- Is_Regular_File --
627 ---------------------
629 function Is_Regular_File (Name : C_File_Name) return Boolean is
630 function Is_Regular_File (Name : Address) return Integer;
631 pragma Import (C, Is_Regular_File, "__gnat_is_regular_file");
634 return Is_Regular_File (Name) /= 0;
637 function Is_Regular_File (Name : String) return Boolean is
638 F_Name : String (1 .. Name'Length + 1);
641 F_Name (1 .. Name'Length) := Name;
642 F_Name (F_Name'Last) := ASCII.NUL;
643 return Is_Regular_File (F_Name'Address);
646 ----------------------
647 -- Is_Writable_File --
648 ----------------------
650 function Is_Writable_File (Name : C_File_Name) return Boolean is
651 function Is_Writable_File (Name : Address) return Integer;
652 pragma Import (C, Is_Writable_File, "__gnat_is_writable_file");
655 return Is_Writable_File (Name) /= 0;
656 end Is_Writable_File;
658 function Is_Writable_File (Name : String) return Boolean is
659 F_Name : String (1 .. Name'Length + 1);
662 F_Name (1 .. Name'Length) := Name;
663 F_Name (F_Name'Last) := ASCII.NUL;
664 return Is_Writable_File (F_Name'Address);
665 end Is_Writable_File;
667 -------------------------
668 -- Locate_Exec_On_Path --
669 -------------------------
671 function Locate_Exec_On_Path
675 function Locate_Exec_On_Path (C_Exec_Name : Address) return Address;
676 pragma Import (C, Locate_Exec_On_Path, "__gnat_locate_exec_on_path");
678 procedure Free (Ptr : System.Address);
679 pragma Import (C, Free, "free");
681 C_Exec_Name : String (1 .. Exec_Name'Length + 1);
684 Result : String_Access;
687 C_Exec_Name (1 .. Exec_Name'Length) := Exec_Name;
688 C_Exec_Name (C_Exec_Name'Last) := ASCII.NUL;
690 Path_Addr := Locate_Exec_On_Path (C_Exec_Name'Address);
691 Path_Len := C_String_Length (Path_Addr);
697 Result := To_Path_String_Access (Path_Addr, Path_Len);
701 end Locate_Exec_On_Path;
703 -------------------------
704 -- Locate_Regular_File --
705 -------------------------
707 function Locate_Regular_File
708 (File_Name : C_File_Name;
712 function Locate_Regular_File
713 (C_File_Name, Path_Val : Address) return Address;
714 pragma Import (C, Locate_Regular_File, "__gnat_locate_regular_file");
716 procedure Free (Ptr : System.Address);
717 pragma Import (C, Free, "free");
721 Result : String_Access;
724 Path_Addr := Locate_Regular_File (File_Name, Path);
725 Path_Len := C_String_Length (Path_Addr);
730 Result := To_Path_String_Access (Path_Addr, Path_Len);
734 end Locate_Regular_File;
736 function Locate_Regular_File
741 C_File_Name : String (1 .. File_Name'Length + 1);
742 C_Path : String (1 .. Path'Length + 1);
745 C_File_Name (1 .. File_Name'Length) := File_Name;
746 C_File_Name (C_File_Name'Last) := ASCII.NUL;
748 C_Path (1 .. Path'Length) := Path;
749 C_Path (C_Path'Last) := ASCII.NUL;
751 return Locate_Regular_File (C_File_Name'Address, C_Path'Address);
752 end Locate_Regular_File;
754 ------------------------
755 -- Non_Blocking_Spawn --
756 ------------------------
758 function Non_Blocking_Spawn
759 (Program_Name : String;
760 Args : Argument_List)
767 Spawn_Internal (Program_Name, Args, Junk, Pid, Blocking => False);
769 end Non_Blocking_Spawn;
771 ------------------------
772 -- Normalize_Pathname --
773 ------------------------
775 function Normalize_Pathname
777 Directory : String := "")
781 pragma Import (C, Max_Path, "max_path_len");
782 -- Maximum length of a path name
784 procedure Get_Current_Dir
785 (Dir : System.Address;
786 Length : System.Address);
787 pragma Import (C, Get_Current_Dir, "__gnat_get_current_dir");
789 Path_Buffer : String (1 .. Max_Path + Max_Path + 2);
790 End_Path : Natural := 0;
791 Link_Buffer : String (1 .. Max_Path + 2);
797 Max_Iterations : constant := 500;
800 (Path : System.Address;
801 Buf : System.Address;
804 pragma Import (C, Readlink, "__gnat_readlink");
806 function To_Canonical_File_Spec
807 (Host_File : System.Address)
808 return System.Address;
810 (C, To_Canonical_File_Spec, "__gnat_to_canonical_file_spec");
812 The_Name : String (1 .. Name'Length + 1);
813 Canonical_File_Addr : System.Address;
814 Canonical_File_Len : Integer;
816 Need_To_Check_Drive_Letter : Boolean := False;
817 -- Set to true if Name is an absolute path that starts with "//"
819 function Strlen (S : System.Address) return Integer;
820 pragma Import (C, Strlen, "strlen");
822 function Get_Directory return String;
823 -- If Directory is not empty, return it, adding a directory separator
824 -- if not already present, otherwise return current working directory
825 -- with terminating directory separator.
827 function Final_Value (S : String) return String;
828 -- Make final adjustment to the returned string.
829 -- To compensate for non standard path name in Interix,
830 -- if S is "/x" or starts with "/x", where x is a capital
831 -- letter 'A' to 'Z', add an additional '/' at the beginning
832 -- so that the returned value starts with "//x".
838 function Get_Directory return String is
840 -- Directory given, add directory separator if needed
842 if Directory'Length > 0 then
843 if Directory (Directory'Length) = Directory_Separator then
847 Result : String (1 .. Directory'Length + 1);
850 Result (1 .. Directory'Length) := Directory;
851 Result (Result'Length) := Directory_Separator;
856 -- Directory name not given, get current directory
860 Buffer : String (1 .. Max_Path + 2);
861 Path_Len : Natural := Max_Path;
864 Get_Current_Dir (Buffer'Address, Path_Len'Address);
866 if Buffer (Path_Len) /= Directory_Separator then
867 Path_Len := Path_Len + 1;
868 Buffer (Path_Len) := Directory_Separator;
871 return Buffer (1 .. Path_Len);
876 Reference_Dir : constant String := Get_Directory;
877 -- Current directory name specified
879 function Final_Value (S : String) return String is
881 -- Interix has the non standard notion of disk drive
882 -- indicated by two '/' followed by a capital letter
883 -- 'A' .. 'Z'. One of the two '/' may have been removed
884 -- by Normalize_Pathname. It has to be added again.
885 -- For other OSes, this should not make no difference.
887 if Need_To_Check_Drive_Letter
888 and then S'Length >= 2
889 and then S (S'First) = '/'
890 and then S (S'First + 1) in 'A' .. 'Z'
891 and then (S'Length = 2 or else S (S'First + 2) = '/')
894 Result : String (1 .. S'Length + 1);
898 Result (2 .. Result'Last) := S;
908 -- Start of processing for Normalize_Pathname
911 -- Special case, if name is null, then return null
913 if Name'Length = 0 then
917 -- First, convert VMS file spec to Unix file spec.
918 -- If Name is not in VMS syntax, then this is equivalent
919 -- to put Name at the begining of Path_Buffer.
921 VMS_Conversion : begin
922 The_Name (1 .. Name'Length) := Name;
923 The_Name (The_Name'Last) := ASCII.NUL;
925 Canonical_File_Addr := To_Canonical_File_Spec (The_Name'Address);
926 Canonical_File_Len := Strlen (Canonical_File_Addr);
928 -- If VMS syntax conversion has failed, return an empty string
929 -- to indicate the failure.
931 if Canonical_File_Len = 0 then
936 subtype Path_String is String (1 .. Canonical_File_Len);
937 type Path_String_Access is access Path_String;
939 function Address_To_Access is new
940 Unchecked_Conversion (Source => Address,
941 Target => Path_String_Access);
943 Path_Access : Path_String_Access :=
944 Address_To_Access (Canonical_File_Addr);
947 Path_Buffer (1 .. Canonical_File_Len) := Path_Access.all;
948 End_Path := Canonical_File_Len;
953 -- Replace all '/' by Directory Separators (this is for Windows)
955 if Directory_Separator /= '/' then
956 for Index in 1 .. End_Path loop
957 if Path_Buffer (Index) = '/' then
958 Path_Buffer (Index) := Directory_Separator;
963 -- Start the conversions
965 -- If this is not finished after Max_Iterations, give up and
966 -- return an empty string.
968 for J in 1 .. Max_Iterations loop
970 -- If we don't have an absolute pathname, prepend
971 -- the directory Reference_Dir.
974 and then not Is_Absolute_Path (Path_Buffer (1 .. End_Path))
977 (Reference_Dir'Last + 1 .. Reference_Dir'Length + End_Path) :=
978 Path_Buffer (1 .. End_Path);
979 End_Path := Reference_Dir'Length + End_Path;
980 Path_Buffer (1 .. Reference_Dir'Length) := Reference_Dir;
981 Last := Reference_Dir'Length;
984 -- If name starts with "//", we may have a drive letter on Interix
986 if Last = 1 and then End_Path >= 3 then
987 Need_To_Check_Drive_Letter := (Path_Buffer (1 .. 2)) = "//";
993 -- If we have traversed the full pathname, return it
995 if Start > End_Path then
996 return Final_Value (Path_Buffer (1 .. End_Path));
999 -- Remove duplicate directory separators
1001 while Path_Buffer (Start) = Directory_Separator loop
1002 if Start = End_Path then
1003 return Final_Value (Path_Buffer (1 .. End_Path - 1));
1006 Path_Buffer (Start .. End_Path - 1) :=
1007 Path_Buffer (Start + 1 .. End_Path);
1008 End_Path := End_Path - 1;
1012 -- Find the end of the current field: last character
1013 -- or the one preceding the next directory separator.
1015 while Finish < End_Path
1016 and then Path_Buffer (Finish + 1) /= Directory_Separator
1018 Finish := Finish + 1;
1023 if Start = Finish and then Path_Buffer (Start) = '.' then
1024 if Start = End_Path then
1026 return (1 => Directory_Separator);
1028 return Path_Buffer (1 .. Last - 1);
1032 Path_Buffer (Last + 1 .. End_Path - 2) :=
1033 Path_Buffer (Last + 3 .. End_Path);
1034 End_Path := End_Path - 2;
1037 -- Remove ".." fields
1039 elsif Finish = Start + 1
1040 and then Path_Buffer (Start .. Finish) = ".."
1045 exit when Start < 1 or else
1046 Path_Buffer (Start) = Directory_Separator;
1050 if Finish = End_Path then
1051 return (1 => Directory_Separator);
1054 Path_Buffer (1 .. End_Path - Finish) :=
1055 Path_Buffer (Finish + 1 .. End_Path);
1056 End_Path := End_Path - Finish;
1061 if Finish = End_Path then
1062 return Final_Value (Path_Buffer (1 .. Start - 1));
1065 Path_Buffer (Start + 1 .. Start + End_Path - Finish - 1) :=
1066 Path_Buffer (Finish + 2 .. End_Path);
1067 End_Path := Start + End_Path - Finish - 1;
1072 -- Check if current field is a symbolic link
1076 Saved : Character := Path_Buffer (Finish + 1);
1079 Path_Buffer (Finish + 1) := ASCII.NUL;
1080 Status := Readlink (Path_Buffer'Address,
1081 Link_Buffer'Address,
1082 Link_Buffer'Length);
1083 Path_Buffer (Finish + 1) := Saved;
1086 -- Not a symbolic link, move to the next field, if any
1091 -- Replace symbolic link with its value.
1094 if Is_Absolute_Path (Link_Buffer (1 .. Status)) then
1095 Path_Buffer (Status + 1 .. End_Path - (Finish - Status)) :=
1096 Path_Buffer (Finish + 1 .. End_Path);
1097 End_Path := End_Path - (Finish - Status);
1098 Path_Buffer (1 .. Status) := Link_Buffer (1 .. Status);
1103 (Last + Status + 1 .. End_Path - Finish + Last + Status) :=
1104 Path_Buffer (Finish + 1 .. End_Path);
1105 End_Path := End_Path - Finish + Last + Status;
1106 Path_Buffer (Last + 1 .. Last + Status) :=
1107 Link_Buffer (1 .. Status);
1113 -- Too many iterations: give up
1115 -- This can happen when there is a circularity in the symbolic links:
1116 -- A is a symbolic link for B, which itself is a symbolic link, and
1117 -- the target of B or of another symbolic link target of B is A.
1118 -- In this case, we return an empty string to indicate failure to
1122 end Normalize_Pathname;
1129 (Name : C_File_Name;
1131 return File_Descriptor
1133 function C_Open_Read
1134 (Name : C_File_Name;
1136 return File_Descriptor;
1137 pragma Import (C, C_Open_Read, "__gnat_open_read");
1140 return C_Open_Read (Name, Fmode);
1146 return File_Descriptor
1148 C_Name : String (1 .. Name'Length + 1);
1151 C_Name (1 .. Name'Length) := Name;
1152 C_Name (C_Name'Last) := ASCII.NUL;
1153 return Open_Read (C_Name (C_Name'First)'Address, Fmode);
1156 ---------------------
1157 -- Open_Read_Write --
1158 ---------------------
1160 function Open_Read_Write
1161 (Name : C_File_Name;
1163 return File_Descriptor
1165 function C_Open_Read_Write
1166 (Name : C_File_Name;
1168 return File_Descriptor;
1169 pragma Import (C, C_Open_Read_Write, "__gnat_open_rw");
1172 return C_Open_Read_Write (Name, Fmode);
1173 end Open_Read_Write;
1175 function Open_Read_Write
1178 return File_Descriptor
1180 C_Name : String (1 .. Name'Length + 1);
1183 C_Name (1 .. Name'Length) := Name;
1184 C_Name (C_Name'Last) := ASCII.NUL;
1185 return Open_Read_Write (C_Name (C_Name'First)'Address, Fmode);
1186 end Open_Read_Write;
1192 procedure Rename_File
1193 (Old_Name : C_File_Name;
1194 New_Name : C_File_Name;
1195 Success : out Boolean)
1197 function rename (From, To : Address) return Integer;
1198 pragma Import (C, rename, "rename");
1203 R := rename (Old_Name, New_Name);
1207 procedure Rename_File
1210 Success : out Boolean)
1212 C_Old_Name : String (1 .. Old_Name'Length + 1);
1213 C_New_Name : String (1 .. New_Name'Length + 1);
1216 C_Old_Name (1 .. Old_Name'Length) := Old_Name;
1217 C_Old_Name (C_Old_Name'Last) := ASCII.NUL;
1219 C_New_Name (1 .. New_Name'Length) := New_Name;
1220 C_New_Name (C_New_Name'Last) := ASCII.NUL;
1222 Rename_File (C_Old_Name'Address, C_New_Name'Address, Success);
1229 procedure Setenv (Name : String; Value : String) is
1230 F_Name : String (1 .. Name'Length + 1);
1231 F_Value : String (1 .. Value'Length + 1);
1233 procedure Set_Env_Value (Name, Value : System.Address);
1234 pragma Import (C, Set_Env_Value, "__gnat_set_env_value");
1237 F_Name (1 .. Name'Length) := Name;
1238 F_Name (F_Name'Last) := ASCII.NUL;
1240 F_Value (1 .. Value'Length) := Value;
1241 F_Value (F_Value'Last) := ASCII.NUL;
1243 Set_Env_Value (F_Name'Address, F_Value'Address);
1251 (Program_Name : String;
1252 Args : Argument_List)
1259 Spawn_Internal (Program_Name, Args, Result, Junk, Blocking => True);
1264 (Program_Name : String;
1265 Args : Argument_List;
1266 Success : out Boolean)
1269 Success := (Spawn (Program_Name, Args) = 0);
1272 --------------------
1273 -- Spawn_Internal --
1274 --------------------
1276 procedure Spawn_Internal
1277 (Program_Name : String;
1278 Args : Argument_List;
1279 Result : out Integer;
1280 Pid : out Process_Id;
1283 type Chars is array (Positive range <>) of aliased Character;
1284 type Char_Ptr is access constant Character;
1286 Command_Len : constant Positive := Program_Name'Length + 1
1287 + Args_Length (Args);
1288 Command_Last : Natural := 0;
1289 Command : aliased Chars (1 .. Command_Len);
1290 -- Command contains all characters of the Program_Name and Args,
1291 -- all terminated by ASCII.NUL characters
1293 Arg_List_Len : constant Positive := Args'Length + 2;
1294 Arg_List_Last : Natural := 0;
1295 Arg_List : aliased array (1 .. Arg_List_Len) of Char_Ptr;
1296 -- List with pointers to NUL-terminated strings of the
1297 -- Program_Name and the Args and terminated with a null pointer.
1298 -- We rely on the default initialization for the last null pointer.
1300 procedure Add_To_Command (S : String);
1301 -- Add S and a NUL character to Command, updating Last
1303 function Portable_Spawn (Args : Address) return Integer;
1304 pragma Import (C, Portable_Spawn, "__gnat_portable_spawn");
1306 function Portable_No_Block_Spawn (Args : Address) return Process_Id;
1308 (C, Portable_No_Block_Spawn, "__gnat_portable_no_block_spawn");
1310 --------------------
1311 -- Add_To_Command --
1312 --------------------
1314 procedure Add_To_Command (S : String) is
1315 First : constant Natural := Command_Last + 1;
1318 Command_Last := Command_Last + S'Length;
1320 -- Move characters one at a time, because Command has
1321 -- aliased components.
1323 for J in S'Range loop
1324 Command (First + J - S'First) := S (J);
1327 Command_Last := Command_Last + 1;
1328 Command (Command_Last) := ASCII.NUL;
1330 Arg_List_Last := Arg_List_Last + 1;
1331 Arg_List (Arg_List_Last) := Command (First)'Access;
1334 -- Start of processing for Spawn_Internal
1337 Add_To_Command (Program_Name);
1339 for J in Args'Range loop
1340 Add_To_Command (Args (J).all);
1345 Result := Portable_Spawn (Arg_List'Address);
1347 Pid := Portable_No_Block_Spawn (Arg_List'Address);
1348 Result := Boolean'Pos (Pid /= Invalid_Pid);
1353 ---------------------------
1354 -- To_Path_String_Access --
1355 ---------------------------
1357 function To_Path_String_Access
1358 (Path_Addr : Address;
1360 return String_Access
1362 subtype Path_String is String (1 .. Path_Len);
1363 type Path_String_Access is access Path_String;
1365 function Address_To_Access is new
1366 Unchecked_Conversion (Source => Address,
1367 Target => Path_String_Access);
1369 Path_Access : Path_String_Access := Address_To_Access (Path_Addr);
1371 Return_Val : String_Access;
1374 Return_Val := new String (1 .. Path_Len);
1376 for J in 1 .. Path_Len loop
1377 Return_Val (J) := Path_Access (J);
1381 end To_Path_String_Access;
1387 procedure Wait_Process (Pid : out Process_Id; Success : out Boolean) is
1390 function Portable_Wait (S : Address) return Process_Id;
1391 pragma Import (C, Portable_Wait, "__gnat_portable_wait");
1394 Pid := Portable_Wait (Status'Address);
1395 Success := (Status = 0);