1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
5 -- G N A T . O S _ L I B --
9 -- Copyright (C) 1995-2002 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 is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
31 ------------------------------------------------------------------------------
33 with System.Soft_Links;
34 with Unchecked_Conversion;
35 with System; use System;
37 package body GNAT.OS_Lib is
39 package SSL renames System.Soft_Links;
41 -----------------------
42 -- Local Subprograms --
43 -----------------------
45 function Args_Length (Args : Argument_List) return Natural;
46 -- Returns total number of characters needed to create a string
47 -- of all Args terminated by ASCII.NUL characters
49 function C_String_Length (S : Address) return Integer;
50 -- Returns the length of a C string. Does check for null address
53 procedure Spawn_Internal
54 (Program_Name : String;
59 -- Internal routine to implement the two Spawn (blocking/non blocking)
60 -- routines. If Blocking is set to True then the spawn is blocking
61 -- otherwise it is non blocking. In this latter case the Pid contains
62 -- the process id number. The first three parameters are as in Spawn.
63 -- Note that Spawn_Internal normalizes the argument list before calling
64 -- the low level system spawn routines (see Normalize_Arguments). Note
65 -- that Normalize_Arguments is designed to do nothing if it is called
66 -- more than once, so calling Normalize_Arguments before calling one
67 -- of the spawn routines is fine.
69 function To_Path_String_Access
73 -- Converts a C String to an Ada String. We could do this making use of
74 -- Interfaces.C.Strings but we prefer not to import that entire package
80 function Args_Length (Args : Argument_List) return Natural is
84 for J in Args'Range loop
85 Len := Len + Args (J)'Length + 1; -- One extra for ASCII.NUL
91 -----------------------------
92 -- Argument_String_To_List --
93 -----------------------------
95 function Argument_String_To_List
97 return Argument_List_Access
99 Max_Args : Integer := Arg_String'Length;
100 New_Argv : Argument_List (1 .. Max_Args);
101 New_Argc : Natural := 0;
105 Idx := Arg_String'First;
109 Quoted : Boolean := False;
110 Backqd : Boolean := False;
117 -- An unquoted space is the end of an argument
119 if not (Backqd or Quoted)
120 and then Arg_String (Idx) = ' '
124 -- Start of a quoted string
126 elsif not (Backqd or Quoted)
127 and then Arg_String (Idx) = '"'
131 -- End of a quoted string and end of an argument
133 elsif (Quoted and not Backqd)
134 and then Arg_String (Idx) = '"'
139 -- Following character is backquoted
141 elsif Arg_String (Idx) = '\' then
144 -- Turn off backquoting after advancing one character
152 exit when Idx > Arg_String'Last;
157 New_Argc := New_Argc + 1;
158 New_Argv (New_Argc) :=
159 new String'(Arg_String (Old_Idx .. Idx - 1));
161 -- Skip extraneous spaces
163 while Idx <= Arg_String'Last and then Arg_String (Idx) = ' ' loop
168 exit when Idx > Arg_String'Last;
171 return new Argument_List'(New_Argv (1 .. New_Argc));
172 end Argument_String_To_List;
174 ---------------------
175 -- C_String_Length --
176 ---------------------
178 function C_String_Length (S : Address) return Integer is
179 function Strlen (S : Address) return Integer;
180 pragma Import (C, Strlen, "strlen");
183 if S = Null_Address then
197 return File_Descriptor
199 function C_Create_File
202 return File_Descriptor;
203 pragma Import (C, C_Create_File, "__gnat_open_create");
206 return C_Create_File (Name, Fmode);
212 return File_Descriptor
214 C_Name : String (1 .. Name'Length + 1);
217 C_Name (1 .. Name'Length) := Name;
218 C_Name (C_Name'Last) := ASCII.NUL;
219 return Create_File (C_Name (C_Name'First)'Address, Fmode);
222 ---------------------
223 -- Create_New_File --
224 ---------------------
226 function Create_New_File
229 return File_Descriptor
231 function C_Create_New_File
234 return File_Descriptor;
235 pragma Import (C, C_Create_New_File, "__gnat_open_new");
238 return C_Create_New_File (Name, Fmode);
241 function Create_New_File
244 return File_Descriptor
246 C_Name : String (1 .. Name'Length + 1);
249 C_Name (1 .. Name'Length) := Name;
250 C_Name (C_Name'Last) := ASCII.NUL;
251 return Create_New_File (C_Name (C_Name'First)'Address, Fmode);
254 ----------------------
255 -- Create_Temp_File --
256 ----------------------
258 procedure Create_Temp_File
259 (FD : out File_Descriptor;
260 Name : out Temp_File_Name)
262 function Open_New_Temp
263 (Name : System.Address;
265 return File_Descriptor;
266 pragma Import (C, Open_New_Temp, "__gnat_open_new_temp");
269 FD := Open_New_Temp (Name'Address, Binary);
270 end Create_Temp_File;
276 procedure Delete_File (Name : Address; Success : out Boolean) is
279 function unlink (A : Address) return Integer;
280 pragma Import (C, unlink, "unlink");
287 procedure Delete_File (Name : String; Success : out Boolean) is
288 C_Name : String (1 .. Name'Length + 1);
291 C_Name (1 .. Name'Length) := Name;
292 C_Name (C_Name'Last) := ASCII.NUL;
294 Delete_File (C_Name'Address, Success);
297 ---------------------
298 -- File_Time_Stamp --
299 ---------------------
301 function File_Time_Stamp (FD : File_Descriptor) return OS_Time is
302 function File_Time (FD : File_Descriptor) return OS_Time;
303 pragma Import (C, File_Time, "__gnat_file_time_fd");
306 return File_Time (FD);
309 function File_Time_Stamp (Name : C_File_Name) return OS_Time is
310 function File_Time (Name : Address) return OS_Time;
311 pragma Import (C, File_Time, "__gnat_file_time_name");
314 return File_Time (Name);
317 function File_Time_Stamp (Name : String) return OS_Time is
318 F_Name : String (1 .. Name'Length + 1);
321 F_Name (1 .. Name'Length) := Name;
322 F_Name (F_Name'Last) := ASCII.NUL;
323 return File_Time_Stamp (F_Name'Address);
330 procedure Free (Arg : in out String_List_Access) is
333 procedure Free_Array is new Unchecked_Deallocation
334 (Object => String_List, Name => String_List_Access);
337 for J in Arg'Range loop
345 ---------------------------
346 -- Get_Debuggable_Suffix --
347 ---------------------------
349 function Get_Debuggable_Suffix return String_Access is
350 procedure Get_Suffix_Ptr (Length, Ptr : Address);
351 pragma Import (C, Get_Suffix_Ptr, "__gnat_get_debuggable_suffix_ptr");
353 procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
354 pragma Import (C, Strncpy, "strncpy");
356 Suffix_Ptr : Address;
357 Suffix_Length : Integer;
358 Result : String_Access;
361 Get_Suffix_Ptr (Suffix_Length'Address, Suffix_Ptr'Address);
363 Result := new String (1 .. Suffix_Length);
365 if Suffix_Length > 0 then
366 Strncpy (Result.all'Address, Suffix_Ptr, Suffix_Length);
370 end Get_Debuggable_Suffix;
372 ---------------------------
373 -- Get_Executable_Suffix --
374 ---------------------------
376 function Get_Executable_Suffix return String_Access is
377 procedure Get_Suffix_Ptr (Length, Ptr : Address);
378 pragma Import (C, Get_Suffix_Ptr, "__gnat_get_executable_suffix_ptr");
380 procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
381 pragma Import (C, Strncpy, "strncpy");
383 Suffix_Ptr : Address;
384 Suffix_Length : Integer;
385 Result : String_Access;
388 Get_Suffix_Ptr (Suffix_Length'Address, Suffix_Ptr'Address);
390 Result := new String (1 .. Suffix_Length);
392 if Suffix_Length > 0 then
393 Strncpy (Result.all'Address, Suffix_Ptr, Suffix_Length);
397 end Get_Executable_Suffix;
399 -----------------------
400 -- Get_Object_Suffix --
401 -----------------------
403 function Get_Object_Suffix return String_Access is
404 procedure Get_Suffix_Ptr (Length, Ptr : Address);
405 pragma Import (C, Get_Suffix_Ptr, "__gnat_get_object_suffix_ptr");
407 procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
408 pragma Import (C, Strncpy, "strncpy");
410 Suffix_Ptr : Address;
411 Suffix_Length : Integer;
412 Result : String_Access;
415 Get_Suffix_Ptr (Suffix_Length'Address, Suffix_Ptr'Address);
417 Result := new String (1 .. Suffix_Length);
419 if Suffix_Length > 0 then
420 Strncpy (Result.all'Address, Suffix_Ptr, Suffix_Length);
424 end Get_Object_Suffix;
430 function Getenv (Name : String) return String_Access is
431 procedure Get_Env_Value_Ptr (Name, Length, Ptr : Address);
432 pragma Import (C, Get_Env_Value_Ptr, "__gnat_get_env_value_ptr");
434 procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
435 pragma Import (C, Strncpy, "strncpy");
437 Env_Value_Ptr : Address;
438 Env_Value_Length : Integer;
439 F_Name : String (1 .. Name'Length + 1);
440 Result : String_Access;
443 F_Name (1 .. Name'Length) := Name;
444 F_Name (F_Name'Last) := ASCII.NUL;
447 (F_Name'Address, Env_Value_Length'Address, Env_Value_Ptr'Address);
449 Result := new String (1 .. Env_Value_Length);
451 if Env_Value_Length > 0 then
452 Strncpy (Result.all'Address, Env_Value_Ptr, Env_Value_Length);
462 function GM_Day (Date : OS_Time) return Day_Type is
471 GM_Split (Date, Y, Mo, D, H, Mn, S);
479 function GM_Hour (Date : OS_Time) return Hour_Type is
488 GM_Split (Date, Y, Mo, D, H, Mn, S);
496 function GM_Minute (Date : OS_Time) return Minute_Type is
505 GM_Split (Date, Y, Mo, D, H, Mn, S);
513 function GM_Month (Date : OS_Time) return Month_Type is
522 GM_Split (Date, Y, Mo, D, H, Mn, S);
530 function GM_Second (Date : OS_Time) return Second_Type is
539 GM_Split (Date, Y, Mo, D, H, Mn, S);
549 Year : out Year_Type;
550 Month : out Month_Type;
552 Hour : out Hour_Type;
553 Minute : out Minute_Type;
554 Second : out Second_Type)
557 (P_Time_T, P_Year, P_Month, P_Day, P_Hours, P_Mins, P_Secs : Address);
558 pragma Import (C, To_GM_Time, "__gnat_to_gm_time");
569 -- Use the global lock because To_GM_Time is not thread safe.
571 Locked_Processing : begin
574 (T'Address, Y'Address, Mo'Address, D'Address,
575 H'Address, Mn'Address, S'Address);
582 end Locked_Processing;
596 function GM_Year (Date : OS_Time) return Year_Type is
605 GM_Split (Date, Y, Mo, D, H, Mn, S);
609 ----------------------
610 -- Is_Absolute_Path --
611 ----------------------
613 function Is_Absolute_Path (Name : String) return Boolean is
614 function Is_Absolute_Path (Name : Address) return Integer;
615 pragma Import (C, Is_Absolute_Path, "__gnat_is_absolute_path");
617 F_Name : String (1 .. Name'Length + 1);
620 F_Name (1 .. Name'Length) := Name;
621 F_Name (F_Name'Last) := ASCII.NUL;
623 return Is_Absolute_Path (F_Name'Address) /= 0;
624 end Is_Absolute_Path;
630 function Is_Directory (Name : C_File_Name) return Boolean is
631 function Is_Directory (Name : Address) return Integer;
632 pragma Import (C, Is_Directory, "__gnat_is_directory");
635 return Is_Directory (Name) /= 0;
638 function Is_Directory (Name : String) return Boolean is
639 F_Name : String (1 .. Name'Length + 1);
642 F_Name (1 .. Name'Length) := Name;
643 F_Name (F_Name'Last) := ASCII.NUL;
644 return Is_Directory (F_Name'Address);
647 ---------------------
648 -- Is_Regular_File --
649 ---------------------
651 function Is_Regular_File (Name : C_File_Name) return Boolean is
652 function Is_Regular_File (Name : Address) return Integer;
653 pragma Import (C, Is_Regular_File, "__gnat_is_regular_file");
656 return Is_Regular_File (Name) /= 0;
659 function Is_Regular_File (Name : String) return Boolean is
660 F_Name : String (1 .. Name'Length + 1);
663 F_Name (1 .. Name'Length) := Name;
664 F_Name (F_Name'Last) := ASCII.NUL;
665 return Is_Regular_File (F_Name'Address);
668 ----------------------
669 -- Is_Writable_File --
670 ----------------------
672 function Is_Writable_File (Name : C_File_Name) return Boolean is
673 function Is_Writable_File (Name : Address) return Integer;
674 pragma Import (C, Is_Writable_File, "__gnat_is_writable_file");
677 return Is_Writable_File (Name) /= 0;
678 end Is_Writable_File;
680 function Is_Writable_File (Name : String) return Boolean is
681 F_Name : String (1 .. Name'Length + 1);
684 F_Name (1 .. Name'Length) := Name;
685 F_Name (F_Name'Last) := ASCII.NUL;
686 return Is_Writable_File (F_Name'Address);
687 end Is_Writable_File;
689 -------------------------
690 -- Locate_Exec_On_Path --
691 -------------------------
693 function Locate_Exec_On_Path
697 function Locate_Exec_On_Path (C_Exec_Name : Address) return Address;
698 pragma Import (C, Locate_Exec_On_Path, "__gnat_locate_exec_on_path");
700 procedure Free (Ptr : System.Address);
701 pragma Import (C, Free, "free");
703 C_Exec_Name : String (1 .. Exec_Name'Length + 1);
706 Result : String_Access;
709 C_Exec_Name (1 .. Exec_Name'Length) := Exec_Name;
710 C_Exec_Name (C_Exec_Name'Last) := ASCII.NUL;
712 Path_Addr := Locate_Exec_On_Path (C_Exec_Name'Address);
713 Path_Len := C_String_Length (Path_Addr);
719 Result := To_Path_String_Access (Path_Addr, Path_Len);
723 end Locate_Exec_On_Path;
725 -------------------------
726 -- Locate_Regular_File --
727 -------------------------
729 function Locate_Regular_File
730 (File_Name : C_File_Name;
734 function Locate_Regular_File
735 (C_File_Name, Path_Val : Address) return Address;
736 pragma Import (C, Locate_Regular_File, "__gnat_locate_regular_file");
738 procedure Free (Ptr : System.Address);
739 pragma Import (C, Free, "free");
743 Result : String_Access;
746 Path_Addr := Locate_Regular_File (File_Name, Path);
747 Path_Len := C_String_Length (Path_Addr);
752 Result := To_Path_String_Access (Path_Addr, Path_Len);
756 end Locate_Regular_File;
758 function Locate_Regular_File
763 C_File_Name : String (1 .. File_Name'Length + 1);
764 C_Path : String (1 .. Path'Length + 1);
767 C_File_Name (1 .. File_Name'Length) := File_Name;
768 C_File_Name (C_File_Name'Last) := ASCII.NUL;
770 C_Path (1 .. Path'Length) := Path;
771 C_Path (C_Path'Last) := ASCII.NUL;
773 return Locate_Regular_File (C_File_Name'Address, C_Path'Address);
774 end Locate_Regular_File;
776 ------------------------
777 -- Non_Blocking_Spawn --
778 ------------------------
780 function Non_Blocking_Spawn
781 (Program_Name : String;
782 Args : Argument_List)
789 Spawn_Internal (Program_Name, Args, Junk, Pid, Blocking => False);
791 end Non_Blocking_Spawn;
793 -------------------------
794 -- Normalize_Arguments --
795 -------------------------
797 procedure Normalize_Arguments (Args : in out Argument_List) is
799 procedure Quote_Argument (Arg : in out String_Access);
800 -- Add quote around argument if it contains spaces.
802 Argument_Needs_Quote : Boolean;
803 pragma Import (C, Argument_Needs_Quote, "__gnat_argument_needs_quote");
809 procedure Quote_Argument (Arg : in out String_Access) is
810 Res : String (1 .. Arg'Length * 2);
812 Quote_Needed : Boolean := False;
815 if Arg (Arg'First) /= '"' or else Arg (Arg'Last) /= '"' then
821 for K in Arg'Range loop
825 if Arg (K) = '"' then
830 elsif Arg (K) = ' ' then
832 Quote_Needed := True;
848 Old : String_Access := Arg;
851 Arg := new String'(Res (1 .. J));
860 if Argument_Needs_Quote then
861 for K in Args'Range loop
862 if Args (K) /= null then
863 Quote_Argument (Args (K));
867 end Normalize_Arguments;
869 ------------------------
870 -- Normalize_Pathname --
871 ------------------------
873 function Normalize_Pathname
875 Directory : String := "")
879 pragma Import (C, Max_Path, "__gnat_max_path_len");
880 -- Maximum length of a path name
882 procedure Get_Current_Dir
883 (Dir : System.Address;
884 Length : System.Address);
885 pragma Import (C, Get_Current_Dir, "__gnat_get_current_dir");
887 Path_Buffer : String (1 .. Max_Path + Max_Path + 2);
888 End_Path : Natural := 0;
889 Link_Buffer : String (1 .. Max_Path + 2);
895 Max_Iterations : constant := 500;
898 (Path : System.Address;
899 Buf : System.Address;
902 pragma Import (C, Readlink, "__gnat_readlink");
904 function To_Canonical_File_Spec
905 (Host_File : System.Address)
906 return System.Address;
908 (C, To_Canonical_File_Spec, "__gnat_to_canonical_file_spec");
910 The_Name : String (1 .. Name'Length + 1);
911 Canonical_File_Addr : System.Address;
912 Canonical_File_Len : Integer;
914 Need_To_Check_Drive_Letter : Boolean := False;
915 -- Set to true if Name is an absolute path that starts with "//"
917 function Strlen (S : System.Address) return Integer;
918 pragma Import (C, Strlen, "strlen");
920 function Get_Directory return String;
921 -- If Directory is not empty, return it, adding a directory separator
922 -- if not already present, otherwise return current working directory
923 -- with terminating directory separator.
925 function Final_Value (S : String) return String;
926 -- Make final adjustment to the returned string.
927 -- To compensate for non standard path name in Interix,
928 -- if S is "/x" or starts with "/x", where x is a capital
929 -- letter 'A' to 'Z', add an additional '/' at the beginning
930 -- so that the returned value starts with "//x".
936 function Get_Directory return String is
938 -- Directory given, add directory separator if needed
940 if Directory'Length > 0 then
941 if Directory (Directory'Length) = Directory_Separator then
945 Result : String (1 .. Directory'Length + 1);
948 Result (1 .. Directory'Length) := Directory;
949 Result (Result'Length) := Directory_Separator;
954 -- Directory name not given, get current directory
958 Buffer : String (1 .. Max_Path + 2);
959 Path_Len : Natural := Max_Path;
962 Get_Current_Dir (Buffer'Address, Path_Len'Address);
964 if Buffer (Path_Len) /= Directory_Separator then
965 Path_Len := Path_Len + 1;
966 Buffer (Path_Len) := Directory_Separator;
969 return Buffer (1 .. Path_Len);
974 Reference_Dir : constant String := Get_Directory;
975 -- Current directory name specified
981 function Final_Value (S : String) return String is
983 -- Interix has the non standard notion of disk drive
984 -- indicated by two '/' followed by a capital letter
985 -- 'A' .. 'Z'. One of the two '/' may have been removed
986 -- by Normalize_Pathname. It has to be added again.
987 -- For other OSes, this should not make no difference.
989 if Need_To_Check_Drive_Letter
990 and then S'Length >= 2
991 and then S (S'First) = '/'
992 and then S (S'First + 1) in 'A' .. 'Z'
993 and then (S'Length = 2 or else S (S'First + 2) = '/')
996 Result : String (1 .. S'Length + 1);
1000 Result (2 .. Result'Last) := S;
1010 -- Start of processing for Normalize_Pathname
1013 -- Special case, if name is null, then return null
1015 if Name'Length = 0 then
1019 -- First, convert VMS file spec to Unix file spec.
1020 -- If Name is not in VMS syntax, then this is equivalent
1021 -- to put Name at the begining of Path_Buffer.
1023 VMS_Conversion : begin
1024 The_Name (1 .. Name'Length) := Name;
1025 The_Name (The_Name'Last) := ASCII.NUL;
1027 Canonical_File_Addr := To_Canonical_File_Spec (The_Name'Address);
1028 Canonical_File_Len := Strlen (Canonical_File_Addr);
1030 -- If VMS syntax conversion has failed, return an empty string
1031 -- to indicate the failure.
1033 if Canonical_File_Len = 0 then
1038 subtype Path_String is String (1 .. Canonical_File_Len);
1039 type Path_String_Access is access Path_String;
1041 function Address_To_Access is new
1042 Unchecked_Conversion (Source => Address,
1043 Target => Path_String_Access);
1045 Path_Access : Path_String_Access :=
1046 Address_To_Access (Canonical_File_Addr);
1049 Path_Buffer (1 .. Canonical_File_Len) := Path_Access.all;
1050 End_Path := Canonical_File_Len;
1055 -- Replace all '/' by Directory Separators (this is for Windows)
1057 if Directory_Separator /= '/' then
1058 for Index in 1 .. End_Path loop
1059 if Path_Buffer (Index) = '/' then
1060 Path_Buffer (Index) := Directory_Separator;
1065 -- Start the conversions
1067 -- If this is not finished after Max_Iterations, give up and
1068 -- return an empty string.
1070 for J in 1 .. Max_Iterations loop
1072 -- If we don't have an absolute pathname, prepend
1073 -- the directory Reference_Dir.
1076 and then not Is_Absolute_Path (Path_Buffer (1 .. End_Path))
1079 (Reference_Dir'Last + 1 .. Reference_Dir'Length + End_Path) :=
1080 Path_Buffer (1 .. End_Path);
1081 End_Path := Reference_Dir'Length + End_Path;
1082 Path_Buffer (1 .. Reference_Dir'Length) := Reference_Dir;
1083 Last := Reference_Dir'Length;
1086 -- If name starts with "//", we may have a drive letter on Interix
1088 if Last = 1 and then End_Path >= 3 then
1089 Need_To_Check_Drive_Letter := (Path_Buffer (1 .. 2)) = "//";
1095 -- If we have traversed the full pathname, return it
1097 if Start > End_Path then
1098 return Final_Value (Path_Buffer (1 .. End_Path));
1101 -- Remove duplicate directory separators
1103 while Path_Buffer (Start) = Directory_Separator loop
1104 if Start = End_Path then
1105 return Final_Value (Path_Buffer (1 .. End_Path - 1));
1108 Path_Buffer (Start .. End_Path - 1) :=
1109 Path_Buffer (Start + 1 .. End_Path);
1110 End_Path := End_Path - 1;
1114 -- Find the end of the current field: last character
1115 -- or the one preceding the next directory separator.
1117 while Finish < End_Path
1118 and then Path_Buffer (Finish + 1) /= Directory_Separator
1120 Finish := Finish + 1;
1125 if Start = Finish and then Path_Buffer (Start) = '.' then
1126 if Start = End_Path then
1128 return (1 => Directory_Separator);
1130 return Path_Buffer (1 .. Last - 1);
1134 Path_Buffer (Last + 1 .. End_Path - 2) :=
1135 Path_Buffer (Last + 3 .. End_Path);
1136 End_Path := End_Path - 2;
1139 -- Remove ".." fields
1141 elsif Finish = Start + 1
1142 and then Path_Buffer (Start .. Finish) = ".."
1147 exit when Start < 1 or else
1148 Path_Buffer (Start) = Directory_Separator;
1152 if Finish = End_Path then
1153 return (1 => Directory_Separator);
1156 Path_Buffer (1 .. End_Path - Finish) :=
1157 Path_Buffer (Finish + 1 .. End_Path);
1158 End_Path := End_Path - Finish;
1163 if Finish = End_Path then
1164 return Final_Value (Path_Buffer (1 .. Start - 1));
1167 Path_Buffer (Start + 1 .. Start + End_Path - Finish - 1) :=
1168 Path_Buffer (Finish + 2 .. End_Path);
1169 End_Path := Start + End_Path - Finish - 1;
1174 -- Check if current field is a symbolic link
1178 Saved : Character := Path_Buffer (Finish + 1);
1181 Path_Buffer (Finish + 1) := ASCII.NUL;
1182 Status := Readlink (Path_Buffer'Address,
1183 Link_Buffer'Address,
1184 Link_Buffer'Length);
1185 Path_Buffer (Finish + 1) := Saved;
1188 -- Not a symbolic link, move to the next field, if any
1193 -- Replace symbolic link with its value.
1196 if Is_Absolute_Path (Link_Buffer (1 .. Status)) then
1197 Path_Buffer (Status + 1 .. End_Path - (Finish - Status)) :=
1198 Path_Buffer (Finish + 1 .. End_Path);
1199 End_Path := End_Path - (Finish - Status);
1200 Path_Buffer (1 .. Status) := Link_Buffer (1 .. Status);
1205 (Last + Status + 1 .. End_Path - Finish + Last + Status) :=
1206 Path_Buffer (Finish + 1 .. End_Path);
1207 End_Path := End_Path - Finish + Last + Status;
1208 Path_Buffer (Last + 1 .. Last + Status) :=
1209 Link_Buffer (1 .. Status);
1215 -- Too many iterations: give up
1217 -- This can happen when there is a circularity in the symbolic links:
1218 -- A is a symbolic link for B, which itself is a symbolic link, and
1219 -- the target of B or of another symbolic link target of B is A.
1220 -- In this case, we return an empty string to indicate failure to
1224 end Normalize_Pathname;
1231 (Name : C_File_Name;
1233 return File_Descriptor
1235 function C_Open_Read
1236 (Name : C_File_Name;
1238 return File_Descriptor;
1239 pragma Import (C, C_Open_Read, "__gnat_open_read");
1242 return C_Open_Read (Name, Fmode);
1248 return File_Descriptor
1250 C_Name : String (1 .. Name'Length + 1);
1253 C_Name (1 .. Name'Length) := Name;
1254 C_Name (C_Name'Last) := ASCII.NUL;
1255 return Open_Read (C_Name (C_Name'First)'Address, Fmode);
1258 ---------------------
1259 -- Open_Read_Write --
1260 ---------------------
1262 function Open_Read_Write
1263 (Name : C_File_Name;
1265 return File_Descriptor
1267 function C_Open_Read_Write
1268 (Name : C_File_Name;
1270 return File_Descriptor;
1271 pragma Import (C, C_Open_Read_Write, "__gnat_open_rw");
1274 return C_Open_Read_Write (Name, Fmode);
1275 end Open_Read_Write;
1277 function Open_Read_Write
1280 return File_Descriptor
1282 C_Name : String (1 .. Name'Length + 1);
1285 C_Name (1 .. Name'Length) := Name;
1286 C_Name (C_Name'Last) := ASCII.NUL;
1287 return Open_Read_Write (C_Name (C_Name'First)'Address, Fmode);
1288 end Open_Read_Write;
1294 procedure Rename_File
1295 (Old_Name : C_File_Name;
1296 New_Name : C_File_Name;
1297 Success : out Boolean)
1299 function rename (From, To : Address) return Integer;
1300 pragma Import (C, rename, "rename");
1305 R := rename (Old_Name, New_Name);
1309 procedure Rename_File
1312 Success : out Boolean)
1314 C_Old_Name : String (1 .. Old_Name'Length + 1);
1315 C_New_Name : String (1 .. New_Name'Length + 1);
1318 C_Old_Name (1 .. Old_Name'Length) := Old_Name;
1319 C_Old_Name (C_Old_Name'Last) := ASCII.NUL;
1321 C_New_Name (1 .. New_Name'Length) := New_Name;
1322 C_New_Name (C_New_Name'Last) := ASCII.NUL;
1324 Rename_File (C_Old_Name'Address, C_New_Name'Address, Success);
1331 procedure Setenv (Name : String; Value : String) is
1332 F_Name : String (1 .. Name'Length + 1);
1333 F_Value : String (1 .. Value'Length + 1);
1335 procedure Set_Env_Value (Name, Value : System.Address);
1336 pragma Import (C, Set_Env_Value, "__gnat_set_env_value");
1339 F_Name (1 .. Name'Length) := Name;
1340 F_Name (F_Name'Last) := ASCII.NUL;
1342 F_Value (1 .. Value'Length) := Value;
1343 F_Value (F_Value'Last) := ASCII.NUL;
1345 Set_Env_Value (F_Name'Address, F_Value'Address);
1353 (Program_Name : String;
1354 Args : Argument_List)
1361 Spawn_Internal (Program_Name, Args, Result, Junk, Blocking => True);
1366 (Program_Name : String;
1367 Args : Argument_List;
1368 Success : out Boolean)
1371 Success := (Spawn (Program_Name, Args) = 0);
1374 --------------------
1375 -- Spawn_Internal --
1376 --------------------
1378 procedure Spawn_Internal
1379 (Program_Name : String;
1380 Args : Argument_List;
1381 Result : out Integer;
1382 Pid : out Process_Id;
1386 procedure Spawn (Args : Argument_List);
1389 N_Args : Argument_List (Args'Range);
1390 -- Normalized arguments
1396 procedure Spawn (Args : Argument_List) is
1397 type Chars is array (Positive range <>) of aliased Character;
1398 type Char_Ptr is access constant Character;
1400 Command_Len : constant Positive := Program_Name'Length + 1
1401 + Args_Length (Args);
1402 Command_Last : Natural := 0;
1403 Command : aliased Chars (1 .. Command_Len);
1404 -- Command contains all characters of the Program_Name and Args,
1405 -- all terminated by ASCII.NUL characters
1407 Arg_List_Len : constant Positive := Args'Length + 2;
1408 Arg_List_Last : Natural := 0;
1409 Arg_List : aliased array (1 .. Arg_List_Len) of Char_Ptr;
1410 -- List with pointers to NUL-terminated strings of the
1411 -- Program_Name and the Args and terminated with a null pointer.
1412 -- We rely on the default initialization for the last null pointer.
1414 procedure Add_To_Command (S : String);
1415 -- Add S and a NUL character to Command, updating Last
1417 function Portable_Spawn (Args : Address) return Integer;
1418 pragma Import (C, Portable_Spawn, "__gnat_portable_spawn");
1420 function Portable_No_Block_Spawn (Args : Address) return Process_Id;
1422 (C, Portable_No_Block_Spawn, "__gnat_portable_no_block_spawn");
1424 --------------------
1425 -- Add_To_Command --
1426 --------------------
1428 procedure Add_To_Command (S : String) is
1429 First : constant Natural := Command_Last + 1;
1432 Command_Last := Command_Last + S'Length;
1434 -- Move characters one at a time, because Command has
1435 -- aliased components.
1437 for J in S'Range loop
1438 Command (First + J - S'First) := S (J);
1441 Command_Last := Command_Last + 1;
1442 Command (Command_Last) := ASCII.NUL;
1444 Arg_List_Last := Arg_List_Last + 1;
1445 Arg_List (Arg_List_Last) := Command (First)'Access;
1448 -- Start of processing for Spawn
1451 Add_To_Command (Program_Name);
1453 for J in Args'Range loop
1454 Add_To_Command (Args (J).all);
1459 Result := Portable_Spawn (Arg_List'Address);
1461 Pid := Portable_No_Block_Spawn (Arg_List'Address);
1462 Result := Boolean'Pos (Pid /= Invalid_Pid);
1466 -- Start of processing for Spawn_Internal
1469 -- Copy arguments into a local structure
1471 for K in N_Args'Range loop
1472 N_Args (K) := new String'(Args (K).all);
1475 -- Normalize those arguments
1477 Normalize_Arguments (N_Args);
1479 -- Call spawn using the normalized arguments
1483 -- Free arguments list
1485 for K in N_Args'Range loop
1490 ---------------------------
1491 -- To_Path_String_Access --
1492 ---------------------------
1494 function To_Path_String_Access
1495 (Path_Addr : Address;
1497 return String_Access
1499 subtype Path_String is String (1 .. Path_Len);
1500 type Path_String_Access is access Path_String;
1502 function Address_To_Access is new
1503 Unchecked_Conversion (Source => Address,
1504 Target => Path_String_Access);
1506 Path_Access : Path_String_Access := Address_To_Access (Path_Addr);
1508 Return_Val : String_Access;
1511 Return_Val := new String (1 .. Path_Len);
1513 for J in 1 .. Path_Len loop
1514 Return_Val (J) := Path_Access (J);
1518 end To_Path_String_Access;
1524 procedure Wait_Process (Pid : out Process_Id; Success : out Boolean) is
1527 function Portable_Wait (S : Address) return Process_Id;
1528 pragma Import (C, Portable_Wait, "__gnat_portable_wait");
1531 Pid := Portable_Wait (Status'Address);
1532 Success := (Status = 0);