+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- G N A T . O S _ L I B --
--- --
--- B o d y --
--- --
--- $Revision: 1.3 $
--- --
--- Copyright (C) 1995-2001 Ada Core Technologies, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 2, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
--- --
--- As a special exception, if other files instantiate generics from this --
--- unit, or you link this unit with other files to produce an executable, --
--- this unit does not by itself cause the resulting executable to be --
--- covered by the GNU General Public License. This exception does not --
--- however invalidate any other reasons why the executable file might be --
--- covered by the GNU Public License. --
--- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
--- --
-------------------------------------------------------------------------------
-
-with System.Soft_Links;
-with Unchecked_Conversion;
-with System; use System;
-
-package body GNAT.OS_Lib is
-
- package SSL renames System.Soft_Links;
-
- -----------------------
- -- Local Subprograms --
- -----------------------
-
- function Args_Length (Args : Argument_List) return Natural;
- -- Returns total number of characters needed to create a string
- -- of all Args terminated by ASCII.NUL characters
-
- function C_String_Length (S : Address) return Integer;
- -- Returns the length of a C string. Does check for null address
- -- (returns 0).
-
- procedure Spawn_Internal
- (Program_Name : String;
- Args : Argument_List;
- Result : out Integer;
- Pid : out Process_Id;
- Blocking : Boolean);
- -- Internal routine to implement the to Spawn (blocking and non blocking)
- -- routines. If Blocking is set to True then the spawn is blocking
- -- otherwise it is non blocking. In this latter case the Pid contains
- -- the process id number. The first three parameters are as in Spawn.
-
- function To_Path_String_Access
- (Path_Addr : Address;
- Path_Len : Integer)
- return String_Access;
- -- Converts a C String to an Ada String. We could do this making use of
- -- Interfaces.C.Strings but we prefer not to import that entire package
-
- -----------------
- -- Args_Length --
- -----------------
-
- function Args_Length (Args : Argument_List) return Natural is
- Len : Natural := 0;
-
- begin
- for J in Args'Range loop
- Len := Len + Args (J)'Length + 1; -- One extra for ASCII.NUL
- end loop;
-
- return Len;
- end Args_Length;
-
- -----------------------------
- -- Argument_String_To_List --
- -----------------------------
-
- function Argument_String_To_List
- (Arg_String : String)
- return Argument_List_Access
- is
- Max_Args : Integer := Arg_String'Length;
- New_Argv : Argument_List (1 .. Max_Args);
- New_Argc : Natural := 0;
- Idx : Integer;
-
- begin
- Idx := Arg_String'First;
-
- loop
- declare
- Quoted : Boolean := False;
- Backqd : Boolean := False;
- Old_Idx : Integer;
-
- begin
- Old_Idx := Idx;
-
- loop
- -- A vanilla space is the end of an argument
-
- if not Backqd and then not Quoted
- and then Arg_String (Idx) = ' '
- then
- exit;
-
- -- Start of a quoted string
-
- elsif not Backqd and then not Quoted
- and then Arg_String (Idx) = '"'
- then
- Quoted := True;
-
- -- End of a quoted string and end of an argument
-
- elsif not Backqd and then Quoted
- and then Arg_String (Idx) = '"'
- then
- Idx := Idx + 1;
- exit;
-
- -- Following character is backquoted
-
- elsif Arg_String (Idx) = '\' then
- Backqd := True;
-
- -- Turn off backquoting after advancing one character
-
- elsif Backqd then
- Backqd := False;
-
- end if;
-
- Idx := Idx + 1;
- exit when Idx > Arg_String'Last;
- end loop;
-
- -- Found an argument
-
- New_Argc := New_Argc + 1;
- New_Argv (New_Argc) :=
- new String'(Arg_String (Old_Idx .. Idx - 1));
-
- -- Skip extraneous spaces
-
- while Idx <= Arg_String'Last and then Arg_String (Idx) = ' ' loop
- Idx := Idx + 1;
- end loop;
- end;
-
- exit when Idx > Arg_String'Last;
- end loop;
-
- return new Argument_List'(New_Argv (1 .. New_Argc));
- end Argument_String_To_List;
-
- ---------------------
- -- C_String_Length --
- ---------------------
-
- function C_String_Length (S : Address) return Integer is
- function Strlen (S : Address) return Integer;
- pragma Import (C, Strlen, "strlen");
-
- begin
- if S = Null_Address then
- return 0;
- else
- return Strlen (S);
- end if;
- end C_String_Length;
-
- -----------------
- -- Create_File --
- -----------------
-
- function Create_File
- (Name : C_File_Name;
- Fmode : Mode)
- return File_Descriptor
- is
- function C_Create_File
- (Name : C_File_Name;
- Fmode : Mode)
- return File_Descriptor;
- pragma Import (C, C_Create_File, "__gnat_open_create");
-
- begin
- return C_Create_File (Name, Fmode);
- end Create_File;
-
- function Create_File
- (Name : String;
- Fmode : Mode)
- return File_Descriptor
- is
- C_Name : String (1 .. Name'Length + 1);
-
- begin
- C_Name (1 .. Name'Length) := Name;
- C_Name (C_Name'Last) := ASCII.NUL;
- return Create_File (C_Name (C_Name'First)'Address, Fmode);
- end Create_File;
-
- ---------------------
- -- Create_New_File --
- ---------------------
-
- function Create_New_File
- (Name : C_File_Name;
- Fmode : Mode)
- return File_Descriptor
- is
- function C_Create_New_File
- (Name : C_File_Name;
- Fmode : Mode)
- return File_Descriptor;
- pragma Import (C, C_Create_New_File, "__gnat_open_new");
-
- begin
- return C_Create_New_File (Name, Fmode);
- end Create_New_File;
-
- function Create_New_File
- (Name : String;
- Fmode : Mode)
- return File_Descriptor
- is
- C_Name : String (1 .. Name'Length + 1);
-
- begin
- C_Name (1 .. Name'Length) := Name;
- C_Name (C_Name'Last) := ASCII.NUL;
- return Create_New_File (C_Name (C_Name'First)'Address, Fmode);
- end Create_New_File;
-
- ----------------------
- -- Create_Temp_File --
- ----------------------
-
- procedure Create_Temp_File
- (FD : out File_Descriptor;
- Name : out Temp_File_Name)
- is
- function Open_New_Temp
- (Name : System.Address;
- Fmode : Mode)
- return File_Descriptor;
- pragma Import (C, Open_New_Temp, "__gnat_open_new_temp");
-
- begin
- FD := Open_New_Temp (Name'Address, Binary);
- end Create_Temp_File;
-
- -----------------
- -- Delete_File --
- -----------------
-
- procedure Delete_File (Name : Address; Success : out Boolean) is
- R : Integer;
-
- function unlink (A : Address) return Integer;
- pragma Import (C, unlink, "unlink");
-
- begin
- R := unlink (Name);
- Success := (R = 0);
- end Delete_File;
-
- procedure Delete_File (Name : String; Success : out Boolean) is
- C_Name : String (1 .. Name'Length + 1);
-
- begin
- C_Name (1 .. Name'Length) := Name;
- C_Name (C_Name'Last) := ASCII.NUL;
-
- Delete_File (C_Name'Address, Success);
- end Delete_File;
-
- ---------------------
- -- File_Time_Stamp --
- ---------------------
-
- function File_Time_Stamp (FD : File_Descriptor) return OS_Time is
- function File_Time (FD : File_Descriptor) return OS_Time;
- pragma Import (C, File_Time, "__gnat_file_time_fd");
-
- begin
- return File_Time (FD);
- end File_Time_Stamp;
-
- function File_Time_Stamp (Name : C_File_Name) return OS_Time is
- function File_Time (Name : Address) return OS_Time;
- pragma Import (C, File_Time, "__gnat_file_time_name");
-
- begin
- return File_Time (Name);
- end File_Time_Stamp;
-
- function File_Time_Stamp (Name : String) return OS_Time is
- F_Name : String (1 .. Name'Length + 1);
-
- begin
- F_Name (1 .. Name'Length) := Name;
- F_Name (F_Name'Last) := ASCII.NUL;
- return File_Time_Stamp (F_Name'Address);
- end File_Time_Stamp;
-
- ---------------------------
- -- Get_Debuggable_Suffix --
- ---------------------------
-
- function Get_Debuggable_Suffix return String_Access is
- procedure Get_Suffix_Ptr (Length, Ptr : Address);
- pragma Import (C, Get_Suffix_Ptr, "__gnat_get_debuggable_suffix_ptr");
-
- procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
- pragma Import (C, Strncpy, "strncpy");
-
- Suffix_Ptr : Address;
- Suffix_Length : Integer;
- Result : String_Access;
-
- begin
- Get_Suffix_Ptr (Suffix_Length'Address, Suffix_Ptr'Address);
-
- Result := new String (1 .. Suffix_Length);
-
- if Suffix_Length > 0 then
- Strncpy (Result.all'Address, Suffix_Ptr, Suffix_Length);
- end if;
-
- return Result;
- end Get_Debuggable_Suffix;
-
- ---------------------------
- -- Get_Executable_Suffix --
- ---------------------------
-
- function Get_Executable_Suffix return String_Access is
- procedure Get_Suffix_Ptr (Length, Ptr : Address);
- pragma Import (C, Get_Suffix_Ptr, "__gnat_get_executable_suffix_ptr");
-
- procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
- pragma Import (C, Strncpy, "strncpy");
-
- Suffix_Ptr : Address;
- Suffix_Length : Integer;
- Result : String_Access;
-
- begin
- Get_Suffix_Ptr (Suffix_Length'Address, Suffix_Ptr'Address);
-
- Result := new String (1 .. Suffix_Length);
-
- if Suffix_Length > 0 then
- Strncpy (Result.all'Address, Suffix_Ptr, Suffix_Length);
- end if;
-
- return Result;
- end Get_Executable_Suffix;
-
- -----------------------
- -- Get_Object_Suffix --
- -----------------------
-
- function Get_Object_Suffix return String_Access is
- procedure Get_Suffix_Ptr (Length, Ptr : Address);
- pragma Import (C, Get_Suffix_Ptr, "__gnat_get_object_suffix_ptr");
-
- procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
- pragma Import (C, Strncpy, "strncpy");
-
- Suffix_Ptr : Address;
- Suffix_Length : Integer;
- Result : String_Access;
-
- begin
- Get_Suffix_Ptr (Suffix_Length'Address, Suffix_Ptr'Address);
-
- Result := new String (1 .. Suffix_Length);
-
- if Suffix_Length > 0 then
- Strncpy (Result.all'Address, Suffix_Ptr, Suffix_Length);
- end if;
-
- return Result;
- end Get_Object_Suffix;
-
- ------------
- -- Getenv --
- ------------
-
- function Getenv (Name : String) return String_Access is
- procedure Get_Env_Value_Ptr (Name, Length, Ptr : Address);
- pragma Import (C, Get_Env_Value_Ptr, "__gnat_get_env_value_ptr");
-
- procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
- pragma Import (C, Strncpy, "strncpy");
-
- Env_Value_Ptr : Address;
- Env_Value_Length : Integer;
- F_Name : String (1 .. Name'Length + 1);
- Result : String_Access;
-
- begin
- F_Name (1 .. Name'Length) := Name;
- F_Name (F_Name'Last) := ASCII.NUL;
-
- Get_Env_Value_Ptr
- (F_Name'Address, Env_Value_Length'Address, Env_Value_Ptr'Address);
-
- Result := new String (1 .. Env_Value_Length);
-
- if Env_Value_Length > 0 then
- Strncpy (Result.all'Address, Env_Value_Ptr, Env_Value_Length);
- end if;
-
- return Result;
- end Getenv;
-
- ------------
- -- GM_Day --
- ------------
-
- function GM_Day (Date : OS_Time) return Day_Type is
- Y : Year_Type;
- Mo : Month_Type;
- D : Day_Type;
- H : Hour_Type;
- Mn : Minute_Type;
- S : Second_Type;
-
- begin
- GM_Split (Date, Y, Mo, D, H, Mn, S);
- return D;
- end GM_Day;
-
- -------------
- -- GM_Hour --
- -------------
-
- function GM_Hour (Date : OS_Time) return Hour_Type is
- Y : Year_Type;
- Mo : Month_Type;
- D : Day_Type;
- H : Hour_Type;
- Mn : Minute_Type;
- S : Second_Type;
-
- begin
- GM_Split (Date, Y, Mo, D, H, Mn, S);
- return H;
- end GM_Hour;
-
- ---------------
- -- GM_Minute --
- ---------------
-
- function GM_Minute (Date : OS_Time) return Minute_Type is
- Y : Year_Type;
- Mo : Month_Type;
- D : Day_Type;
- H : Hour_Type;
- Mn : Minute_Type;
- S : Second_Type;
-
- begin
- GM_Split (Date, Y, Mo, D, H, Mn, S);
- return Mn;
- end GM_Minute;
-
- --------------
- -- GM_Month --
- --------------
-
- function GM_Month (Date : OS_Time) return Month_Type is
- Y : Year_Type;
- Mo : Month_Type;
- D : Day_Type;
- H : Hour_Type;
- Mn : Minute_Type;
- S : Second_Type;
-
- begin
- GM_Split (Date, Y, Mo, D, H, Mn, S);
- return Mo;
- end GM_Month;
-
- ---------------
- -- GM_Second --
- ---------------
-
- function GM_Second (Date : OS_Time) return Second_Type is
- Y : Year_Type;
- Mo : Month_Type;
- D : Day_Type;
- H : Hour_Type;
- Mn : Minute_Type;
- S : Second_Type;
-
- begin
- GM_Split (Date, Y, Mo, D, H, Mn, S);
- return S;
- end GM_Second;
-
- --------------
- -- GM_Split --
- --------------
-
- procedure GM_Split
- (Date : OS_Time;
- Year : out Year_Type;
- Month : out Month_Type;
- Day : out Day_Type;
- Hour : out Hour_Type;
- Minute : out Minute_Type;
- Second : out Second_Type)
- is
- procedure To_GM_Time
- (P_Time_T, P_Year, P_Month, P_Day, P_Hours, P_Mins, P_Secs : Address);
- pragma Import (C, To_GM_Time, "__gnat_to_gm_time");
-
- T : OS_Time := Date;
- Y : Integer;
- Mo : Integer;
- D : Integer;
- H : Integer;
- Mn : Integer;
- S : Integer;
-
- begin
- -- Use the global lock because To_GM_Time is not thread safe.
-
- Locked_Processing : begin
- SSL.Lock_Task.all;
- To_GM_Time
- (T'Address, Y'Address, Mo'Address, D'Address,
- H'Address, Mn'Address, S'Address);
- SSL.Unlock_Task.all;
-
- exception
- when others =>
- SSL.Unlock_Task.all;
- raise;
- end Locked_Processing;
-
- Year := Y + 1900;
- Month := Mo + 1;
- Day := D;
- Hour := H;
- Minute := Mn;
- Second := S;
- end GM_Split;
-
- -------------
- -- GM_Year --
- -------------
-
- function GM_Year (Date : OS_Time) return Year_Type is
- Y : Year_Type;
- Mo : Month_Type;
- D : Day_Type;
- H : Hour_Type;
- Mn : Minute_Type;
- S : Second_Type;
-
- begin
- GM_Split (Date, Y, Mo, D, H, Mn, S);
- return Y;
- end GM_Year;
-
- ----------------------
- -- Is_Absolute_Path --
- ----------------------
-
- function Is_Absolute_Path (Name : String) return Boolean is
- function Is_Absolute_Path (Name : Address) return Integer;
- pragma Import (C, Is_Absolute_Path, "__gnat_is_absolute_path");
-
- F_Name : String (1 .. Name'Length + 1);
-
- begin
- F_Name (1 .. Name'Length) := Name;
- F_Name (F_Name'Last) := ASCII.NUL;
-
- return Is_Absolute_Path (F_Name'Address) /= 0;
- end Is_Absolute_Path;
-
- ------------------
- -- Is_Directory --
- ------------------
-
- function Is_Directory (Name : C_File_Name) return Boolean is
- function Is_Directory (Name : Address) return Integer;
- pragma Import (C, Is_Directory, "__gnat_is_directory");
-
- begin
- return Is_Directory (Name) /= 0;
- end Is_Directory;
-
- function Is_Directory (Name : String) return Boolean is
- F_Name : String (1 .. Name'Length + 1);
-
- begin
- F_Name (1 .. Name'Length) := Name;
- F_Name (F_Name'Last) := ASCII.NUL;
- return Is_Directory (F_Name'Address);
- end Is_Directory;
-
- ---------------------
- -- Is_Regular_File --
- ---------------------
-
- function Is_Regular_File (Name : C_File_Name) return Boolean is
- function Is_Regular_File (Name : Address) return Integer;
- pragma Import (C, Is_Regular_File, "__gnat_is_regular_file");
-
- begin
- return Is_Regular_File (Name) /= 0;
- end Is_Regular_File;
-
- function Is_Regular_File (Name : String) return Boolean is
- F_Name : String (1 .. Name'Length + 1);
-
- begin
- F_Name (1 .. Name'Length) := Name;
- F_Name (F_Name'Last) := ASCII.NUL;
- return Is_Regular_File (F_Name'Address);
- end Is_Regular_File;
-
- ----------------------
- -- Is_Writable_File --
- ----------------------
-
- function Is_Writable_File (Name : C_File_Name) return Boolean is
- function Is_Writable_File (Name : Address) return Integer;
- pragma Import (C, Is_Writable_File, "__gnat_is_writable_file");
-
- begin
- return Is_Writable_File (Name) /= 0;
- end Is_Writable_File;
-
- function Is_Writable_File (Name : String) return Boolean is
- F_Name : String (1 .. Name'Length + 1);
-
- begin
- F_Name (1 .. Name'Length) := Name;
- F_Name (F_Name'Last) := ASCII.NUL;
- return Is_Writable_File (F_Name'Address);
- end Is_Writable_File;
-
- -------------------------
- -- Locate_Exec_On_Path --
- -------------------------
-
- function Locate_Exec_On_Path
- (Exec_Name : String)
- return String_Access
- is
- function Locate_Exec_On_Path (C_Exec_Name : Address) return Address;
- pragma Import (C, Locate_Exec_On_Path, "__gnat_locate_exec_on_path");
-
- procedure Free (Ptr : System.Address);
- pragma Import (C, Free, "free");
-
- C_Exec_Name : String (1 .. Exec_Name'Length + 1);
- Path_Addr : Address;
- Path_Len : Integer;
- Result : String_Access;
-
- begin
- C_Exec_Name (1 .. Exec_Name'Length) := Exec_Name;
- C_Exec_Name (C_Exec_Name'Last) := ASCII.NUL;
-
- Path_Addr := Locate_Exec_On_Path (C_Exec_Name'Address);
- Path_Len := C_String_Length (Path_Addr);
-
- if Path_Len = 0 then
- return null;
-
- else
- Result := To_Path_String_Access (Path_Addr, Path_Len);
- Free (Path_Addr);
- return Result;
- end if;
- end Locate_Exec_On_Path;
-
- -------------------------
- -- Locate_Regular_File --
- -------------------------
-
- function Locate_Regular_File
- (File_Name : C_File_Name;
- Path : C_File_Name)
- return String_Access
- is
- function Locate_Regular_File
- (C_File_Name, Path_Val : Address) return Address;
- pragma Import (C, Locate_Regular_File, "__gnat_locate_regular_file");
-
- procedure Free (Ptr : System.Address);
- pragma Import (C, Free, "free");
-
- Path_Addr : Address;
- Path_Len : Integer;
- Result : String_Access;
-
- begin
- Path_Addr := Locate_Regular_File (File_Name, Path);
- Path_Len := C_String_Length (Path_Addr);
-
- if Path_Len = 0 then
- return null;
- else
- Result := To_Path_String_Access (Path_Addr, Path_Len);
- Free (Path_Addr);
- return Result;
- end if;
- end Locate_Regular_File;
-
- function Locate_Regular_File
- (File_Name : String;
- Path : String)
- return String_Access
- is
- C_File_Name : String (1 .. File_Name'Length + 1);
- C_Path : String (1 .. Path'Length + 1);
-
- begin
- C_File_Name (1 .. File_Name'Length) := File_Name;
- C_File_Name (C_File_Name'Last) := ASCII.NUL;
-
- C_Path (1 .. Path'Length) := Path;
- C_Path (C_Path'Last) := ASCII.NUL;
-
- return Locate_Regular_File (C_File_Name'Address, C_Path'Address);
- end Locate_Regular_File;
-
- ------------------------
- -- Non_Blocking_Spawn --
- ------------------------
-
- function Non_Blocking_Spawn
- (Program_Name : String;
- Args : Argument_List)
- return Process_Id
- is
- Junk : Integer;
- Pid : Process_Id;
-
- begin
- Spawn_Internal (Program_Name, Args, Junk, Pid, Blocking => False);
- return Pid;
- end Non_Blocking_Spawn;
-
- ------------------------
- -- Normalize_Pathname --
- ------------------------
-
- function Normalize_Pathname
- (Name : String;
- Directory : String := "")
- return String
- is
- Max_Path : Integer;
- pragma Import (C, Max_Path, "max_path_len");
- -- Maximum length of a path name
-
- procedure Get_Current_Dir
- (Dir : System.Address;
- Length : System.Address);
- pragma Import (C, Get_Current_Dir, "__gnat_get_current_dir");
-
- Path_Buffer : String (1 .. Max_Path + Max_Path + 2);
- End_Path : Natural := 0;
- Link_Buffer : String (1 .. Max_Path + 2);
- Status : Integer;
- Last : Positive;
- Start : Natural;
- Finish : Positive;
-
- Max_Iterations : constant := 500;
-
- function Readlink
- (Path : System.Address;
- Buf : System.Address;
- Bufsiz : Integer)
- return Integer;
- pragma Import (C, Readlink, "__gnat_readlink");
-
- function To_Canonical_File_Spec
- (Host_File : System.Address)
- return System.Address;
- pragma Import
- (C, To_Canonical_File_Spec, "__gnat_to_canonical_file_spec");
-
- The_Name : String (1 .. Name'Length + 1);
- Canonical_File_Addr : System.Address;
- Canonical_File_Len : Integer;
-
- Need_To_Check_Drive_Letter : Boolean := False;
- -- Set to true if Name is an absolute path that starts with "//"
-
- function Strlen (S : System.Address) return Integer;
- pragma Import (C, Strlen, "strlen");
-
- function Get_Directory return String;
- -- If Directory is not empty, return it, adding a directory separator
- -- if not already present, otherwise return current working directory
- -- with terminating directory separator.
-
- function Final_Value (S : String) return String;
- -- Make final adjustment to the returned string.
- -- To compensate for non standard path name in Interix,
- -- if S is "/x" or starts with "/x", where x is a capital
- -- letter 'A' to 'Z', add an additional '/' at the beginning
- -- so that the returned value starts with "//x".
-
- -------------------
- -- Get_Directory --
- -------------------
-
- function Get_Directory return String is
- begin
- -- Directory given, add directory separator if needed
-
- if Directory'Length > 0 then
- if Directory (Directory'Length) = Directory_Separator then
- return Directory;
- else
- declare
- Result : String (1 .. Directory'Length + 1);
-
- begin
- Result (1 .. Directory'Length) := Directory;
- Result (Result'Length) := Directory_Separator;
- return Result;
- end;
- end if;
-
- -- Directory name not given, get current directory
-
- else
- declare
- Buffer : String (1 .. Max_Path + 2);
- Path_Len : Natural := Max_Path;
-
- begin
- Get_Current_Dir (Buffer'Address, Path_Len'Address);
-
- if Buffer (Path_Len) /= Directory_Separator then
- Path_Len := Path_Len + 1;
- Buffer (Path_Len) := Directory_Separator;
- end if;
-
- return Buffer (1 .. Path_Len);
- end;
- end if;
- end Get_Directory;
-
- Reference_Dir : constant String := Get_Directory;
- -- Current directory name specified
-
- function Final_Value (S : String) return String is
- begin
- -- Interix has the non standard notion of disk drive
- -- indicated by two '/' followed by a capital letter
- -- 'A' .. 'Z'. One of the two '/' may have been removed
- -- by Normalize_Pathname. It has to be added again.
- -- For other OSes, this should not make no difference.
-
- if Need_To_Check_Drive_Letter
- and then S'Length >= 2
- and then S (S'First) = '/'
- and then S (S'First + 1) in 'A' .. 'Z'
- and then (S'Length = 2 or else S (S'First + 2) = '/')
- then
- declare
- Result : String (1 .. S'Length + 1);
-
- begin
- Result (1) := '/';
- Result (2 .. Result'Last) := S;
- return Result;
- end;
-
- else
- return S;
- end if;
-
- end Final_Value;
-
- -- Start of processing for Normalize_Pathname
-
- begin
- -- Special case, if name is null, then return null
-
- if Name'Length = 0 then
- return "";
- end if;
-
- -- First, convert VMS file spec to Unix file spec.
- -- If Name is not in VMS syntax, then this is equivalent
- -- to put Name at the begining of Path_Buffer.
-
- VMS_Conversion : begin
- The_Name (1 .. Name'Length) := Name;
- The_Name (The_Name'Last) := ASCII.NUL;
-
- Canonical_File_Addr := To_Canonical_File_Spec (The_Name'Address);
- Canonical_File_Len := Strlen (Canonical_File_Addr);
-
- -- If VMS syntax conversion has failed, return an empty string
- -- to indicate the failure.
-
- if Canonical_File_Len = 0 then
- return "";
- end if;
-
- declare
- subtype Path_String is String (1 .. Canonical_File_Len);
- type Path_String_Access is access Path_String;
-
- function Address_To_Access is new
- Unchecked_Conversion (Source => Address,
- Target => Path_String_Access);
-
- Path_Access : Path_String_Access :=
- Address_To_Access (Canonical_File_Addr);
-
- begin
- Path_Buffer (1 .. Canonical_File_Len) := Path_Access.all;
- End_Path := Canonical_File_Len;
- Last := 1;
- end;
- end VMS_Conversion;
-
- -- Replace all '/' by Directory Separators (this is for Windows)
-
- if Directory_Separator /= '/' then
- for Index in 1 .. End_Path loop
- if Path_Buffer (Index) = '/' then
- Path_Buffer (Index) := Directory_Separator;
- end if;
- end loop;
- end if;
-
- -- Start the conversions
-
- -- If this is not finished after Max_Iterations, give up and
- -- return an empty string.
-
- for J in 1 .. Max_Iterations loop
-
- -- If we don't have an absolute pathname, prepend
- -- the directory Reference_Dir.
-
- if Last = 1
- and then not Is_Absolute_Path (Path_Buffer (1 .. End_Path))
- then
- Path_Buffer
- (Reference_Dir'Last + 1 .. Reference_Dir'Length + End_Path) :=
- Path_Buffer (1 .. End_Path);
- End_Path := Reference_Dir'Length + End_Path;
- Path_Buffer (1 .. Reference_Dir'Length) := Reference_Dir;
- Last := Reference_Dir'Length;
- end if;
-
- -- If name starts with "//", we may have a drive letter on Interix
-
- if Last = 1 and then End_Path >= 3 then
- Need_To_Check_Drive_Letter := (Path_Buffer (1 .. 2)) = "//";
- end if;
-
- Start := Last + 1;
- Finish := Last;
-
- -- If we have traversed the full pathname, return it
-
- if Start > End_Path then
- return Final_Value (Path_Buffer (1 .. End_Path));
- end if;
-
- -- Remove duplicate directory separators
-
- while Path_Buffer (Start) = Directory_Separator loop
- if Start = End_Path then
- return Final_Value (Path_Buffer (1 .. End_Path - 1));
-
- else
- Path_Buffer (Start .. End_Path - 1) :=
- Path_Buffer (Start + 1 .. End_Path);
- End_Path := End_Path - 1;
- end if;
- end loop;
-
- -- Find the end of the current field: last character
- -- or the one preceding the next directory separator.
-
- while Finish < End_Path
- and then Path_Buffer (Finish + 1) /= Directory_Separator
- loop
- Finish := Finish + 1;
- end loop;
-
- -- Remove "." field
-
- if Start = Finish and then Path_Buffer (Start) = '.' then
- if Start = End_Path then
- if Last = 1 then
- return (1 => Directory_Separator);
- else
- return Path_Buffer (1 .. Last - 1);
- end if;
-
- else
- Path_Buffer (Last + 1 .. End_Path - 2) :=
- Path_Buffer (Last + 3 .. End_Path);
- End_Path := End_Path - 2;
- end if;
-
- -- Remove ".." fields
-
- elsif Finish = Start + 1
- and then Path_Buffer (Start .. Finish) = ".."
- then
- Start := Last;
- loop
- Start := Start - 1;
- exit when Start < 1 or else
- Path_Buffer (Start) = Directory_Separator;
- end loop;
-
- if Start <= 1 then
- if Finish = End_Path then
- return (1 => Directory_Separator);
-
- else
- Path_Buffer (1 .. End_Path - Finish) :=
- Path_Buffer (Finish + 1 .. End_Path);
- End_Path := End_Path - Finish;
- Last := 1;
- end if;
-
- else
- if Finish = End_Path then
- return Final_Value (Path_Buffer (1 .. Start - 1));
-
- else
- Path_Buffer (Start + 1 .. Start + End_Path - Finish - 1) :=
- Path_Buffer (Finish + 2 .. End_Path);
- End_Path := Start + End_Path - Finish - 1;
- Last := Start;
- end if;
- end if;
-
- -- Check if current field is a symbolic link
-
- else
- declare
- Saved : Character := Path_Buffer (Finish + 1);
-
- begin
- Path_Buffer (Finish + 1) := ASCII.NUL;
- Status := Readlink (Path_Buffer'Address,
- Link_Buffer'Address,
- Link_Buffer'Length);
- Path_Buffer (Finish + 1) := Saved;
- end;
-
- -- Not a symbolic link, move to the next field, if any
-
- if Status <= 0 then
- Last := Finish + 1;
-
- -- Replace symbolic link with its value.
-
- else
- if Is_Absolute_Path (Link_Buffer (1 .. Status)) then
- Path_Buffer (Status + 1 .. End_Path - (Finish - Status)) :=
- Path_Buffer (Finish + 1 .. End_Path);
- End_Path := End_Path - (Finish - Status);
- Path_Buffer (1 .. Status) := Link_Buffer (1 .. Status);
- Last := 1;
-
- else
- Path_Buffer
- (Last + Status + 1 .. End_Path - Finish + Last + Status) :=
- Path_Buffer (Finish + 1 .. End_Path);
- End_Path := End_Path - Finish + Last + Status;
- Path_Buffer (Last + 1 .. Last + Status) :=
- Link_Buffer (1 .. Status);
- end if;
- end if;
- end if;
- end loop;
-
- -- Too many iterations: give up
-
- -- This can happen when there is a circularity in the symbolic links:
- -- A is a symbolic link for B, which itself is a symbolic link, and
- -- the target of B or of another symbolic link target of B is A.
- -- In this case, we return an empty string to indicate failure to
- -- resolve.
-
- return "";
- end Normalize_Pathname;
-
- ---------------
- -- Open_Read --
- ---------------
-
- function Open_Read
- (Name : C_File_Name;
- Fmode : Mode)
- return File_Descriptor
- is
- function C_Open_Read
- (Name : C_File_Name;
- Fmode : Mode)
- return File_Descriptor;
- pragma Import (C, C_Open_Read, "__gnat_open_read");
-
- begin
- return C_Open_Read (Name, Fmode);
- end Open_Read;
-
- function Open_Read
- (Name : String;
- Fmode : Mode)
- return File_Descriptor
- is
- C_Name : String (1 .. Name'Length + 1);
-
- begin
- C_Name (1 .. Name'Length) := Name;
- C_Name (C_Name'Last) := ASCII.NUL;
- return Open_Read (C_Name (C_Name'First)'Address, Fmode);
- end Open_Read;
-
- ---------------------
- -- Open_Read_Write --
- ---------------------
-
- function Open_Read_Write
- (Name : C_File_Name;
- Fmode : Mode)
- return File_Descriptor
- is
- function C_Open_Read_Write
- (Name : C_File_Name;
- Fmode : Mode)
- return File_Descriptor;
- pragma Import (C, C_Open_Read_Write, "__gnat_open_rw");
-
- begin
- return C_Open_Read_Write (Name, Fmode);
- end Open_Read_Write;
-
- function Open_Read_Write
- (Name : String;
- Fmode : Mode)
- return File_Descriptor
- is
- C_Name : String (1 .. Name'Length + 1);
-
- begin
- C_Name (1 .. Name'Length) := Name;
- C_Name (C_Name'Last) := ASCII.NUL;
- return Open_Read_Write (C_Name (C_Name'First)'Address, Fmode);
- end Open_Read_Write;
-
- -----------------
- -- Rename_File --
- -----------------
-
- procedure Rename_File
- (Old_Name : C_File_Name;
- New_Name : C_File_Name;
- Success : out Boolean)
- is
- function rename (From, To : Address) return Integer;
- pragma Import (C, rename, "rename");
-
- R : Integer;
-
- begin
- R := rename (Old_Name, New_Name);
- Success := (R = 0);
- end Rename_File;
-
- procedure Rename_File
- (Old_Name : String;
- New_Name : String;
- Success : out Boolean)
- is
- C_Old_Name : String (1 .. Old_Name'Length + 1);
- C_New_Name : String (1 .. New_Name'Length + 1);
-
- begin
- C_Old_Name (1 .. Old_Name'Length) := Old_Name;
- C_Old_Name (C_Old_Name'Last) := ASCII.NUL;
-
- C_New_Name (1 .. New_Name'Length) := New_Name;
- C_New_Name (C_New_Name'Last) := ASCII.NUL;
-
- Rename_File (C_Old_Name'Address, C_New_Name'Address, Success);
- end Rename_File;
-
- ------------
- -- Setenv --
- ------------
-
- procedure Setenv (Name : String; Value : String) is
- F_Name : String (1 .. Name'Length + 1);
- F_Value : String (1 .. Value'Length + 1);
-
- procedure Set_Env_Value (Name, Value : System.Address);
- pragma Import (C, Set_Env_Value, "__gnat_set_env_value");
-
- begin
- F_Name (1 .. Name'Length) := Name;
- F_Name (F_Name'Last) := ASCII.NUL;
-
- F_Value (1 .. Value'Length) := Value;
- F_Value (F_Value'Last) := ASCII.NUL;
-
- Set_Env_Value (F_Name'Address, F_Value'Address);
- end Setenv;
-
- -----------
- -- Spawn --
- -----------
-
- function Spawn
- (Program_Name : String;
- Args : Argument_List)
- return Integer
- is
- Junk : Process_Id;
- Result : Integer;
-
- begin
- Spawn_Internal (Program_Name, Args, Result, Junk, Blocking => True);
- return Result;
- end Spawn;
-
- procedure Spawn
- (Program_Name : String;
- Args : Argument_List;
- Success : out Boolean)
- is
- begin
- Success := (Spawn (Program_Name, Args) = 0);
- end Spawn;
-
- --------------------
- -- Spawn_Internal --
- --------------------
-
- procedure Spawn_Internal
- (Program_Name : String;
- Args : Argument_List;
- Result : out Integer;
- Pid : out Process_Id;
- Blocking : Boolean)
- is
- type Chars is array (Positive range <>) of aliased Character;
- type Char_Ptr is access constant Character;
-
- Command_Len : constant Positive := Program_Name'Length + 1
- + Args_Length (Args);
- Command_Last : Natural := 0;
- Command : aliased Chars (1 .. Command_Len);
- -- Command contains all characters of the Program_Name and Args,
- -- all terminated by ASCII.NUL characters
-
- Arg_List_Len : constant Positive := Args'Length + 2;
- Arg_List_Last : Natural := 0;
- Arg_List : aliased array (1 .. Arg_List_Len) of Char_Ptr;
- -- List with pointers to NUL-terminated strings of the
- -- Program_Name and the Args and terminated with a null pointer.
- -- We rely on the default initialization for the last null pointer.
-
- procedure Add_To_Command (S : String);
- -- Add S and a NUL character to Command, updating Last
-
- function Portable_Spawn (Args : Address) return Integer;
- pragma Import (C, Portable_Spawn, "__gnat_portable_spawn");
-
- function Portable_No_Block_Spawn (Args : Address) return Process_Id;
- pragma Import
- (C, Portable_No_Block_Spawn, "__gnat_portable_no_block_spawn");
-
- --------------------
- -- Add_To_Command --
- --------------------
-
- procedure Add_To_Command (S : String) is
- First : constant Natural := Command_Last + 1;
-
- begin
- Command_Last := Command_Last + S'Length;
-
- -- Move characters one at a time, because Command has
- -- aliased components.
-
- for J in S'Range loop
- Command (First + J - S'First) := S (J);
- end loop;
-
- Command_Last := Command_Last + 1;
- Command (Command_Last) := ASCII.NUL;
-
- Arg_List_Last := Arg_List_Last + 1;
- Arg_List (Arg_List_Last) := Command (First)'Access;
- end Add_To_Command;
-
- -- Start of processing for Spawn_Internal
-
- begin
- Add_To_Command (Program_Name);
-
- for J in Args'Range loop
- Add_To_Command (Args (J).all);
- end loop;
-
- if Blocking then
- Pid := Invalid_Pid;
- Result := Portable_Spawn (Arg_List'Address);
- else
- Pid := Portable_No_Block_Spawn (Arg_List'Address);
- Result := Boolean'Pos (Pid /= Invalid_Pid);
- end if;
-
- end Spawn_Internal;
-
- ---------------------------
- -- To_Path_String_Access --
- ---------------------------
-
- function To_Path_String_Access
- (Path_Addr : Address;
- Path_Len : Integer)
- return String_Access
- is
- subtype Path_String is String (1 .. Path_Len);
- type Path_String_Access is access Path_String;
-
- function Address_To_Access is new
- Unchecked_Conversion (Source => Address,
- Target => Path_String_Access);
-
- Path_Access : Path_String_Access := Address_To_Access (Path_Addr);
-
- Return_Val : String_Access;
-
- begin
- Return_Val := new String (1 .. Path_Len);
-
- for J in 1 .. Path_Len loop
- Return_Val (J) := Path_Access (J);
- end loop;
-
- return Return_Val;
- end To_Path_String_Access;
-
- ------------------
- -- Wait_Process --
- ------------------
-
- procedure Wait_Process (Pid : out Process_Id; Success : out Boolean) is
- Status : Integer;
-
- function Portable_Wait (S : Address) return Process_Id;
- pragma Import (C, Portable_Wait, "__gnat_portable_wait");
-
- begin
- Pid := Portable_Wait (Status'Address);
- Success := (Status = 0);
- end Wait_Process;
-
-end GNAT.OS_Lib;
projects / msp430-gcc.git / blobdiff