1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
5 -- S Y S T E M . O S _ L I B --
9 -- Copyright (C) 1995-2009, AdaCore --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 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, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, 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 ------------------------------------------------------------------------------
36 with System.Case_Util;
38 with System.Soft_Links;
39 with Ada.Unchecked_Conversion;
40 with Ada.Unchecked_Deallocation;
41 with System; use System;
43 package body System.OS_Lib is
45 -- Imported procedures Dup and Dup2 are used in procedures Spawn and
46 -- Non_Blocking_Spawn.
48 function Dup (Fd : File_Descriptor) return File_Descriptor;
49 pragma Import (C, Dup, "__gnat_dup");
51 procedure Dup2 (Old_Fd, New_Fd : File_Descriptor);
52 pragma Import (C, Dup2, "__gnat_dup2");
54 On_Windows : constant Boolean := Directory_Separator = '\';
55 -- An indication that we are on Windows. Used in Normalize_Pathname, to
56 -- deal with drive letters in the beginning of absolute paths.
58 package SSL renames System.Soft_Links;
60 -- The following are used by Create_Temp_File
62 First_Temp_File_Name : constant String := "GNAT-TEMP-000000.TMP";
63 -- Used to initialize Current_Temp_File_Name and Temp_File_Name_Last_Digit
65 Current_Temp_File_Name : String := First_Temp_File_Name;
66 -- Name of the temp file last created
68 Temp_File_Name_Last_Digit : constant Positive :=
69 First_Temp_File_Name'Last - 4;
70 -- Position of the last digit in Current_Temp_File_Name
72 Max_Attempts : constant := 100;
73 -- The maximum number of attempts to create a new temp file
75 -----------------------
76 -- Local Subprograms --
77 -----------------------
79 function Args_Length (Args : Argument_List) return Natural;
80 -- Returns total number of characters needed to create a string
81 -- of all Args terminated by ASCII.NUL characters
83 procedure Create_Temp_File_Internal
84 (FD : out File_Descriptor;
85 Name : out String_Access;
87 -- Internal routine to implement two Create_Temp_File routines. If Stdout
88 -- is set to True the created descriptor is stdout-compatible, otherwise
89 -- it might not be depending on the OS (VMS is one example). The first two
90 -- parameters are as in Create_Temp_File.
92 function C_String_Length (S : Address) return Integer;
93 -- Returns the length of a C string. Does check for null address
96 procedure Spawn_Internal
97 (Program_Name : String;
100 Pid : out Process_Id;
102 -- Internal routine to implement the two Spawn (blocking/non blocking)
103 -- routines. If Blocking is set to True then the spawn is blocking
104 -- otherwise it is non blocking. In this latter case the Pid contains the
105 -- process id number. The first three parameters are as in Spawn. Note that
106 -- Spawn_Internal normalizes the argument list before calling the low level
107 -- system spawn routines (see Normalize_Arguments).
109 -- Note: Normalize_Arguments is designed to do nothing if it is called more
110 -- than once, so calling Normalize_Arguments before calling one of the
111 -- spawn routines is fine.
113 function To_Path_String_Access
114 (Path_Addr : Address;
115 Path_Len : Integer) return String_Access;
116 -- Converts a C String to an Ada String. We could do this making use of
117 -- Interfaces.C.Strings but we prefer not to import that entire package
123 function "<" (X, Y : OS_Time) return Boolean is
125 return Long_Integer (X) < Long_Integer (Y);
132 function "<=" (X, Y : OS_Time) return Boolean is
134 return Long_Integer (X) <= Long_Integer (Y);
141 function ">" (X, Y : OS_Time) return Boolean is
143 return Long_Integer (X) > Long_Integer (Y);
150 function ">=" (X, Y : OS_Time) return Boolean is
152 return Long_Integer (X) >= Long_Integer (Y);
159 function Args_Length (Args : Argument_List) return Natural is
163 for J in Args'Range loop
164 Len := Len + Args (J)'Length + 1; -- One extra for ASCII.NUL
170 -----------------------------
171 -- Argument_String_To_List --
172 -----------------------------
174 function Argument_String_To_List
175 (Arg_String : String) return Argument_List_Access
177 Max_Args : constant Integer := Arg_String'Length;
178 New_Argv : Argument_List (1 .. Max_Args);
179 New_Argc : Natural := 0;
183 Idx := Arg_String'First;
186 exit when Idx > Arg_String'Last;
189 Quoted : Boolean := False;
190 Backqd : Boolean := False;
197 -- An unquoted space is the end of an argument
199 if not (Backqd or Quoted)
200 and then Arg_String (Idx) = ' '
204 -- Start of a quoted string
206 elsif not (Backqd or Quoted)
207 and then Arg_String (Idx) = '"'
211 -- End of a quoted string and end of an argument
213 elsif (Quoted and not Backqd)
214 and then Arg_String (Idx) = '"'
219 -- Following character is backquoted
221 elsif Arg_String (Idx) = '\' then
224 -- Turn off backquoting after advancing one character
232 exit when Idx > Arg_String'Last;
237 New_Argc := New_Argc + 1;
238 New_Argv (New_Argc) :=
239 new String'(Arg_String (Old_Idx .. Idx - 1));
241 -- Skip extraneous spaces
243 while Idx <= Arg_String'Last and then Arg_String (Idx) = ' ' loop
249 return new Argument_List'(New_Argv (1 .. New_Argc));
250 end Argument_String_To_List;
252 ---------------------
253 -- C_String_Length --
254 ---------------------
256 function C_String_Length (S : Address) return Integer is
257 function Strlen (S : Address) return Integer;
258 pragma Import (C, Strlen, "strlen");
260 if S = Null_Address then
271 procedure Close (FD : File_Descriptor) is
272 procedure C_Close (FD : File_Descriptor);
273 pragma Import (C, C_Close, "close");
278 procedure Close (FD : File_Descriptor; Status : out Boolean) is
279 function C_Close (FD : File_Descriptor) return Integer;
280 pragma Import (C, C_Close, "close");
282 Status := (C_Close (FD) = 0);
292 Success : out Boolean;
293 Mode : Copy_Mode := Copy;
294 Preserve : Attribute := Time_Stamps)
296 From : File_Descriptor;
297 To : File_Descriptor;
299 Copy_Error : exception;
300 -- Internal exception raised to signal error in copy
302 function Build_Path (Dir : String; File : String) return String;
303 -- Returns pathname Dir concatenated with File adding the directory
304 -- separator only if needed.
306 procedure Copy (From, To : File_Descriptor);
307 -- Read data from From and place them into To. In both cases the
308 -- operations uses the current file position. Raises Constraint_Error
309 -- if a problem occurs during the copy.
311 procedure Copy_To (To_Name : String);
312 -- Does a straight copy from source to designated destination file
318 function Build_Path (Dir : String; File : String) return String is
319 Res : String (1 .. Dir'Length + File'Length + 1);
321 Base_File_Ptr : Integer;
322 -- The base file name is File (Base_File_Ptr + 1 .. File'Last)
324 function Is_Dirsep (C : Character) return Boolean;
325 pragma Inline (Is_Dirsep);
326 -- Returns True if C is a directory separator. On Windows we
327 -- handle both styles of directory separator.
333 function Is_Dirsep (C : Character) return Boolean is
335 return C = Directory_Separator or else C = '/';
338 -- Start of processing for Build_Path
341 -- Find base file name
343 Base_File_Ptr := File'Last;
344 while Base_File_Ptr >= File'First loop
345 exit when Is_Dirsep (File (Base_File_Ptr));
346 Base_File_Ptr := Base_File_Ptr - 1;
350 Base_File : String renames
351 File (Base_File_Ptr + 1 .. File'Last);
354 Res (1 .. Dir'Length) := Dir;
356 if Is_Dirsep (Dir (Dir'Last)) then
357 Res (Dir'Length + 1 .. Dir'Length + Base_File'Length) :=
359 return Res (1 .. Dir'Length + Base_File'Length);
362 Res (Dir'Length + 1) := Directory_Separator;
363 Res (Dir'Length + 2 .. Dir'Length + 1 + Base_File'Length) :=
365 return Res (1 .. Dir'Length + 1 + Base_File'Length);
374 procedure Copy (From, To : File_Descriptor) is
375 Buf_Size : constant := 200_000;
376 type Buf is array (1 .. Buf_Size) of Character;
377 type Buf_Ptr is access Buf;
383 Status_From : Boolean;
385 -- Statuses for the calls to Close
387 procedure Free is new Ada.Unchecked_Deallocation (Buf, Buf_Ptr);
390 -- Check for invalid descriptors, making sure that we do not
391 -- accidentally leave an open file descriptor around.
393 if From = Invalid_FD then
394 if To /= Invalid_FD then
395 Close (To, Status_To);
400 elsif To = Invalid_FD then
401 Close (From, Status_From);
405 -- Allocate the buffer on the heap
410 R := Read (From, Buffer (1)'Address, Buf_Size);
412 -- For VMS, the buffer may not be full. So, we need to try again
413 -- until there is nothing to read.
417 W := Write (To, Buffer (1)'Address, R);
421 -- Problem writing data, could be a disk full. Close files
422 -- without worrying about status, since we are raising a
423 -- Copy_Error exception in any case.
425 Close (From, Status_From);
426 Close (To, Status_To);
434 Close (From, Status_From);
435 Close (To, Status_To);
439 if not (Status_From and Status_To) then
448 procedure Copy_To (To_Name : String) is
450 function Copy_Attributes
451 (From, To : System.Address;
452 Mode : Integer) return Integer;
453 pragma Import (C, Copy_Attributes, "__gnat_copy_attribs");
454 -- Mode = 0 - copy only time stamps.
455 -- Mode = 1 - copy time stamps and read/write/execute attributes
457 C_From : String (1 .. Name'Length + 1);
458 C_To : String (1 .. To_Name'Length + 1);
461 From := Open_Read (Name, Binary);
463 -- Do not clobber destination file if source file could not be opened
465 if From /= Invalid_FD then
466 To := Create_File (To_Name, Binary);
473 C_From (1 .. Name'Length) := Name;
474 C_From (C_From'Last) := ASCII.NUL;
476 C_To (1 .. To_Name'Length) := To_Name;
477 C_To (C_To'Last) := ASCII.NUL;
482 if Copy_Attributes (C_From'Address, C_To'Address, 0) = -1 then
487 if Copy_Attributes (C_From'Address, C_To'Address, 1) = -1 then
497 -- Start of processing for Copy_File
502 -- The source file must exist
504 if not Is_Regular_File (Name) then
508 -- The source file exists
512 -- Copy case, target file must not exist
516 -- If the target file exists, we have an error
518 if Is_Regular_File (Pathname) then
521 -- Case of target is a directory
523 elsif Is_Directory (Pathname) then
525 Dest : constant String := Build_Path (Pathname, Name);
528 -- If target file exists, we have an error, else do copy
530 if Is_Regular_File (Dest) then
537 -- Case of normal copy to file (destination does not exist)
543 -- Overwrite case (destination file may or may not exist)
546 if Is_Directory (Pathname) then
547 Copy_To (Build_Path (Pathname, Name));
552 -- Append case (destination file may or may not exist)
556 -- Appending to existing file
558 if Is_Regular_File (Pathname) then
560 -- Append mode and destination file exists, append data at the
561 -- end of Pathname. But if we fail to open source file, do not
562 -- touch destination file at all.
564 From := Open_Read (Name, Binary);
565 if From /= Invalid_FD then
566 To := Open_Read_Write (Pathname, Binary);
569 Lseek (To, 0, Seek_End);
573 -- Appending to directory, not allowed
575 elsif Is_Directory (Pathname) then
578 -- Appending when target file does not exist
585 -- All error cases are caught here
594 Pathname : C_File_Name;
595 Success : out Boolean;
596 Mode : Copy_Mode := Copy;
597 Preserve : Attribute := Time_Stamps)
599 Ada_Name : String_Access :=
600 To_Path_String_Access
601 (Name, C_String_Length (Name));
602 Ada_Pathname : String_Access :=
603 To_Path_String_Access
604 (Pathname, C_String_Length (Pathname));
606 Copy_File (Ada_Name.all, Ada_Pathname.all, Success, Mode, Preserve);
611 ----------------------
612 -- Copy_Time_Stamps --
613 ----------------------
615 procedure Copy_Time_Stamps (Source, Dest : String; Success : out Boolean) is
617 function Copy_Attributes
618 (From, To : System.Address;
619 Mode : Integer) return Integer;
620 pragma Import (C, Copy_Attributes, "__gnat_copy_attribs");
621 -- Mode = 0 - copy only time stamps.
622 -- Mode = 1 - copy time stamps and read/write/execute attributes
625 if Is_Regular_File (Source) and then Is_Writable_File (Dest) then
627 C_Source : String (1 .. Source'Length + 1);
628 C_Dest : String (1 .. Dest'Length + 1);
631 C_Source (1 .. Source'Length) := Source;
632 C_Source (C_Source'Last) := ASCII.NUL;
634 C_Dest (1 .. Dest'Length) := Dest;
635 C_Dest (C_Dest'Last) := ASCII.NUL;
637 if Copy_Attributes (C_Source'Address, C_Dest'Address, 0) = -1 then
647 end Copy_Time_Stamps;
649 procedure Copy_Time_Stamps
650 (Source, Dest : C_File_Name;
651 Success : out Boolean)
653 Ada_Source : String_Access :=
654 To_Path_String_Access
655 (Source, C_String_Length (Source));
656 Ada_Dest : String_Access :=
657 To_Path_String_Access
658 (Dest, C_String_Length (Dest));
660 Copy_Time_Stamps (Ada_Source.all, Ada_Dest.all, Success);
663 end Copy_Time_Stamps;
671 Fmode : Mode) return File_Descriptor
673 function C_Create_File
675 Fmode : Mode) return File_Descriptor;
676 pragma Import (C, C_Create_File, "__gnat_open_create");
679 return C_Create_File (Name, Fmode);
684 Fmode : Mode) return File_Descriptor
686 C_Name : String (1 .. Name'Length + 1);
689 C_Name (1 .. Name'Length) := Name;
690 C_Name (C_Name'Last) := ASCII.NUL;
691 return Create_File (C_Name (C_Name'First)'Address, Fmode);
694 ---------------------
695 -- Create_New_File --
696 ---------------------
698 function Create_New_File
700 Fmode : Mode) return File_Descriptor
702 function C_Create_New_File
704 Fmode : Mode) return File_Descriptor;
705 pragma Import (C, C_Create_New_File, "__gnat_open_new");
708 return C_Create_New_File (Name, Fmode);
711 function Create_New_File
713 Fmode : Mode) return File_Descriptor
715 C_Name : String (1 .. Name'Length + 1);
718 C_Name (1 .. Name'Length) := Name;
719 C_Name (C_Name'Last) := ASCII.NUL;
720 return Create_New_File (C_Name (C_Name'First)'Address, Fmode);
723 -----------------------------
724 -- Create_Output_Text_File --
725 -----------------------------
727 function Create_Output_Text_File (Name : String) return File_Descriptor is
728 function C_Create_File
729 (Name : C_File_Name) return File_Descriptor;
730 pragma Import (C, C_Create_File, "__gnat_create_output_file");
732 C_Name : String (1 .. Name'Length + 1);
735 C_Name (1 .. Name'Length) := Name;
736 C_Name (C_Name'Last) := ASCII.NUL;
737 return C_Create_File (C_Name (C_Name'First)'Address);
738 end Create_Output_Text_File;
740 ----------------------
741 -- Create_Temp_File --
742 ----------------------
744 procedure Create_Temp_File
745 (FD : out File_Descriptor;
746 Name : out Temp_File_Name)
748 function Open_New_Temp
749 (Name : System.Address;
750 Fmode : Mode) return File_Descriptor;
751 pragma Import (C, Open_New_Temp, "__gnat_open_new_temp");
754 FD := Open_New_Temp (Name'Address, Binary);
755 end Create_Temp_File;
757 procedure Create_Temp_File
758 (FD : out File_Descriptor;
759 Name : out String_Access)
762 Create_Temp_File_Internal (FD, Name, Stdout => False);
763 end Create_Temp_File;
765 procedure Create_Temp_Output_File
766 (FD : out File_Descriptor;
767 Name : out String_Access)
770 Create_Temp_File_Internal (FD, Name, Stdout => True);
771 end Create_Temp_Output_File;
773 -------------------------------
774 -- Create_Temp_File_Internal --
775 -------------------------------
777 procedure Create_Temp_File_Internal
778 (FD : out File_Descriptor;
779 Name : out String_Access;
783 Attempts : Natural := 0;
784 Current : String (Current_Temp_File_Name'Range);
787 -- Loop until a new temp file can be created
791 -- We need to protect global variable Current_Temp_File_Name
792 -- against concurrent access by different tasks.
796 -- Start at the last digit
798 Pos := Temp_File_Name_Last_Digit;
802 -- Increment the digit by one
804 case Current_Temp_File_Name (Pos) is
806 Current_Temp_File_Name (Pos) :=
807 Character'Succ (Current_Temp_File_Name (Pos));
812 -- For 9, set the digit to 0 and go to the previous digit
814 Current_Temp_File_Name (Pos) := '0';
819 -- If it is not a digit, then there are no available
820 -- temp file names. Return Invalid_FD. There is almost
821 -- no chance that this code will be ever be executed,
822 -- since it would mean that there are one million temp
823 -- files in the same directory!
832 Current := Current_Temp_File_Name;
834 -- We can now release the lock, because we are no longer
835 -- accessing Current_Temp_File_Name.
845 -- Attempt to create the file
848 FD := Create_Output_Text_File (Current);
850 FD := Create_File (Current, Binary);
853 if FD /= Invalid_FD then
854 Name := new String'(Current);
858 if not Is_Regular_File (Current) then
860 -- If the file does not already exist and we are unable to create
861 -- it, we give up after Max_Attempts. Otherwise, we try again with
862 -- the next available file name.
864 Attempts := Attempts + 1;
866 if Attempts >= Max_Attempts then
873 end Create_Temp_File_Internal;
879 procedure Delete_File (Name : Address; Success : out Boolean) is
882 R := System.CRTL.unlink (Name);
886 procedure Delete_File (Name : String; Success : out Boolean) is
887 C_Name : String (1 .. Name'Length + 1);
890 C_Name (1 .. Name'Length) := Name;
891 C_Name (C_Name'Last) := ASCII.NUL;
893 Delete_File (C_Name'Address, Success);
896 ---------------------
897 -- File_Time_Stamp --
898 ---------------------
900 function File_Time_Stamp (FD : File_Descriptor) return OS_Time is
901 function File_Time (FD : File_Descriptor) return OS_Time;
902 pragma Import (C, File_Time, "__gnat_file_time_fd");
904 return File_Time (FD);
907 function File_Time_Stamp (Name : C_File_Name) return OS_Time is
908 function File_Time (Name : Address) return OS_Time;
909 pragma Import (C, File_Time, "__gnat_file_time_name");
911 return File_Time (Name);
914 function File_Time_Stamp (Name : String) return OS_Time is
915 F_Name : String (1 .. Name'Length + 1);
917 F_Name (1 .. Name'Length) := Name;
918 F_Name (F_Name'Last) := ASCII.NUL;
919 return File_Time_Stamp (F_Name'Address);
922 ---------------------------
923 -- Get_Debuggable_Suffix --
924 ---------------------------
926 function Get_Debuggable_Suffix return String_Access is
927 procedure Get_Suffix_Ptr (Length, Ptr : Address);
928 pragma Import (C, Get_Suffix_Ptr, "__gnat_get_debuggable_suffix_ptr");
930 procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
931 pragma Import (C, Strncpy, "strncpy");
933 Suffix_Ptr : Address;
934 Suffix_Length : Integer;
935 Result : String_Access;
938 Get_Suffix_Ptr (Suffix_Length'Address, Suffix_Ptr'Address);
940 Result := new String (1 .. Suffix_Length);
942 if Suffix_Length > 0 then
943 Strncpy (Result.all'Address, Suffix_Ptr, Suffix_Length);
947 end Get_Debuggable_Suffix;
949 ---------------------------
950 -- Get_Executable_Suffix --
951 ---------------------------
953 function Get_Executable_Suffix return String_Access is
954 procedure Get_Suffix_Ptr (Length, Ptr : Address);
955 pragma Import (C, Get_Suffix_Ptr, "__gnat_get_executable_suffix_ptr");
957 procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
958 pragma Import (C, Strncpy, "strncpy");
960 Suffix_Ptr : Address;
961 Suffix_Length : Integer;
962 Result : String_Access;
965 Get_Suffix_Ptr (Suffix_Length'Address, Suffix_Ptr'Address);
967 Result := new String (1 .. Suffix_Length);
969 if Suffix_Length > 0 then
970 Strncpy (Result.all'Address, Suffix_Ptr, Suffix_Length);
974 end Get_Executable_Suffix;
976 -----------------------
977 -- Get_Object_Suffix --
978 -----------------------
980 function Get_Object_Suffix return String_Access is
981 procedure Get_Suffix_Ptr (Length, Ptr : Address);
982 pragma Import (C, Get_Suffix_Ptr, "__gnat_get_object_suffix_ptr");
984 procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
985 pragma Import (C, Strncpy, "strncpy");
987 Suffix_Ptr : Address;
988 Suffix_Length : Integer;
989 Result : String_Access;
992 Get_Suffix_Ptr (Suffix_Length'Address, Suffix_Ptr'Address);
994 Result := new String (1 .. Suffix_Length);
996 if Suffix_Length > 0 then
997 Strncpy (Result.all'Address, Suffix_Ptr, Suffix_Length);
1001 end Get_Object_Suffix;
1003 ----------------------------------
1004 -- Get_Target_Debuggable_Suffix --
1005 ----------------------------------
1007 function Get_Target_Debuggable_Suffix return String_Access is
1008 Target_Exec_Ext_Ptr : Address;
1010 (C, Target_Exec_Ext_Ptr, "__gnat_target_debuggable_extension");
1012 procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
1013 pragma Import (C, Strncpy, "strncpy");
1015 function Strlen (Cstring : Address) return Integer;
1016 pragma Import (C, Strlen, "strlen");
1018 Suffix_Length : Integer;
1019 Result : String_Access;
1022 Suffix_Length := Strlen (Target_Exec_Ext_Ptr);
1024 Result := new String (1 .. Suffix_Length);
1026 if Suffix_Length > 0 then
1027 Strncpy (Result.all'Address, Target_Exec_Ext_Ptr, Suffix_Length);
1031 end Get_Target_Debuggable_Suffix;
1033 ----------------------------------
1034 -- Get_Target_Executable_Suffix --
1035 ----------------------------------
1037 function Get_Target_Executable_Suffix return String_Access is
1038 Target_Exec_Ext_Ptr : Address;
1040 (C, Target_Exec_Ext_Ptr, "__gnat_target_executable_extension");
1042 procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
1043 pragma Import (C, Strncpy, "strncpy");
1045 function Strlen (Cstring : Address) return Integer;
1046 pragma Import (C, Strlen, "strlen");
1048 Suffix_Length : Integer;
1049 Result : String_Access;
1052 Suffix_Length := Strlen (Target_Exec_Ext_Ptr);
1054 Result := new String (1 .. Suffix_Length);
1056 if Suffix_Length > 0 then
1057 Strncpy (Result.all'Address, Target_Exec_Ext_Ptr, Suffix_Length);
1061 end Get_Target_Executable_Suffix;
1063 ------------------------------
1064 -- Get_Target_Object_Suffix --
1065 ------------------------------
1067 function Get_Target_Object_Suffix return String_Access is
1068 Target_Object_Ext_Ptr : Address;
1070 (C, Target_Object_Ext_Ptr, "__gnat_target_object_extension");
1072 procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
1073 pragma Import (C, Strncpy, "strncpy");
1075 function Strlen (Cstring : Address) return Integer;
1076 pragma Import (C, Strlen, "strlen");
1078 Suffix_Length : Integer;
1079 Result : String_Access;
1082 Suffix_Length := Strlen (Target_Object_Ext_Ptr);
1084 Result := new String (1 .. Suffix_Length);
1086 if Suffix_Length > 0 then
1087 Strncpy (Result.all'Address, Target_Object_Ext_Ptr, Suffix_Length);
1091 end Get_Target_Object_Suffix;
1097 function Getenv (Name : String) return String_Access is
1098 procedure Get_Env_Value_Ptr (Name, Length, Ptr : Address);
1099 pragma Import (C, Get_Env_Value_Ptr, "__gnat_getenv");
1101 procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
1102 pragma Import (C, Strncpy, "strncpy");
1104 Env_Value_Ptr : aliased Address;
1105 Env_Value_Length : aliased Integer;
1106 F_Name : aliased String (1 .. Name'Length + 1);
1107 Result : String_Access;
1110 F_Name (1 .. Name'Length) := Name;
1111 F_Name (F_Name'Last) := ASCII.NUL;
1114 (F_Name'Address, Env_Value_Length'Address, Env_Value_Ptr'Address);
1116 Result := new String (1 .. Env_Value_Length);
1118 if Env_Value_Length > 0 then
1119 Strncpy (Result.all'Address, Env_Value_Ptr, Env_Value_Length);
1129 function GM_Day (Date : OS_Time) return Day_Type is
1132 pragma Warnings (Off);
1138 pragma Warnings (On);
1141 GM_Split (Date, Y, Mo, D, H, Mn, S);
1149 function GM_Hour (Date : OS_Time) return Hour_Type is
1152 pragma Warnings (Off);
1158 pragma Warnings (On);
1161 GM_Split (Date, Y, Mo, D, H, Mn, S);
1169 function GM_Minute (Date : OS_Time) return Minute_Type is
1172 pragma Warnings (Off);
1178 pragma Warnings (On);
1181 GM_Split (Date, Y, Mo, D, H, Mn, S);
1189 function GM_Month (Date : OS_Time) return Month_Type is
1192 pragma Warnings (Off);
1198 pragma Warnings (On);
1201 GM_Split (Date, Y, Mo, D, H, Mn, S);
1209 function GM_Second (Date : OS_Time) return Second_Type is
1212 pragma Warnings (Off);
1218 pragma Warnings (On);
1221 GM_Split (Date, Y, Mo, D, H, Mn, S);
1231 Year : out Year_Type;
1232 Month : out Month_Type;
1234 Hour : out Hour_Type;
1235 Minute : out Minute_Type;
1236 Second : out Second_Type)
1238 procedure To_GM_Time
1239 (P_Time_T, P_Year, P_Month, P_Day, P_Hours, P_Mins, P_Secs : Address);
1240 pragma Import (C, To_GM_Time, "__gnat_to_gm_time");
1242 T : OS_Time := Date;
1251 -- Use the global lock because To_GM_Time is not thread safe
1253 Locked_Processing : begin
1256 (T'Address, Y'Address, Mo'Address, D'Address,
1257 H'Address, Mn'Address, S'Address);
1258 SSL.Unlock_Task.all;
1262 SSL.Unlock_Task.all;
1264 end Locked_Processing;
1278 function GM_Year (Date : OS_Time) return Year_Type is
1281 pragma Warnings (Off);
1287 pragma Warnings (On);
1290 GM_Split (Date, Y, Mo, D, H, Mn, S);
1294 ----------------------
1295 -- Is_Absolute_Path --
1296 ----------------------
1298 function Is_Absolute_Path (Name : String) return Boolean is
1299 function Is_Absolute_Path
1301 Length : Integer) return Integer;
1302 pragma Import (C, Is_Absolute_Path, "__gnat_is_absolute_path");
1304 return Is_Absolute_Path (Name'Address, Name'Length) /= 0;
1305 end Is_Absolute_Path;
1311 function Is_Directory (Name : C_File_Name) return Boolean is
1312 function Is_Directory (Name : Address) return Integer;
1313 pragma Import (C, Is_Directory, "__gnat_is_directory");
1315 return Is_Directory (Name) /= 0;
1318 function Is_Directory (Name : String) return Boolean is
1319 F_Name : String (1 .. Name'Length + 1);
1321 F_Name (1 .. Name'Length) := Name;
1322 F_Name (F_Name'Last) := ASCII.NUL;
1323 return Is_Directory (F_Name'Address);
1326 ----------------------
1327 -- Is_Readable_File --
1328 ----------------------
1330 function Is_Readable_File (Name : C_File_Name) return Boolean is
1331 function Is_Readable_File (Name : Address) return Integer;
1332 pragma Import (C, Is_Readable_File, "__gnat_is_readable_file");
1334 return Is_Readable_File (Name) /= 0;
1335 end Is_Readable_File;
1337 function Is_Readable_File (Name : String) return Boolean is
1338 F_Name : String (1 .. Name'Length + 1);
1340 F_Name (1 .. Name'Length) := Name;
1341 F_Name (F_Name'Last) := ASCII.NUL;
1342 return Is_Readable_File (F_Name'Address);
1343 end Is_Readable_File;
1345 ------------------------
1346 -- Is_Executable_File --
1347 ------------------------
1349 function Is_Executable_File (Name : C_File_Name) return Boolean is
1350 function Is_Executable_File (Name : Address) return Integer;
1351 pragma Import (C, Is_Executable_File, "__gnat_is_executable_file");
1353 return Is_Executable_File (Name) /= 0;
1354 end Is_Executable_File;
1356 function Is_Executable_File (Name : String) return Boolean is
1357 F_Name : String (1 .. Name'Length + 1);
1359 F_Name (1 .. Name'Length) := Name;
1360 F_Name (F_Name'Last) := ASCII.NUL;
1361 return Is_Executable_File (F_Name'Address);
1362 end Is_Executable_File;
1364 ---------------------
1365 -- Is_Regular_File --
1366 ---------------------
1368 function Is_Regular_File (Name : C_File_Name) return Boolean is
1369 function Is_Regular_File (Name : Address) return Integer;
1370 pragma Import (C, Is_Regular_File, "__gnat_is_regular_file");
1372 return Is_Regular_File (Name) /= 0;
1373 end Is_Regular_File;
1375 function Is_Regular_File (Name : String) return Boolean is
1376 F_Name : String (1 .. Name'Length + 1);
1378 F_Name (1 .. Name'Length) := Name;
1379 F_Name (F_Name'Last) := ASCII.NUL;
1380 return Is_Regular_File (F_Name'Address);
1381 end Is_Regular_File;
1383 ----------------------
1384 -- Is_Symbolic_Link --
1385 ----------------------
1387 function Is_Symbolic_Link (Name : C_File_Name) return Boolean is
1388 function Is_Symbolic_Link (Name : Address) return Integer;
1389 pragma Import (C, Is_Symbolic_Link, "__gnat_is_symbolic_link");
1391 return Is_Symbolic_Link (Name) /= 0;
1392 end Is_Symbolic_Link;
1394 function Is_Symbolic_Link (Name : String) return Boolean is
1395 F_Name : String (1 .. Name'Length + 1);
1397 F_Name (1 .. Name'Length) := Name;
1398 F_Name (F_Name'Last) := ASCII.NUL;
1399 return Is_Symbolic_Link (F_Name'Address);
1400 end Is_Symbolic_Link;
1402 ----------------------
1403 -- Is_Writable_File --
1404 ----------------------
1406 function Is_Writable_File (Name : C_File_Name) return Boolean is
1407 function Is_Writable_File (Name : Address) return Integer;
1408 pragma Import (C, Is_Writable_File, "__gnat_is_writable_file");
1410 return Is_Writable_File (Name) /= 0;
1411 end Is_Writable_File;
1413 function Is_Writable_File (Name : String) return Boolean is
1414 F_Name : String (1 .. Name'Length + 1);
1416 F_Name (1 .. Name'Length) := Name;
1417 F_Name (F_Name'Last) := ASCII.NUL;
1418 return Is_Writable_File (F_Name'Address);
1419 end Is_Writable_File;
1421 -------------------------
1422 -- Locate_Exec_On_Path --
1423 -------------------------
1425 function Locate_Exec_On_Path
1426 (Exec_Name : String) return String_Access
1428 function Locate_Exec_On_Path (C_Exec_Name : Address) return Address;
1429 pragma Import (C, Locate_Exec_On_Path, "__gnat_locate_exec_on_path");
1431 procedure Free (Ptr : System.Address);
1432 pragma Import (C, Free, "free");
1434 C_Exec_Name : String (1 .. Exec_Name'Length + 1);
1435 Path_Addr : Address;
1437 Result : String_Access;
1440 C_Exec_Name (1 .. Exec_Name'Length) := Exec_Name;
1441 C_Exec_Name (C_Exec_Name'Last) := ASCII.NUL;
1443 Path_Addr := Locate_Exec_On_Path (C_Exec_Name'Address);
1444 Path_Len := C_String_Length (Path_Addr);
1446 if Path_Len = 0 then
1450 Result := To_Path_String_Access (Path_Addr, Path_Len);
1453 -- Always return an absolute path name
1455 if not Is_Absolute_Path (Result.all) then
1457 Absolute_Path : constant String :=
1458 Normalize_Pathname (Result.all);
1461 Result := new String'(Absolute_Path);
1467 end Locate_Exec_On_Path;
1469 -------------------------
1470 -- Locate_Regular_File --
1471 -------------------------
1473 function Locate_Regular_File
1474 (File_Name : C_File_Name;
1475 Path : C_File_Name) return String_Access
1477 function Locate_Regular_File
1478 (C_File_Name, Path_Val : Address) return Address;
1479 pragma Import (C, Locate_Regular_File, "__gnat_locate_regular_file");
1481 procedure Free (Ptr : System.Address);
1482 pragma Import (C, Free, "free");
1484 Path_Addr : Address;
1486 Result : String_Access;
1489 Path_Addr := Locate_Regular_File (File_Name, Path);
1490 Path_Len := C_String_Length (Path_Addr);
1492 if Path_Len = 0 then
1496 Result := To_Path_String_Access (Path_Addr, Path_Len);
1500 end Locate_Regular_File;
1502 function Locate_Regular_File
1503 (File_Name : String;
1504 Path : String) return String_Access
1506 C_File_Name : String (1 .. File_Name'Length + 1);
1507 C_Path : String (1 .. Path'Length + 1);
1508 Result : String_Access;
1511 C_File_Name (1 .. File_Name'Length) := File_Name;
1512 C_File_Name (C_File_Name'Last) := ASCII.NUL;
1514 C_Path (1 .. Path'Length) := Path;
1515 C_Path (C_Path'Last) := ASCII.NUL;
1517 Result := Locate_Regular_File (C_File_Name'Address, C_Path'Address);
1519 -- Always return an absolute path name
1521 if Result /= null and then not Is_Absolute_Path (Result.all) then
1523 Absolute_Path : constant String := Normalize_Pathname (Result.all);
1526 Result := new String'(Absolute_Path);
1531 end Locate_Regular_File;
1533 ------------------------
1534 -- Non_Blocking_Spawn --
1535 ------------------------
1537 function Non_Blocking_Spawn
1538 (Program_Name : String;
1539 Args : Argument_List) return Process_Id
1543 pragma Warnings (Off, Junk);
1545 Spawn_Internal (Program_Name, Args, Junk, Pid, Blocking => False);
1547 end Non_Blocking_Spawn;
1549 function Non_Blocking_Spawn
1550 (Program_Name : String;
1551 Args : Argument_List;
1552 Output_File_Descriptor : File_Descriptor;
1553 Err_To_Out : Boolean := True) return Process_Id
1555 Saved_Output : File_Descriptor;
1556 Saved_Error : File_Descriptor := Invalid_FD; -- prevent warning
1560 if Output_File_Descriptor = Invalid_FD then
1564 -- Set standard output and, if specified, error to the temporary file
1566 Saved_Output := Dup (Standout);
1567 Dup2 (Output_File_Descriptor, Standout);
1570 Saved_Error := Dup (Standerr);
1571 Dup2 (Output_File_Descriptor, Standerr);
1574 -- Spawn the program
1576 Pid := Non_Blocking_Spawn (Program_Name, Args);
1578 -- Restore the standard output and error
1580 Dup2 (Saved_Output, Standout);
1583 Dup2 (Saved_Error, Standerr);
1586 -- And close the saved standard output and error file descriptors
1588 Close (Saved_Output);
1591 Close (Saved_Error);
1595 end Non_Blocking_Spawn;
1597 function Non_Blocking_Spawn
1598 (Program_Name : String;
1599 Args : Argument_List;
1600 Output_File : String;
1601 Err_To_Out : Boolean := True) return Process_Id
1603 Output_File_Descriptor : constant File_Descriptor :=
1604 Create_Output_Text_File (Output_File);
1605 Result : Process_Id;
1608 -- Do not attempt to spawn if the output file could not be created
1610 if Output_File_Descriptor = Invalid_FD then
1614 Result := Non_Blocking_Spawn
1615 (Program_Name, Args, Output_File_Descriptor, Err_To_Out);
1617 -- Close the file just created for the output, as the file descriptor
1618 -- cannot be used anywhere, being a local value. It is safe to do
1619 -- that, as the file descriptor has been duplicated to form
1620 -- standard output and error of the spawned process.
1622 Close (Output_File_Descriptor);
1626 end Non_Blocking_Spawn;
1628 -------------------------
1629 -- Normalize_Arguments --
1630 -------------------------
1632 procedure Normalize_Arguments (Args : in out Argument_List) is
1634 procedure Quote_Argument (Arg : in out String_Access);
1635 -- Add quote around argument if it contains spaces
1637 C_Argument_Needs_Quote : Integer;
1638 pragma Import (C, C_Argument_Needs_Quote, "__gnat_argument_needs_quote");
1639 Argument_Needs_Quote : constant Boolean := C_Argument_Needs_Quote /= 0;
1641 --------------------
1642 -- Quote_Argument --
1643 --------------------
1645 procedure Quote_Argument (Arg : in out String_Access) is
1646 Res : String (1 .. Arg'Length * 2);
1648 Quote_Needed : Boolean := False;
1651 if Arg (Arg'First) /= '"' or else Arg (Arg'Last) /= '"' then
1657 for K in Arg'Range loop
1661 if Arg (K) = '"' then
1665 Quote_Needed := True;
1667 elsif Arg (K) = ' ' then
1669 Quote_Needed := True;
1677 if Quote_Needed then
1679 -- If null terminated string, put the quote before
1681 if Res (J) = ASCII.NUL then
1684 Res (J) := ASCII.NUL;
1686 -- If argument is terminated by '\', then double it. Otherwise
1687 -- the ending quote will be taken as-is. This is quite strange
1688 -- spawn behavior from Windows, but this is what we see!
1691 if Res (J) = '\' then
1703 Old : String_Access := Arg;
1706 Arg := new String'(Res (1 .. J));
1714 -- Start of processing for Normalize_Arguments
1717 if Argument_Needs_Quote then
1718 for K in Args'Range loop
1719 if Args (K) /= null and then Args (K)'Length /= 0 then
1720 Quote_Argument (Args (K));
1724 end Normalize_Arguments;
1726 ------------------------
1727 -- Normalize_Pathname --
1728 ------------------------
1730 function Normalize_Pathname
1732 Directory : String := "";
1733 Resolve_Links : Boolean := True;
1734 Case_Sensitive : Boolean := True) return String
1737 pragma Import (C, Max_Path, "__gnat_max_path_len");
1738 -- Maximum length of a path name
1740 procedure Get_Current_Dir
1741 (Dir : System.Address;
1742 Length : System.Address);
1743 pragma Import (C, Get_Current_Dir, "__gnat_get_current_dir");
1745 Path_Buffer : String (1 .. Max_Path + Max_Path + 2);
1746 End_Path : Natural := 0;
1747 Link_Buffer : String (1 .. Max_Path + 2);
1753 Max_Iterations : constant := 500;
1755 function Get_File_Names_Case_Sensitive return Integer;
1757 (C, Get_File_Names_Case_Sensitive,
1758 "__gnat_get_file_names_case_sensitive");
1760 Fold_To_Lower_Case : constant Boolean :=
1762 and then Get_File_Names_Case_Sensitive = 0;
1765 (Path : System.Address;
1766 Buf : System.Address;
1767 Bufsiz : Integer) return Integer;
1768 pragma Import (C, Readlink, "__gnat_readlink");
1770 function To_Canonical_File_Spec
1771 (Host_File : System.Address) return System.Address;
1773 (C, To_Canonical_File_Spec, "__gnat_to_canonical_file_spec");
1775 The_Name : String (1 .. Name'Length + 1);
1776 Canonical_File_Addr : System.Address;
1777 Canonical_File_Len : Integer;
1779 function Strlen (S : System.Address) return Integer;
1780 pragma Import (C, Strlen, "strlen");
1782 function Final_Value (S : String) return String;
1783 -- Make final adjustment to the returned string. This function strips
1784 -- trailing directory separators, and folds returned string to lower
1785 -- case if required.
1787 function Get_Directory (Dir : String) return String;
1788 -- If Dir is not empty, return it, adding a directory separator
1789 -- if not already present, otherwise return current working directory
1790 -- with terminating directory separator.
1796 function Final_Value (S : String) return String is
1798 -- We may need to fold S to lower case, so we need a variable
1803 if Fold_To_Lower_Case then
1804 System.Case_Util.To_Lower (S1);
1807 -- Remove trailing directory separator, if any
1812 and then (S1 (Last) = '/'
1814 S1 (Last) = Directory_Separator)
1816 -- Special case for Windows: C:\
1819 and then S1 (1) /= Directory_Separator
1820 and then S1 (2) = ':'
1829 return S1 (1 .. Last);
1836 function Get_Directory (Dir : String) return String is
1837 Result : String (1 .. Dir'Length + 1);
1838 Length : constant Natural := Dir'Length;
1841 -- Directory given, add directory separator if needed
1844 Result (1 .. Length) := Dir;
1846 -- On Windows, change all '/' to '\'
1849 for J in 1 .. Length loop
1850 if Result (J) = '/' then
1851 Result (J) := Directory_Separator;
1856 -- Add directory separator, if needed
1858 if Result (Length) = Directory_Separator then
1859 return Result (1 .. Length);
1861 Result (Result'Length) := Directory_Separator;
1865 -- Directory name not given, get current directory
1869 Buffer : String (1 .. Max_Path + 2);
1870 Path_Len : Natural := Max_Path;
1873 Get_Current_Dir (Buffer'Address, Path_Len'Address);
1875 if Buffer (Path_Len) /= Directory_Separator then
1876 Path_Len := Path_Len + 1;
1877 Buffer (Path_Len) := Directory_Separator;
1880 -- By default, the drive letter on Windows is in upper case
1883 and then Path_Len >= 2
1884 and then Buffer (2) = ':'
1886 System.Case_Util.To_Upper (Buffer (1 .. 1));
1889 return Buffer (1 .. Path_Len);
1894 -- Start of processing for Normalize_Pathname
1897 -- Special case, if name is null, then return null
1899 if Name'Length = 0 then
1903 -- First, convert VMS file spec to Unix file spec.
1904 -- If Name is not in VMS syntax, then this is equivalent
1905 -- to put Name at the beginning of Path_Buffer.
1907 VMS_Conversion : begin
1908 The_Name (1 .. Name'Length) := Name;
1909 The_Name (The_Name'Last) := ASCII.NUL;
1911 Canonical_File_Addr := To_Canonical_File_Spec (The_Name'Address);
1912 Canonical_File_Len := Strlen (Canonical_File_Addr);
1914 -- If VMS syntax conversion has failed, return an empty string
1915 -- to indicate the failure.
1917 if Canonical_File_Len = 0 then
1922 subtype Path_String is String (1 .. Canonical_File_Len);
1923 type Path_String_Access is access Path_String;
1925 function Address_To_Access is new
1926 Ada.Unchecked_Conversion (Source => Address,
1927 Target => Path_String_Access);
1929 Path_Access : constant Path_String_Access :=
1930 Address_To_Access (Canonical_File_Addr);
1933 Path_Buffer (1 .. Canonical_File_Len) := Path_Access.all;
1934 End_Path := Canonical_File_Len;
1939 -- Replace all '/' by Directory Separators (this is for Windows)
1941 if Directory_Separator /= '/' then
1942 for Index in 1 .. End_Path loop
1943 if Path_Buffer (Index) = '/' then
1944 Path_Buffer (Index) := Directory_Separator;
1949 -- Resolve directory names for Windows (formerly also VMS)
1951 -- On VMS, if we have a Unix path such as /temp/..., and TEMP is a
1952 -- logical name, we must not try to resolve this logical name, because
1953 -- it may have multiple equivalences and if resolved we will only
1954 -- get the first one.
1958 -- On Windows, if we have an absolute path starting with a directory
1959 -- separator, we need to have the drive letter appended in front.
1961 -- On Windows, Get_Current_Dir will return a suitable directory name
1962 -- (path starting with a drive letter on Windows). So we take this
1963 -- drive letter and prepend it to the current path.
1965 if Path_Buffer (1) = Directory_Separator
1966 and then Path_Buffer (2) /= Directory_Separator
1969 Cur_Dir : constant String := Get_Directory ("");
1970 -- Get the current directory to get the drive letter
1973 if Cur_Dir'Length > 2
1974 and then Cur_Dir (Cur_Dir'First + 1) = ':'
1976 Path_Buffer (3 .. End_Path + 2) :=
1977 Path_Buffer (1 .. End_Path);
1978 Path_Buffer (1 .. 2) :=
1979 Cur_Dir (Cur_Dir'First .. Cur_Dir'First + 1);
1980 End_Path := End_Path + 2;
1984 -- We have a drive letter, ensure it is upper-case
1986 elsif Path_Buffer (1) in 'a' .. 'z'
1987 and then Path_Buffer (2) = ':'
1989 System.Case_Util.To_Upper (Path_Buffer (1 .. 1));
1993 -- On Windows, remove all double-quotes that are possibly part of the
1994 -- path but can cause problems with other methods.
2001 Index := Path_Buffer'First;
2002 for Current in Path_Buffer'First .. End_Path loop
2003 if Path_Buffer (Current) /= '"' then
2004 Path_Buffer (Index) := Path_Buffer (Current);
2009 End_Path := Index - 1;
2013 -- Start the conversions
2015 -- If this is not finished after Max_Iterations, give up and return an
2018 for J in 1 .. Max_Iterations loop
2020 -- If we don't have an absolute pathname, prepend the directory
2024 and then not Is_Absolute_Path (Path_Buffer (1 .. End_Path))
2027 Reference_Dir : constant String := Get_Directory (Directory);
2028 Ref_Dir_Len : constant Natural := Reference_Dir'Length;
2029 -- Current directory name specified and its length
2032 Path_Buffer (Ref_Dir_Len + 1 .. Ref_Dir_Len + End_Path) :=
2033 Path_Buffer (1 .. End_Path);
2034 End_Path := Ref_Dir_Len + End_Path;
2035 Path_Buffer (1 .. Ref_Dir_Len) := Reference_Dir;
2036 Last := Ref_Dir_Len;
2043 -- Ensure that Windows network drives are kept, e.g: \\server\drive-c
2046 and then Directory_Separator = '\'
2047 and then Path_Buffer (1 .. 2) = "\\"
2052 -- If we have traversed the full pathname, return it
2054 if Start > End_Path then
2055 return Final_Value (Path_Buffer (1 .. End_Path));
2058 -- Remove duplicate directory separators
2060 while Path_Buffer (Start) = Directory_Separator loop
2061 if Start = End_Path then
2062 return Final_Value (Path_Buffer (1 .. End_Path - 1));
2065 Path_Buffer (Start .. End_Path - 1) :=
2066 Path_Buffer (Start + 1 .. End_Path);
2067 End_Path := End_Path - 1;
2071 -- Find the end of the current field: last character or the one
2072 -- preceding the next directory separator.
2074 while Finish < End_Path
2075 and then Path_Buffer (Finish + 1) /= Directory_Separator
2077 Finish := Finish + 1;
2082 if Start = Finish and then Path_Buffer (Start) = '.' then
2083 if Start = End_Path then
2085 return (1 => Directory_Separator);
2088 if Fold_To_Lower_Case then
2089 System.Case_Util.To_Lower (Path_Buffer (1 .. Last - 1));
2092 return Path_Buffer (1 .. Last - 1);
2097 Path_Buffer (Last + 1 .. End_Path - 2) :=
2098 Path_Buffer (Last + 3 .. End_Path);
2099 End_Path := End_Path - 2;
2102 -- Remove ".." fields
2104 elsif Finish = Start + 1
2105 and then Path_Buffer (Start .. Finish) = ".."
2110 exit when Start < 1 or else
2111 Path_Buffer (Start) = Directory_Separator;
2115 if Finish = End_Path then
2116 return (1 => Directory_Separator);
2119 Path_Buffer (1 .. End_Path - Finish) :=
2120 Path_Buffer (Finish + 1 .. End_Path);
2121 End_Path := End_Path - Finish;
2126 if Finish = End_Path then
2127 return Final_Value (Path_Buffer (1 .. Start - 1));
2130 Path_Buffer (Start + 1 .. Start + End_Path - Finish - 1) :=
2131 Path_Buffer (Finish + 2 .. End_Path);
2132 End_Path := Start + End_Path - Finish - 1;
2137 -- Check if current field is a symbolic link
2139 elsif Resolve_Links then
2141 Saved : constant Character := Path_Buffer (Finish + 1);
2144 Path_Buffer (Finish + 1) := ASCII.NUL;
2145 Status := Readlink (Path_Buffer'Address,
2146 Link_Buffer'Address,
2147 Link_Buffer'Length);
2148 Path_Buffer (Finish + 1) := Saved;
2151 -- Not a symbolic link, move to the next field, if any
2156 -- Replace symbolic link with its value
2159 if Is_Absolute_Path (Link_Buffer (1 .. Status)) then
2160 Path_Buffer (Status + 1 .. End_Path - (Finish - Status)) :=
2161 Path_Buffer (Finish + 1 .. End_Path);
2162 End_Path := End_Path - (Finish - Status);
2163 Path_Buffer (1 .. Status) := Link_Buffer (1 .. Status);
2168 (Last + Status + 1 .. End_Path - Finish + Last + Status) :=
2169 Path_Buffer (Finish + 1 .. End_Path);
2170 End_Path := End_Path - Finish + Last + Status;
2171 Path_Buffer (Last + 1 .. Last + Status) :=
2172 Link_Buffer (1 .. Status);
2181 -- Too many iterations: give up
2183 -- This can happen when there is a circularity in the symbolic links: A
2184 -- is a symbolic link for B, which itself is a symbolic link, and the
2185 -- target of B or of another symbolic link target of B is A. In this
2186 -- case, we return an empty string to indicate failure to resolve.
2189 end Normalize_Pathname;
2196 (Name : C_File_Name;
2197 Fmode : Mode) return File_Descriptor
2199 function C_Open_Read
2200 (Name : C_File_Name;
2201 Fmode : Mode) return File_Descriptor;
2202 pragma Import (C, C_Open_Read, "__gnat_open_read");
2204 return C_Open_Read (Name, Fmode);
2209 Fmode : Mode) return File_Descriptor
2211 C_Name : String (1 .. Name'Length + 1);
2213 C_Name (1 .. Name'Length) := Name;
2214 C_Name (C_Name'Last) := ASCII.NUL;
2215 return Open_Read (C_Name (C_Name'First)'Address, Fmode);
2218 ---------------------
2219 -- Open_Read_Write --
2220 ---------------------
2222 function Open_Read_Write
2223 (Name : C_File_Name;
2224 Fmode : Mode) return File_Descriptor
2226 function C_Open_Read_Write
2227 (Name : C_File_Name;
2228 Fmode : Mode) return File_Descriptor;
2229 pragma Import (C, C_Open_Read_Write, "__gnat_open_rw");
2231 return C_Open_Read_Write (Name, Fmode);
2232 end Open_Read_Write;
2234 function Open_Read_Write
2236 Fmode : Mode) return File_Descriptor
2238 C_Name : String (1 .. Name'Length + 1);
2240 C_Name (1 .. Name'Length) := Name;
2241 C_Name (C_Name'Last) := ASCII.NUL;
2242 return Open_Read_Write (C_Name (C_Name'First)'Address, Fmode);
2243 end Open_Read_Write;
2249 procedure OS_Exit (Status : Integer) is
2251 OS_Exit_Ptr (Status);
2252 raise Program_Error;
2255 ---------------------
2256 -- OS_Exit_Default --
2257 ---------------------
2259 procedure OS_Exit_Default (Status : Integer) is
2260 procedure GNAT_OS_Exit (Status : Integer);
2261 pragma Import (C, GNAT_OS_Exit, "__gnat_os_exit");
2262 pragma No_Return (GNAT_OS_Exit);
2264 GNAT_OS_Exit (Status);
2265 end OS_Exit_Default;
2267 --------------------
2268 -- Pid_To_Integer --
2269 --------------------
2271 function Pid_To_Integer (Pid : Process_Id) return Integer is
2273 return Integer (Pid);
2281 (FD : File_Descriptor;
2283 N : Integer) return Integer
2286 return Integer (System.CRTL.read
2287 (System.CRTL.int (FD), System.CRTL.chars (A), System.CRTL.int (N)));
2294 procedure Rename_File
2295 (Old_Name : C_File_Name;
2296 New_Name : C_File_Name;
2297 Success : out Boolean)
2299 function rename (From, To : Address) return Integer;
2300 pragma Import (C, rename, "__gnat_rename");
2303 R := rename (Old_Name, New_Name);
2307 procedure Rename_File
2310 Success : out Boolean)
2312 C_Old_Name : String (1 .. Old_Name'Length + 1);
2313 C_New_Name : String (1 .. New_Name'Length + 1);
2315 C_Old_Name (1 .. Old_Name'Length) := Old_Name;
2316 C_Old_Name (C_Old_Name'Last) := ASCII.NUL;
2317 C_New_Name (1 .. New_Name'Length) := New_Name;
2318 C_New_Name (C_New_Name'Last) := ASCII.NUL;
2319 Rename_File (C_Old_Name'Address, C_New_Name'Address, Success);
2322 -----------------------
2323 -- Set_Close_On_Exec --
2324 -----------------------
2326 procedure Set_Close_On_Exec
2327 (FD : File_Descriptor;
2328 Close_On_Exec : Boolean;
2329 Status : out Boolean)
2331 function C_Set_Close_On_Exec
2332 (FD : File_Descriptor; Close_On_Exec : System.CRTL.int)
2333 return System.CRTL.int;
2334 pragma Import (C, C_Set_Close_On_Exec, "__gnat_set_close_on_exec");
2336 Status := C_Set_Close_On_Exec (FD, Boolean'Pos (Close_On_Exec)) = 0;
2337 end Set_Close_On_Exec;
2339 --------------------
2340 -- Set_Executable --
2341 --------------------
2343 procedure Set_Executable (Name : String) is
2344 procedure C_Set_Executable (Name : C_File_Name);
2345 pragma Import (C, C_Set_Executable, "__gnat_set_executable");
2346 C_Name : aliased String (Name'First .. Name'Last + 1);
2348 C_Name (Name'Range) := Name;
2349 C_Name (C_Name'Last) := ASCII.NUL;
2350 C_Set_Executable (C_Name (C_Name'First)'Address);
2353 ----------------------
2354 -- Set_Non_Readable --
2355 ----------------------
2357 procedure Set_Non_Readable (Name : String) is
2358 procedure C_Set_Non_Readable (Name : C_File_Name);
2359 pragma Import (C, C_Set_Non_Readable, "__gnat_set_non_readable");
2360 C_Name : aliased String (Name'First .. Name'Last + 1);
2362 C_Name (Name'Range) := Name;
2363 C_Name (C_Name'Last) := ASCII.NUL;
2364 C_Set_Non_Readable (C_Name (C_Name'First)'Address);
2365 end Set_Non_Readable;
2367 ----------------------
2368 -- Set_Non_Writable --
2369 ----------------------
2371 procedure Set_Non_Writable (Name : String) is
2372 procedure C_Set_Non_Writable (Name : C_File_Name);
2373 pragma Import (C, C_Set_Non_Writable, "__gnat_set_non_writable");
2374 C_Name : aliased String (Name'First .. Name'Last + 1);
2376 C_Name (Name'Range) := Name;
2377 C_Name (C_Name'Last) := ASCII.NUL;
2378 C_Set_Non_Writable (C_Name (C_Name'First)'Address);
2379 end Set_Non_Writable;
2385 procedure Set_Readable (Name : String) is
2386 procedure C_Set_Readable (Name : C_File_Name);
2387 pragma Import (C, C_Set_Readable, "__gnat_set_readable");
2388 C_Name : aliased String (Name'First .. Name'Last + 1);
2390 C_Name (Name'Range) := Name;
2391 C_Name (C_Name'Last) := ASCII.NUL;
2392 C_Set_Readable (C_Name (C_Name'First)'Address);
2395 --------------------
2397 --------------------
2399 procedure Set_Writable (Name : String) is
2400 procedure C_Set_Writable (Name : C_File_Name);
2401 pragma Import (C, C_Set_Writable, "__gnat_set_writable");
2402 C_Name : aliased String (Name'First .. Name'Last + 1);
2404 C_Name (Name'Range) := Name;
2405 C_Name (C_Name'Last) := ASCII.NUL;
2406 C_Set_Writable (C_Name (C_Name'First)'Address);
2413 procedure Setenv (Name : String; Value : String) is
2414 F_Name : String (1 .. Name'Length + 1);
2415 F_Value : String (1 .. Value'Length + 1);
2417 procedure Set_Env_Value (Name, Value : System.Address);
2418 pragma Import (C, Set_Env_Value, "__gnat_setenv");
2421 F_Name (1 .. Name'Length) := Name;
2422 F_Name (F_Name'Last) := ASCII.NUL;
2424 F_Value (1 .. Value'Length) := Value;
2425 F_Value (F_Value'Last) := ASCII.NUL;
2427 Set_Env_Value (F_Name'Address, F_Value'Address);
2435 (Program_Name : String;
2436 Args : Argument_List) return Integer
2440 pragma Warnings (Off, Junk);
2442 Spawn_Internal (Program_Name, Args, Result, Junk, Blocking => True);
2447 (Program_Name : String;
2448 Args : Argument_List;
2449 Success : out Boolean)
2452 Success := (Spawn (Program_Name, Args) = 0);
2456 (Program_Name : String;
2457 Args : Argument_List;
2458 Output_File_Descriptor : File_Descriptor;
2459 Return_Code : out Integer;
2460 Err_To_Out : Boolean := True)
2462 Saved_Output : File_Descriptor;
2463 Saved_Error : File_Descriptor := Invalid_FD; -- prevent compiler warning
2466 -- Set standard output and error to the temporary file
2468 Saved_Output := Dup (Standout);
2469 Dup2 (Output_File_Descriptor, Standout);
2472 Saved_Error := Dup (Standerr);
2473 Dup2 (Output_File_Descriptor, Standerr);
2476 -- Spawn the program
2478 Return_Code := Spawn (Program_Name, Args);
2480 -- Restore the standard output and error
2482 Dup2 (Saved_Output, Standout);
2485 Dup2 (Saved_Error, Standerr);
2488 -- And close the saved standard output and error file descriptors
2490 Close (Saved_Output);
2493 Close (Saved_Error);
2498 (Program_Name : String;
2499 Args : Argument_List;
2500 Output_File : String;
2501 Success : out Boolean;
2502 Return_Code : out Integer;
2503 Err_To_Out : Boolean := True)
2505 FD : File_Descriptor;
2511 FD := Create_Output_Text_File (Output_File);
2513 if FD = Invalid_FD then
2518 Spawn (Program_Name, Args, FD, Return_Code, Err_To_Out);
2520 Close (FD, Success);
2523 --------------------
2524 -- Spawn_Internal --
2525 --------------------
2527 procedure Spawn_Internal
2528 (Program_Name : String;
2529 Args : Argument_List;
2530 Result : out Integer;
2531 Pid : out Process_Id;
2535 procedure Spawn (Args : Argument_List);
2536 -- Call Spawn with given argument list
2538 N_Args : Argument_List (Args'Range);
2539 -- Normalized arguments
2545 procedure Spawn (Args : Argument_List) is
2546 type Chars is array (Positive range <>) of aliased Character;
2547 type Char_Ptr is access constant Character;
2549 Command_Len : constant Positive := Program_Name'Length + 1
2550 + Args_Length (Args);
2551 Command_Last : Natural := 0;
2552 Command : aliased Chars (1 .. Command_Len);
2553 -- Command contains all characters of the Program_Name and Args, all
2554 -- terminated by ASCII.NUL characters.
2556 Arg_List_Len : constant Positive := Args'Length + 2;
2557 Arg_List_Last : Natural := 0;
2558 Arg_List : aliased array (1 .. Arg_List_Len) of Char_Ptr;
2559 -- List with pointers to NUL-terminated strings of the Program_Name
2560 -- and the Args and terminated with a null pointer. We rely on the
2561 -- default initialization for the last null pointer.
2563 procedure Add_To_Command (S : String);
2564 -- Add S and a NUL character to Command, updating Last
2566 function Portable_Spawn (Args : Address) return Integer;
2567 pragma Import (C, Portable_Spawn, "__gnat_portable_spawn");
2569 function Portable_No_Block_Spawn (Args : Address) return Process_Id;
2571 (C, Portable_No_Block_Spawn, "__gnat_portable_no_block_spawn");
2573 --------------------
2574 -- Add_To_Command --
2575 --------------------
2577 procedure Add_To_Command (S : String) is
2578 First : constant Natural := Command_Last + 1;
2581 Command_Last := Command_Last + S'Length;
2583 -- Move characters one at a time, because Command has aliased
2586 -- But not volatile, so why is this necessary ???
2588 for J in S'Range loop
2589 Command (First + J - S'First) := S (J);
2592 Command_Last := Command_Last + 1;
2593 Command (Command_Last) := ASCII.NUL;
2595 Arg_List_Last := Arg_List_Last + 1;
2596 Arg_List (Arg_List_Last) := Command (First)'Access;
2599 -- Start of processing for Spawn
2602 Add_To_Command (Program_Name);
2604 for J in Args'Range loop
2605 Add_To_Command (Args (J).all);
2610 Result := Portable_Spawn (Arg_List'Address);
2612 Pid := Portable_No_Block_Spawn (Arg_List'Address);
2613 Result := Boolean'Pos (Pid /= Invalid_Pid);
2617 -- Start of processing for Spawn_Internal
2620 -- Copy arguments into a local structure
2622 for K in N_Args'Range loop
2623 N_Args (K) := new String'(Args (K).all);
2626 -- Normalize those arguments
2628 Normalize_Arguments (N_Args);
2630 -- Call spawn using the normalized arguments
2634 -- Free arguments list
2636 for K in N_Args'Range loop
2641 ---------------------------
2642 -- To_Path_String_Access --
2643 ---------------------------
2645 function To_Path_String_Access
2646 (Path_Addr : Address;
2647 Path_Len : Integer) return String_Access
2649 subtype Path_String is String (1 .. Path_Len);
2650 type Path_String_Access is access Path_String;
2652 function Address_To_Access is new Ada.Unchecked_Conversion
2653 (Source => Address, Target => Path_String_Access);
2655 Path_Access : constant Path_String_Access :=
2656 Address_To_Access (Path_Addr);
2658 Return_Val : String_Access;
2661 Return_Val := new String (1 .. Path_Len);
2663 for J in 1 .. Path_Len loop
2664 Return_Val (J) := Path_Access (J);
2668 end To_Path_String_Access;
2674 procedure Wait_Process (Pid : out Process_Id; Success : out Boolean) is
2677 function Portable_Wait (S : Address) return Process_Id;
2678 pragma Import (C, Portable_Wait, "__gnat_portable_wait");
2681 Pid := Portable_Wait (Status'Address);
2682 Success := (Status = 0);
2690 (FD : File_Descriptor;
2692 N : Integer) return Integer
2695 return Integer (System.CRTL.write
2696 (System.CRTL.int (FD), System.CRTL.chars (A), System.CRTL.int (N)));