-- --
-- B o d y --
-- --
--- Copyright (C) 1995-2006, AdaCore --
+-- Copyright (C) 1995-2007, AdaCore --
-- --
-- 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- --
-- --
------------------------------------------------------------------------------
-with System.Case_Util;
-with System.CRTL;
-with System.Soft_Links;
-with Unchecked_Conversion;
-with Unchecked_Deallocation;
-with System; use System;
+-- This package does not require a body, since it is a package renaming. We
+-- provide a dummy file containing a No_Body pragma so that previous versions
+-- of the body (which did exist) will not intefere.
-package body GNAT.OS_Lib is
-
- -- Imported procedures Dup and Dup2 are used in procedures Spawn and
- -- Non_Blocking_Spawn.
-
- function Dup (Fd : File_Descriptor) return File_Descriptor;
- pragma Import (C, Dup, "__gnat_dup");
-
- procedure Dup2 (Old_Fd, New_Fd : File_Descriptor);
- pragma Import (C, Dup2, "__gnat_dup2");
-
- On_Windows : constant Boolean := Directory_Separator = '\';
- -- An indication that we are on Windows. Used in Normalize_Pathname, to
- -- deal with drive letters in the beginning of absolute paths.
-
- package SSL renames System.Soft_Links;
-
- -- The following are used by Create_Temp_File
-
- First_Temp_File_Name : constant String := "GNAT-TEMP-000000.TMP";
- -- Used to initialize Current_Temp_File_Name and Temp_File_Name_Last_Digit
-
- Current_Temp_File_Name : String := First_Temp_File_Name;
- -- Name of the temp file last created
-
- Temp_File_Name_Last_Digit : constant Positive :=
- First_Temp_File_Name'Last - 4;
- -- Position of the last digit in Current_Temp_File_Name
-
- Max_Attempts : constant := 100;
- -- The maximum number of attempts to create a new temp file
-
- -----------------------
- -- 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 two Spawn (blocking/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. Note that
- -- Spawn_Internal normalizes the argument list before calling the low level
- -- system spawn routines (see Normalize_Arguments).
- --
- -- Note: Normalize_Arguments is designed to do nothing if it is called more
- -- than once, so calling Normalize_Arguments before calling one of the
- -- spawn routines is fine.
-
- 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
-
- ---------
- -- "<" --
- ---------
-
- function "<" (X, Y : OS_Time) return Boolean is
- begin
- return Long_Integer (X) < Long_Integer (Y);
- end "<";
-
- ----------
- -- "<=" --
- ----------
-
- function "<=" (X, Y : OS_Time) return Boolean is
- begin
- return Long_Integer (X) <= Long_Integer (Y);
- end "<=";
-
- ---------
- -- ">" --
- ---------
-
- function ">" (X, Y : OS_Time) return Boolean is
- begin
- return Long_Integer (X) > Long_Integer (Y);
- end ">";
-
- ----------
- -- ">=" --
- ----------
-
- function ">=" (X, Y : OS_Time) return Boolean is
- begin
- return Long_Integer (X) >= Long_Integer (Y);
- end ">=";
-
- -----------------
- -- 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 : constant Integer := Arg_String'Length;
- New_Argv : Argument_List (1 .. Max_Args);
- New_Argc : Natural := 0;
- Idx : Integer;
-
- begin
- Idx := Arg_String'First;
-
- loop
- exit when Idx > Arg_String'Last;
-
- declare
- Quoted : Boolean := False;
- Backqd : Boolean := False;
- Old_Idx : Integer;
-
- begin
- Old_Idx := Idx;
-
- loop
- -- An unquoted space is the end of an argument
-
- if not (Backqd or Quoted)
- and then Arg_String (Idx) = ' '
- then
- exit;
-
- -- Start of a quoted string
-
- elsif not (Backqd or Quoted)
- and then Arg_String (Idx) = '"'
- then
- Quoted := True;
-
- -- End of a quoted string and end of an argument
-
- elsif (Quoted and not Backqd)
- 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;
- 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;
-
- -----------
- -- Close --
- -----------
-
- procedure Close (FD : File_Descriptor) is
- procedure C_Close (FD : File_Descriptor);
- pragma Import (C, C_Close, "close");
- begin
- C_Close (FD);
- end Close;
-
- procedure Close (FD : File_Descriptor; Status : out Boolean) is
- function C_Close (FD : File_Descriptor) return Integer;
- pragma Import (C, C_Close, "close");
- begin
- Status := (C_Close (FD) = 0);
- end Close;
-
- ---------------
- -- Copy_File --
- ---------------
-
- procedure Copy_File
- (Name : String;
- Pathname : String;
- Success : out Boolean;
- Mode : Copy_Mode := Copy;
- Preserve : Attribute := Time_Stamps)
- is
- From : File_Descriptor;
- To : File_Descriptor;
-
- Copy_Error : exception;
- -- Internal exception raised to signal error in copy
-
- function Build_Path (Dir : String; File : String) return String;
- -- Returns pathname Dir catenated with File adding the directory
- -- separator only if needed.
-
- procedure Copy (From, To : File_Descriptor);
- -- Read data from From and place them into To. In both cases the
- -- operations uses the current file position. Raises Constraint_Error
- -- if a problem occurs during the copy.
-
- procedure Copy_To (To_Name : String);
- -- Does a straight copy from source to designated destination file
-
- ----------------
- -- Build_Path --
- ----------------
-
- function Build_Path (Dir : String; File : String) return String is
- Res : String (1 .. Dir'Length + File'Length + 1);
-
- Base_File_Ptr : Integer;
- -- The base file name is File (Base_File_Ptr + 1 .. File'Last)
-
- function Is_Dirsep (C : Character) return Boolean;
- pragma Inline (Is_Dirsep);
- -- Returns True if C is a directory separator. On Windows we
- -- handle both styles of directory separator.
-
- ---------------
- -- Is_Dirsep --
- ---------------
-
- function Is_Dirsep (C : Character) return Boolean is
- begin
- return C = Directory_Separator or else C = '/';
- end Is_Dirsep;
-
- -- Start of processing for Build_Path
-
- begin
- -- Find base file name
-
- Base_File_Ptr := File'Last;
- while Base_File_Ptr >= File'First loop
- exit when Is_Dirsep (File (Base_File_Ptr));
- Base_File_Ptr := Base_File_Ptr - 1;
- end loop;
-
- declare
- Base_File : String renames
- File (Base_File_Ptr + 1 .. File'Last);
-
- begin
- Res (1 .. Dir'Length) := Dir;
-
- if Is_Dirsep (Dir (Dir'Last)) then
- Res (Dir'Length + 1 .. Dir'Length + Base_File'Length) :=
- Base_File;
- return Res (1 .. Dir'Length + Base_File'Length);
-
- else
- Res (Dir'Length + 1) := Directory_Separator;
- Res (Dir'Length + 2 .. Dir'Length + 1 + Base_File'Length) :=
- Base_File;
- return Res (1 .. Dir'Length + 1 + Base_File'Length);
- end if;
- end;
- end Build_Path;
-
- ----------
- -- Copy --
- ----------
-
- procedure Copy (From, To : File_Descriptor) is
- Buf_Size : constant := 200_000;
- type Buf is array (1 .. Buf_Size) of Character;
- type Buf_Ptr is access Buf;
-
- Buffer : Buf_Ptr;
- R : Integer;
- W : Integer;
-
- Status_From : Boolean;
- Status_To : Boolean;
- -- Statuses for the calls to Close
-
- procedure Free is new Unchecked_Deallocation (Buf, Buf_Ptr);
-
- begin
- -- Check for invalid descriptors, making sure that we do not
- -- accidentally leave an open file descriptor around.
-
- if From = Invalid_FD then
- if To /= Invalid_FD then
- Close (To, Status_To);
- end if;
-
- raise Copy_Error;
-
- elsif To = Invalid_FD then
- Close (From, Status_From);
- raise Copy_Error;
- end if;
-
- -- Allocate the buffer on the heap
-
- Buffer := new Buf;
-
- loop
- R := Read (From, Buffer (1)'Address, Buf_Size);
-
- -- For VMS, the buffer may not be full. So, we need to try again
- -- until there is nothing to read.
-
- exit when R = 0;
-
- W := Write (To, Buffer (1)'Address, R);
-
- if W < R then
-
- -- Problem writing data, could be a disk full. Close files
- -- without worrying about status, since we are raising a
- -- Copy_Error exception in any case.
-
- Close (From, Status_From);
- Close (To, Status_To);
-
- Free (Buffer);
-
- raise Copy_Error;
- end if;
- end loop;
-
- Close (From, Status_From);
- Close (To, Status_To);
-
- Free (Buffer);
-
- if not (Status_From and Status_To) then
- raise Copy_Error;
- end if;
- end Copy;
-
- -------------
- -- Copy_To --
- -------------
-
- procedure Copy_To (To_Name : String) is
-
- function Copy_Attributes
- (From, To : System.Address;
- Mode : Integer) return Integer;
- pragma Import (C, Copy_Attributes, "__gnat_copy_attribs");
- -- Mode = 0 - copy only time stamps.
- -- Mode = 1 - copy time stamps and read/write/execute attributes
-
- C_From : String (1 .. Name'Length + 1);
- C_To : String (1 .. To_Name'Length + 1);
-
- begin
- From := Open_Read (Name, Binary);
- To := Create_File (To_Name, Binary);
- Copy (From, To);
-
- -- Copy attributes
-
- C_From (1 .. Name'Length) := Name;
- C_From (C_From'Last) := ASCII.Nul;
-
- C_To (1 .. To_Name'Length) := To_Name;
- C_To (C_To'Last) := ASCII.Nul;
-
- case Preserve is
-
- when Time_Stamps =>
- if Copy_Attributes (C_From'Address, C_To'Address, 0) = -1 then
- raise Copy_Error;
- end if;
-
- when Full =>
- if Copy_Attributes (C_From'Address, C_To'Address, 1) = -1 then
- raise Copy_Error;
- end if;
-
- when None =>
- null;
- end case;
-
- end Copy_To;
-
- -- Start of processing for Copy_File
-
- begin
- Success := True;
-
- -- The source file must exist
-
- if not Is_Regular_File (Name) then
- raise Copy_Error;
- end if;
-
- -- The source file exists
-
- case Mode is
-
- -- Copy case, target file must not exist
-
- when Copy =>
-
- -- If the target file exists, we have an error
-
- if Is_Regular_File (Pathname) then
- raise Copy_Error;
-
- -- Case of target is a directory
-
- elsif Is_Directory (Pathname) then
- declare
- Dest : constant String := Build_Path (Pathname, Name);
-
- begin
- -- If target file exists, we have an error, else do copy
-
- if Is_Regular_File (Dest) then
- raise Copy_Error;
- else
- Copy_To (Dest);
- end if;
- end;
-
- -- Case of normal copy to file (destination does not exist)
-
- else
- Copy_To (Pathname);
- end if;
-
- -- Overwrite case (destination file may or may not exist)
-
- when Overwrite =>
- if Is_Directory (Pathname) then
- Copy_To (Build_Path (Pathname, Name));
- else
- Copy_To (Pathname);
- end if;
-
- -- Append case (destination file may or may not exist)
-
- when Append =>
-
- -- Appending to existing file
-
- if Is_Regular_File (Pathname) then
-
- -- Append mode and destination file exists, append data at the
- -- end of Pathname.
-
- From := Open_Read (Name, Binary);
- To := Open_Read_Write (Pathname, Binary);
- Lseek (To, 0, Seek_End);
-
- Copy (From, To);
-
- -- Appending to directory, not allowed
-
- elsif Is_Directory (Pathname) then
- raise Copy_Error;
-
- -- Appending when target file does not exist
-
- else
- Copy_To (Pathname);
- end if;
- end case;
-
- -- All error cases are caught here
-
- exception
- when Copy_Error =>
- Success := False;
- end Copy_File;
-
- procedure Copy_File
- (Name : C_File_Name;
- Pathname : C_File_Name;
- Success : out Boolean;
- Mode : Copy_Mode := Copy;
- Preserve : Attribute := Time_Stamps)
- is
- Ada_Name : String_Access :=
- To_Path_String_Access
- (Name, C_String_Length (Name));
-
- Ada_Pathname : String_Access :=
- To_Path_String_Access
- (Pathname, C_String_Length (Pathname));
-
- begin
- Copy_File (Ada_Name.all, Ada_Pathname.all, Success, Mode, Preserve);
- Free (Ada_Name);
- Free (Ada_Pathname);
- end Copy_File;
-
- ----------------------
- -- Copy_Time_Stamps --
- ----------------------
-
- procedure Copy_Time_Stamps (Source, Dest : String; Success : out Boolean) is
-
- function Copy_Attributes
- (From, To : System.Address;
- Mode : Integer) return Integer;
- pragma Import (C, Copy_Attributes, "__gnat_copy_attribs");
- -- Mode = 0 - copy only time stamps.
- -- Mode = 1 - copy time stamps and read/write/execute attributes
-
- begin
- if Is_Regular_File (Source) and then Is_Writable_File (Dest) then
- declare
- C_Source : String (1 .. Source'Length + 1);
- C_Dest : String (1 .. Dest'Length + 1);
- begin
- C_Source (1 .. Source'Length) := Source;
- C_Source (C_Source'Last) := ASCII.NUL;
-
- C_Dest (1 .. Dest'Length) := Dest;
- C_Dest (C_Dest'Last) := ASCII.NUL;
-
- if Copy_Attributes (C_Source'Address, C_Dest'Address, 0) = -1 then
- Success := False;
- else
- Success := True;
- end if;
- end;
-
- else
- Success := False;
- end if;
- end Copy_Time_Stamps;
-
- procedure Copy_Time_Stamps
- (Source, Dest : C_File_Name;
- Success : out Boolean)
- is
- Ada_Source : String_Access :=
- To_Path_String_Access
- (Source, C_String_Length (Source));
-
- Ada_Dest : String_Access :=
- To_Path_String_Access
- (Dest, C_String_Length (Dest));
- begin
- Copy_Time_Stamps (Ada_Source.all, Ada_Dest.all, Success);
- Free (Ada_Source);
- Free (Ada_Dest);
- end Copy_Time_Stamps;
-
- -----------------
- -- 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_Output_Text_File --
- -----------------------------
-
- function Create_Output_Text_File (Name : String) return File_Descriptor is
- function C_Create_File
- (Name : C_File_Name) return File_Descriptor;
- pragma Import (C, C_Create_File, "__gnat_create_output_file");
-
- C_Name : String (1 .. Name'Length + 1);
-
- begin
- C_Name (1 .. Name'Length) := Name;
- C_Name (C_Name'Last) := ASCII.NUL;
- return C_Create_File (C_Name (C_Name'First)'Address);
- end Create_Output_Text_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;
-
- procedure Create_Temp_File
- (FD : out File_Descriptor;
- Name : out String_Access)
- is
- Pos : Positive;
- Attempts : Natural := 0;
- Current : String (Current_Temp_File_Name'Range);
-
- begin
- -- Loop until a new temp file can be created
-
- File_Loop : loop
- Locked : begin
- -- We need to protect global variable Current_Temp_File_Name
- -- against concurrent access by different tasks.
-
- SSL.Lock_Task.all;
-
- -- Start at the last digit
-
- Pos := Temp_File_Name_Last_Digit;
-
- Digit_Loop :
- loop
- -- Increment the digit by one
-
- case Current_Temp_File_Name (Pos) is
- when '0' .. '8' =>
- Current_Temp_File_Name (Pos) :=
- Character'Succ (Current_Temp_File_Name (Pos));
- exit Digit_Loop;
-
- when '9' =>
-
- -- For 9, set the digit to 0 and go to the previous digit
-
- Current_Temp_File_Name (Pos) := '0';
- Pos := Pos - 1;
-
- when others =>
-
- -- If it is not a digit, then there are no available
- -- temp file names. Return Invalid_FD. There is almost
- -- no that this code will be ever be executed, since
- -- it would mean that there are one million temp files
- -- in the same directory!
-
- SSL.Unlock_Task.all;
- FD := Invalid_FD;
- Name := null;
- exit File_Loop;
- end case;
- end loop Digit_Loop;
-
- Current := Current_Temp_File_Name;
-
- -- We can now release the lock, because we are no longer
- -- accessing Current_Temp_File_Name.
-
- SSL.Unlock_Task.all;
-
- exception
- when others =>
- SSL.Unlock_Task.all;
- raise;
- end Locked;
-
- -- Attempt to create the file
-
- FD := Create_New_File (Current, Binary);
-
- if FD /= Invalid_FD then
- Name := new String'(Current);
- exit File_Loop;
- end if;
-
- if not Is_Regular_File (Current) then
-
- -- If the file does not already exist and we are unable to create
- -- it, we give up after Max_Attempts. Otherwise, we try again with
- -- the next available file name.
-
- Attempts := Attempts + 1;
-
- if Attempts >= Max_Attempts then
- FD := Invalid_FD;
- Name := null;
- exit File_Loop;
- end if;
- end if;
- end loop File_Loop;
- 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;
-
- ----------------------------------
- -- Get_Target_Debuggable_Suffix --
- ----------------------------------
-
- function Get_Target_Debuggable_Suffix return String_Access is
- Target_Exec_Ext_Ptr : Address;
- pragma Import
- (C, Target_Exec_Ext_Ptr, "__gnat_target_debuggable_extension");
-
- procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
- pragma Import (C, Strncpy, "strncpy");
-
- function Strlen (Cstring : Address) return Integer;
- pragma Import (C, Strlen, "strlen");
-
- Suffix_Length : Integer;
- Result : String_Access;
-
- begin
- Suffix_Length := Strlen (Target_Exec_Ext_Ptr);
-
- Result := new String (1 .. Suffix_Length);
-
- if Suffix_Length > 0 then
- Strncpy (Result.all'Address, Target_Exec_Ext_Ptr, Suffix_Length);
- end if;
-
- return Result;
- end Get_Target_Debuggable_Suffix;
-
- ----------------------------------
- -- Get_Target_Executable_Suffix --
- ----------------------------------
-
- function Get_Target_Executable_Suffix return String_Access is
- Target_Exec_Ext_Ptr : Address;
- pragma Import
- (C, Target_Exec_Ext_Ptr, "__gnat_target_executable_extension");
-
- procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
- pragma Import (C, Strncpy, "strncpy");
-
- function Strlen (Cstring : Address) return Integer;
- pragma Import (C, Strlen, "strlen");
-
- Suffix_Length : Integer;
- Result : String_Access;
-
- begin
- Suffix_Length := Strlen (Target_Exec_Ext_Ptr);
-
- Result := new String (1 .. Suffix_Length);
-
- if Suffix_Length > 0 then
- Strncpy (Result.all'Address, Target_Exec_Ext_Ptr, Suffix_Length);
- end if;
-
- return Result;
- end Get_Target_Executable_Suffix;
-
- ------------------------------
- -- Get_Target_Object_Suffix --
- ------------------------------
-
- function Get_Target_Object_Suffix return String_Access is
- Target_Object_Ext_Ptr : Address;
- pragma Import
- (C, Target_Object_Ext_Ptr, "__gnat_target_object_extension");
-
- procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
- pragma Import (C, Strncpy, "strncpy");
-
- function Strlen (Cstring : Address) return Integer;
- pragma Import (C, Strlen, "strlen");
-
- Suffix_Length : Integer;
- Result : String_Access;
-
- begin
- Suffix_Length := Strlen (Target_Object_Ext_Ptr);
-
- Result := new String (1 .. Suffix_Length);
-
- if Suffix_Length > 0 then
- Strncpy (Result.all'Address, Target_Object_Ext_Ptr, Suffix_Length);
- end if;
-
- return Result;
- end Get_Target_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_getenv");
-
- procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
- pragma Import (C, Strncpy, "strncpy");
-
- Env_Value_Ptr : aliased Address;
- Env_Value_Length : aliased Integer;
- F_Name : aliased 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;
- Length : Integer) return Integer;
- pragma Import (C, Is_Absolute_Path, "__gnat_is_absolute_path");
- begin
- return Is_Absolute_Path (Name'Address, Name'Length) /= 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_Readable_File --
- ----------------------
-
- function Is_Readable_File (Name : C_File_Name) return Boolean is
- function Is_Readable_File (Name : Address) return Integer;
- pragma Import (C, Is_Readable_File, "__gnat_is_readable_file");
- begin
- return Is_Readable_File (Name) /= 0;
- end Is_Readable_File;
-
- function Is_Readable_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_Readable_File (F_Name'Address);
- end Is_Readable_File;
-
- ---------------------
- -- 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_Symbolic_Link --
- ----------------------
-
- function Is_Symbolic_Link (Name : C_File_Name) return Boolean is
- function Is_Symbolic_Link (Name : Address) return Integer;
- pragma Import (C, Is_Symbolic_Link, "__gnat_is_symbolic_link");
- begin
- return Is_Symbolic_Link (Name) /= 0;
- end Is_Symbolic_Link;
-
- function Is_Symbolic_Link (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_Symbolic_Link (F_Name'Address);
- end Is_Symbolic_Link;
-
- ----------------------
- -- 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);
-
- -- Always return an absolute path name
-
- if not Is_Absolute_Path (Result.all) then
- declare
- Absolute_Path : constant String :=
- Normalize_Pathname (Result.all);
- begin
- Free (Result);
- Result := new String'(Absolute_Path);
- end;
- end if;
-
- 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);
- Result : String_Access;
-
- 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;
-
- Result := Locate_Regular_File (C_File_Name'Address, C_Path'Address);
-
- -- Always return an absolute path name
-
- if Result /= null and then not Is_Absolute_Path (Result.all) then
- declare
- Absolute_Path : constant String := Normalize_Pathname (Result.all);
- begin
- Free (Result);
- Result := new String'(Absolute_Path);
- end;
- end if;
-
- return Result;
- 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;
-
- function Non_Blocking_Spawn
- (Program_Name : String;
- Args : Argument_List;
- Output_File_Descriptor : File_Descriptor;
- Err_To_Out : Boolean := True) return Process_Id
- is
- Saved_Output : File_Descriptor;
- Saved_Error : File_Descriptor := Invalid_FD; -- prevent warning
- Pid : Process_Id;
-
- begin
- if Output_File_Descriptor = Invalid_FD then
- return Invalid_Pid;
- end if;
-
- -- Set standard output and, if specified, error to the temporary file
-
- Saved_Output := Dup (Standout);
- Dup2 (Output_File_Descriptor, Standout);
-
- if Err_To_Out then
- Saved_Error := Dup (Standerr);
- Dup2 (Output_File_Descriptor, Standerr);
- end if;
-
- -- Spawn the program
-
- Pid := Non_Blocking_Spawn (Program_Name, Args);
-
- -- Restore the standard output and error
-
- Dup2 (Saved_Output, Standout);
-
- if Err_To_Out then
- Dup2 (Saved_Error, Standerr);
- end if;
-
- -- And close the saved standard output and error file descriptors
-
- Close (Saved_Output);
-
- if Err_To_Out then
- Close (Saved_Error);
- end if;
-
- return Pid;
- end Non_Blocking_Spawn;
-
- function Non_Blocking_Spawn
- (Program_Name : String;
- Args : Argument_List;
- Output_File : String;
- Err_To_Out : Boolean := True) return Process_Id
- is
- Output_File_Descriptor : constant File_Descriptor :=
- Create_Output_Text_File (Output_File);
- Result : Process_Id;
-
- begin
- -- Do not attempt to spawn if the output file could not be created
-
- if Output_File_Descriptor = Invalid_FD then
- return Invalid_Pid;
-
- else
- Result := Non_Blocking_Spawn
- (Program_Name, Args, Output_File_Descriptor, Err_To_Out);
-
- -- Close the file just created for the output, as the file descriptor
- -- cannot be used anywhere, being a local value. It is safe to do
- -- that, as the file descriptor has been duplicated to form
- -- standard output and error of the spawned process.
-
- Close (Output_File_Descriptor);
-
- return Result;
- end if;
- end Non_Blocking_Spawn;
-
- -------------------------
- -- Normalize_Arguments --
- -------------------------
-
- procedure Normalize_Arguments (Args : in out Argument_List) is
-
- procedure Quote_Argument (Arg : in out String_Access);
- -- Add quote around argument if it contains spaces
-
- C_Argument_Needs_Quote : Integer;
- pragma Import (C, C_Argument_Needs_Quote, "__gnat_argument_needs_quote");
- Argument_Needs_Quote : constant Boolean := C_Argument_Needs_Quote /= 0;
-
- --------------------
- -- Quote_Argument --
- --------------------
-
- procedure Quote_Argument (Arg : in out String_Access) is
- Res : String (1 .. Arg'Length * 2);
- J : Positive := 1;
- Quote_Needed : Boolean := False;
-
- begin
- if Arg (Arg'First) /= '"' or else Arg (Arg'Last) /= '"' then
-
- -- Starting quote
-
- Res (J) := '"';
-
- for K in Arg'Range loop
-
- J := J + 1;
-
- if Arg (K) = '"' then
- Res (J) := '\';
- J := J + 1;
- Res (J) := '"';
- Quote_Needed := True;
-
- elsif Arg (K) = ' ' then
- Res (J) := Arg (K);
- Quote_Needed := True;
-
- else
- Res (J) := Arg (K);
- end if;
-
- end loop;
-
- if Quote_Needed then
-
- -- If null terminated string, put the quote before
-
- if Res (J) = ASCII.Nul then
- Res (J) := '"';
- J := J + 1;
- Res (J) := ASCII.Nul;
-
- -- If argument is terminated by '\', then double it. Otherwise
- -- the ending quote will be taken as-is. This is quite strange
- -- spawn behavior from Windows, but this is what we see!
-
- else
- if Res (J) = '\' then
- J := J + 1;
- Res (J) := '\';
- end if;
-
- -- Ending quote
-
- J := J + 1;
- Res (J) := '"';
- end if;
-
- declare
- Old : String_Access := Arg;
-
- begin
- Arg := new String'(Res (1 .. J));
- Free (Old);
- end;
- end if;
-
- end if;
- end Quote_Argument;
-
- -- Start of processing for Normalize_Arguments
-
- begin
- if Argument_Needs_Quote then
- for K in Args'Range loop
- if Args (K) /= null and then Args (K)'Length /= 0 then
- Quote_Argument (Args (K));
- end if;
- end loop;
- end if;
- end Normalize_Arguments;
-
- ------------------------
- -- Normalize_Pathname --
- ------------------------
-
- function Normalize_Pathname
- (Name : String;
- Directory : String := "";
- Resolve_Links : Boolean := True;
- Case_Sensitive : Boolean := True) return String
- is
- Max_Path : Integer;
- pragma Import (C, Max_Path, "__gnat_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 Get_File_Names_Case_Sensitive return Integer;
- pragma Import
- (C, Get_File_Names_Case_Sensitive,
- "__gnat_get_file_names_case_sensitive");
-
- Fold_To_Lower_Case : constant Boolean :=
- not Case_Sensitive
- and then Get_File_Names_Case_Sensitive = 0;
-
- 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 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".
-
- function Get_Directory (Dir : String) return String;
- -- If Dir is not empty, return it, adding a directory separator
- -- if not already present, otherwise return current working directory
- -- with terminating directory separator.
-
- -----------------
- -- Final_Value --
- -----------------
-
- function Final_Value (S : String) return String is
- S1 : String := S;
- -- We may need to fold S to lower case, so we need a variable
-
- Last : Natural;
-
- 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;
- Last := Result'Last;
-
- if Fold_To_Lower_Case then
- System.Case_Util.To_Lower (Result);
- end if;
-
- -- Remove trailing directory separator, if any
-
- if Last > 1 and then
- (Result (Last) = '/' or else
- Result (Last) = Directory_Separator)
- then
- Last := Last - 1;
- end if;
-
- return Result (1 .. Last);
- end;
-
- else
- if Fold_To_Lower_Case then
- System.Case_Util.To_Lower (S1);
- end if;
-
- -- Remove trailing directory separator, if any
-
- Last := S1'Last;
-
- if Last > 1
- and then (S1 (Last) = '/'
- or else
- S1 (Last) = Directory_Separator)
- then
- -- Special case for Windows: C:\
-
- if Last = 3
- and then S1 (1) /= Directory_Separator
- and then S1 (2) = ':'
- then
- null;
-
- else
- Last := Last - 1;
- end if;
- end if;
-
- return S1 (1 .. Last);
- end if;
- end Final_Value;
-
- -------------------
- -- Get_Directory --
- -------------------
-
- function Get_Directory (Dir : String) return String is
- begin
- -- Directory given, add directory separator if needed
-
- if Dir'Length > 0 then
- if Dir (Dir'Last) = Directory_Separator then
- return Directory;
- else
- declare
- Result : String (1 .. Dir'Length + 1);
- begin
- Result (1 .. Dir'Length) := Dir;
- 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;
-
- -- By default, the drive letter on Windows is in upper case
-
- if On_Windows and then Path_Len >= 2 and then
- Buffer (2) = ':'
- then
- System.Case_Util.To_Upper (Buffer (1 .. 1));
- end if;
-
- return Buffer (1 .. Path_Len);
- end;
- end if;
- end Get_Directory;
-
- Reference_Dir : constant String := Get_Directory (Directory);
- -- Current directory name specified
-
- -- 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 : constant 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;
-
- -- Resolve directory names for Windows (formerly also VMS)
-
- -- On VMS, if we have a Unix path such as /temp/..., and TEMP is a
- -- logical name, we must not try to resolve this logical name, because
- -- it may have multiple equivalences and if resolved we will only
- -- get the first one.
-
- -- On Windows, if we have an absolute path starting with a directory
- -- separator, we need to have the drive letter appended in front.
-
- -- On Windows, Get_Current_Dir will return a suitable directory
- -- name (path starting with a drive letter on Windows). So we take this
- -- drive letter and prepend it to the current path.
-
- if On_Windows
- and then Path_Buffer (1) = Directory_Separator
- and then Path_Buffer (2) /= Directory_Separator
- then
- declare
- Cur_Dir : String := Get_Directory ("");
- -- Get the current directory to get the drive letter
-
- begin
- if Cur_Dir'Length > 2
- and then Cur_Dir (Cur_Dir'First + 1) = ':'
- then
- Path_Buffer (3 .. End_Path + 2) := Path_Buffer (1 .. End_Path);
- Path_Buffer (1 .. 2) :=
- Cur_Dir (Cur_Dir'First .. Cur_Dir'First + 1);
- End_Path := End_Path + 2;
- end if;
- end;
- 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;
-
- -- Ensure that Windows network drives are kept, e.g: \\server\drive-c
-
- if Start = 2
- and then Directory_Separator = '\'
- and then Path_Buffer (1 .. 2) = "\\"
- then
- Start := 3;
- end if;
-
- -- 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
-
- if Fold_To_Lower_Case then
- System.Case_Util.To_Lower (Path_Buffer (1 .. Last - 1));
- end if;
-
- 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
-
- elsif Resolve_Links then
- declare
- Saved : constant 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;
-
- else
- Last := Finish + 1;
- 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;
-
- --------------------
- -- Pid_To_Integer --
- --------------------
-
- function Pid_To_Integer (Pid : Process_Id) return Integer is
- begin
- return Integer (Pid);
- end Pid_To_Integer;
-
- ----------
- -- Read --
- ----------
-
- function Read
- (FD : File_Descriptor;
- A : System.Address;
- N : Integer) return Integer
- is
- begin
- return Integer (System.CRTL.read
- (System.CRTL.int (FD), System.CRTL.chars (A), System.CRTL.int (N)));
- end Read;
-
- -----------------
- -- 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;
-
- -----------------------
- -- Set_Close_On_Exec --
- -----------------------
-
- procedure Set_Close_On_Exec
- (FD : File_Descriptor;
- Close_On_Exec : Boolean;
- Status : out Boolean)
- is
- function C_Set_Close_On_Exec
- (FD : File_Descriptor; Close_On_Exec : System.CRTL.int)
- return System.CRTL.int;
- pragma Import (C, C_Set_Close_On_Exec, "__gnat_set_close_on_exec");
- begin
- Status := C_Set_Close_On_Exec (FD, Boolean'Pos (Close_On_Exec)) = 0;
- end Set_Close_On_Exec;
-
- --------------------
- -- Set_Executable --
- --------------------
-
- procedure Set_Executable (Name : String) is
- procedure C_Set_Executable (Name : C_File_Name);
- pragma Import (C, C_Set_Executable, "__gnat_set_executable");
- C_Name : aliased String (Name'First .. Name'Last + 1);
- begin
- C_Name (Name'Range) := Name;
- C_Name (C_Name'Last) := ASCII.NUL;
- C_Set_Executable (C_Name (C_Name'First)'Address);
- end Set_Executable;
-
- --------------------
- -- Set_Read_Only --
- --------------------
-
- procedure Set_Read_Only (Name : String) is
- procedure C_Set_Read_Only (Name : C_File_Name);
- pragma Import (C, C_Set_Read_Only, "__gnat_set_readonly");
- C_Name : aliased String (Name'First .. Name'Last + 1);
- begin
- C_Name (Name'Range) := Name;
- C_Name (C_Name'Last) := ASCII.NUL;
- C_Set_Read_Only (C_Name (C_Name'First)'Address);
- end Set_Read_Only;
-
- --------------------
- -- Set_Writable --
- --------------------
-
- procedure Set_Writable (Name : String) is
- procedure C_Set_Writable (Name : C_File_Name);
- pragma Import (C, C_Set_Writable, "__gnat_set_writable");
- C_Name : aliased String (Name'First .. Name'Last + 1);
- begin
- C_Name (Name'Range) := Name;
- C_Name (C_Name'Last) := ASCII.NUL;
- C_Set_Writable (C_Name (C_Name'First)'Address);
- end Set_Writable;
-
- ------------
- -- 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_setenv");
-
- 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;
-
- procedure Spawn
- (Program_Name : String;
- Args : Argument_List;
- Output_File_Descriptor : File_Descriptor;
- Return_Code : out Integer;
- Err_To_Out : Boolean := True)
- is
- Saved_Output : File_Descriptor;
- Saved_Error : File_Descriptor := Invalid_FD; -- prevent compiler warning
-
- begin
- -- Set standard output and error to the temporary file
-
- Saved_Output := Dup (Standout);
- Dup2 (Output_File_Descriptor, Standout);
-
- if Err_To_Out then
- Saved_Error := Dup (Standerr);
- Dup2 (Output_File_Descriptor, Standerr);
- end if;
-
- -- Spawn the program
-
- Return_Code := Spawn (Program_Name, Args);
-
- -- Restore the standard output and error
-
- Dup2 (Saved_Output, Standout);
-
- if Err_To_Out then
- Dup2 (Saved_Error, Standerr);
- end if;
-
- -- And close the saved standard output and error file descriptors
-
- Close (Saved_Output);
-
- if Err_To_Out then
- Close (Saved_Error);
- end if;
- end Spawn;
-
- procedure Spawn
- (Program_Name : String;
- Args : Argument_List;
- Output_File : String;
- Success : out Boolean;
- Return_Code : out Integer;
- Err_To_Out : Boolean := True)
- is
- FD : File_Descriptor;
-
- begin
- Success := True;
- Return_Code := 0;
-
- FD := Create_Output_Text_File (Output_File);
-
- if FD = Invalid_FD then
- Success := False;
- return;
- end if;
-
- Spawn (Program_Name, Args, FD, Return_Code, Err_To_Out);
-
- Close (FD, Success);
- end Spawn;
-
- --------------------
- -- Spawn_Internal --
- --------------------
-
- procedure Spawn_Internal
- (Program_Name : String;
- Args : Argument_List;
- Result : out Integer;
- Pid : out Process_Id;
- Blocking : Boolean)
- is
-
- procedure Spawn (Args : Argument_List);
- -- Call Spawn with given argument list
-
- N_Args : Argument_List (Args'Range);
- -- Normalized arguments
-
- -----------
- -- Spawn --
- -----------
-
- procedure Spawn (Args : Argument_List) 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.
-
- -- But not volatile, so why is this necessary ???
-
- 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
-
- 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;
-
- -- Start of processing for Spawn_Internal
-
- begin
- -- Copy arguments into a local structure
-
- for K in N_Args'Range loop
- N_Args (K) := new String'(Args (K).all);
- end loop;
-
- -- Normalize those arguments
-
- Normalize_Arguments (N_Args);
-
- -- Call spawn using the normalized arguments
-
- Spawn (N_Args);
-
- -- Free arguments list
-
- for K in N_Args'Range loop
- Free (N_Args (K));
- end loop;
- 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 : constant 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;
-
- -----------
- -- Write --
- -----------
-
- function Write
- (FD : File_Descriptor;
- A : System.Address;
- N : Integer) return Integer
- is
- begin
- return Integer (System.CRTL.write
- (System.CRTL.int (FD), System.CRTL.chars (A), System.CRTL.int (N)));
- end Write;
-
-end GNAT.OS_Lib;
+pragma No_Body;
-- --
-- S p e c --
-- --
--- Copyright (C) 1995-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2007, Free Software Foundation, 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- --
-- Except where specifically noted, these routines are portable across all
-- GNAT implementations on all supported operating systems.
-with System;
-with GNAT.Strings;
+-- See file s-os_lib.ads for full documentation of the interface
-package GNAT.OS_Lib is
- pragma Elaborate_Body (OS_Lib);
+with System.OS_Lib;
- -----------------------
- -- String Operations --
- -----------------------
-
- -- These are reexported from package Strings (which was introduced to
- -- avoid different packages declarting different types unnecessarily).
- -- See package GNAT.Strings for details.
-
- subtype String_Access is Strings.String_Access;
-
- function "=" (Left, Right : String_Access) return Boolean
- renames Strings."=";
-
- procedure Free (X : in out String_Access) renames Strings.Free;
-
- subtype String_List is Strings.String_List;
-
- function "=" (Left, Right : String_List) return Boolean
- renames Strings."=";
-
- function "&" (Left : String_Access; Right : String_Access)
- return String_List renames Strings."&";
- function "&" (Left : String_Access; Right : String_List)
- return String_List renames Strings."&";
- function "&" (Left : String_List; Right : String_Access)
- return String_List renames Strings."&";
- function "&" (Left : String_List; Right : String_List)
- return String_List renames Strings."&";
-
- subtype String_List_Access is Strings.String_List_Access;
-
- function "=" (Left, Right : String_List_Access) return Boolean
- renames Strings."=";
-
- procedure Free (Arg : in out String_List_Access)
- renames Strings.Free;
-
- ---------------------
- -- Time/Date Stuff --
- ---------------------
-
- type OS_Time is private;
- -- The OS's notion of time is represented by the private type OS_Time.
- -- This is the type returned by the File_Time_Stamp functions to obtain
- -- the time stamp of a specified file. Functions and a procedure (modeled
- -- after the similar subprograms in package Calendar) are provided for
- -- extracting information from a value of this type. Although these are
- -- called GM, the intention is not that they provide GMT times in all
- -- cases but rather the actual (time-zone independent) time stamp of the
- -- file (of course in Unix systems, this *is* in GMT form).
-
- Invalid_Time : constant OS_Time;
- -- A special unique value used to flag an invalid time stamp value
-
- subtype Year_Type is Integer range 1900 .. 2099;
- subtype Month_Type is Integer range 1 .. 12;
- subtype Day_Type is Integer range 1 .. 31;
- subtype Hour_Type is Integer range 0 .. 23;
- subtype Minute_Type is Integer range 0 .. 59;
- subtype Second_Type is Integer range 0 .. 59;
- -- Declarations similar to those in Calendar, breaking down the time
-
- function Current_Time return OS_Time;
- -- Return the system clock value as OS_Time
-
- function GM_Year (Date : OS_Time) return Year_Type;
- function GM_Month (Date : OS_Time) return Month_Type;
- function GM_Day (Date : OS_Time) return Day_Type;
- function GM_Hour (Date : OS_Time) return Hour_Type;
- function GM_Minute (Date : OS_Time) return Minute_Type;
- function GM_Second (Date : OS_Time) return Second_Type;
- -- Functions to extract information from OS_Time value
-
- function "<" (X, Y : OS_Time) return Boolean;
- function ">" (X, Y : OS_Time) return Boolean;
- function ">=" (X, Y : OS_Time) return Boolean;
- function "<=" (X, Y : OS_Time) return Boolean;
- -- Basic comparison operators on OS_Time with obvious meanings. Note that
- -- these have Intrinsic convention, so for example it is not permissible
- -- to create accesses to any of these functions.
-
- 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);
- -- Analogous to the Split routine in Ada.Calendar, takes an OS_Time
- -- and provides a representation of it as a set of component parts,
- -- to be interpreted as a date point in UTC.
-
- ----------------
- -- File Stuff --
- ----------------
-
- -- These routines give access to the open/creat/close/read/write level of
- -- I/O routines in the typical C library (these functions are not part of
- -- the ANSI C standard, but are typically available in all systems). See
- -- also package Interfaces.C_Streams for access to the stream level
- -- routines.
-
- -- Note on file names. If a file name is passed as type String in any of
- -- the following specifications, then the name is a normal Ada string and
- -- need not be NUL-terminated. However, a trailing NUL character is
- -- permitted, and will be ignored (more accurately, the NUL and any
- -- characters that follow it will be ignored).
-
- type File_Descriptor is new Integer;
- -- Corresponds to the int file handle values used in the C routines
-
- Standin : constant File_Descriptor := 0;
- Standout : constant File_Descriptor := 1;
- Standerr : constant File_Descriptor := 2;
- -- File descriptors for standard input output files
-
- Invalid_FD : constant File_Descriptor := -1;
- -- File descriptor returned when error in opening/creating file;
-
- type Mode is (Binary, Text);
- for Mode'Size use Integer'Size;
- for Mode use (Binary => 0, Text => 1);
- -- Used in all the Open and Create calls to specify if the file is to be
- -- opened in binary mode or text mode. In systems like Unix, this has no
- -- effect, but in systems capable of text mode translation, the use of
- -- Text as the mode parameter causes the system to do CR/LF translation
- -- and also to recognize the DOS end of file character on input. The use
- -- of Text where appropriate allows programs to take a portable Unix view
- -- of DOS-format files and process them appropriately.
-
- function Open_Read
- (Name : String;
- Fmode : Mode) return File_Descriptor;
- -- Open file Name for reading, returning file descriptor File descriptor
- -- returned is Invalid_FD if file cannot be opened.
-
- function Open_Read_Write
- (Name : String;
- Fmode : Mode) return File_Descriptor;
- -- Open file Name for both reading and writing, returning file descriptor.
- -- File descriptor returned is Invalid_FD if file cannot be opened.
-
- function Create_File
- (Name : String;
- Fmode : Mode) return File_Descriptor;
- -- Creates new file with given name for writing, returning file descriptor
- -- for subsequent use in Write calls. File descriptor returned is
- -- Invalid_FD if file cannot be successfully created.
-
- function Create_Output_Text_File (Name : String) return File_Descriptor;
- -- Creates new text file with given name suitable to redirect standard
- -- output, returning file descriptor. File descriptor returned is
- -- Invalid_FD if file cannot be successfully created.
-
- function Create_New_File
- (Name : String;
- Fmode : Mode) return File_Descriptor;
- -- Create new file with given name for writing, returning file descriptor
- -- for subsequent use in Write calls. This differs from Create_File in
- -- that it fails if the file already exists. File descriptor returned is
- -- Invalid_FD if the file exists or cannot be created.
-
- Temp_File_Len : constant Integer := 12;
- -- Length of name returned by Create_Temp_File call (GNAT-XXXXXX & NUL)
-
- subtype Temp_File_Name is String (1 .. Temp_File_Len);
- -- String subtype set by Create_Temp_File
-
- procedure Create_Temp_File
- (FD : out File_Descriptor;
- Name : out Temp_File_Name);
- -- Create and open for writing a temporary file in the current working
- -- directory. The name of the file and the File Descriptor are returned.
- -- The File Descriptor returned is Invalid_FD in the case of failure. No
- -- mode parameter is provided. Since this is a temporary file, there is no
- -- point in doing text translation on it.
- --
- -- On some OSes, the maximum number of temp files that can be created with
- -- this procedure may be limited. When the maximum is reached, this
- -- procedure returns Invalid_FD. On some OSes, there may be a race
- -- condition between processes trying to create temp files at the same
- -- time in the same directory using this procedure.
-
- procedure Create_Temp_File
- (FD : out File_Descriptor;
- Name : out String_Access);
- -- Create and open for writing a temporary file in the current working
- -- directory. The name of the file and the File Descriptor are returned.
- -- No mode parameter is provided. Since this is a temporary file, there is
- -- no point in doing text translation on it. It is the responsibility of
- -- the caller to deallocate the access value returned in Name.
- --
- -- This procedure will always succeed if the current working directory is
- -- writable. If the current working directory is not writable, then
- -- Invalid_FD is returned for the file descriptor and null for the Name.
- -- There is no race condition problem between processes trying to create
- -- temp files at the same time in the same directory.
-
- procedure Close (FD : File_Descriptor; Status : out Boolean);
- -- Close file referenced by FD. Status is False if the underlying service
- -- failed. Reasons for failure include: disk full, disk quotas exceeded
- -- and invalid file descriptor (the file may have been closed twice).
-
- procedure Close (FD : File_Descriptor);
- -- Close file referenced by FD. This form is used when the caller wants to
- -- ignore any possible error (see above for error cases).
-
- procedure Set_Close_On_Exec
- (FD : File_Descriptor;
- Close_On_Exec : Boolean;
- Status : out Boolean);
- -- When Close_On_Exec is True, mark FD to be closed automatically when new
- -- program is executed by the calling process (i.e. prevent FD from being
- -- inherited by child processes). When Close_On_Exec is False, mark FD to
- -- not be closed on exec (i.e. allow it to be inherited). Status is False
- -- if the operation could not be performed.
-
- procedure Delete_File (Name : String; Success : out Boolean);
- -- Deletes file. Success is set True or False indicating if the delete is
- -- successful.
-
- procedure Rename_File
- (Old_Name : String;
- New_Name : String;
- Success : out Boolean);
- -- Rename a file. Success is set True or False indicating if the rename is
- -- successful or not.
-
- -- The following defines the mode for the Copy_File procedure below. Note
- -- that "time stamps and other file attributes" in the descriptions below
- -- refers to the creation and last modification times, and also the file
- -- access (read/write/execute) status flags.
-
- type Copy_Mode is
- (Copy,
- -- Copy the file. It is an error if the target file already exists. The
- -- time stamps and other file attributes are preserved in the copy.
-
- Overwrite,
- -- If the target file exists, the file is replaced otherwise the file
- -- is just copied. The time stamps and other file attributes are
- -- preserved in the copy.
-
- Append);
- -- If the target file exists, the contents of the source file is
- -- appended at the end. Otherwise the source file is just copied. The
- -- time stamps and other file attributes are are preserved if the
- -- destination file does not exist.
-
- type Attribute is
- (Time_Stamps,
- -- Copy time stamps from source file to target file. All other
- -- attributes are set to normal default values for file creation.
-
- Full,
- -- All attributes are copied from the source file to the target file.
- -- This includes the timestamps, and for example also includes
- -- read/write/execute attributes in Unix systems.
-
- None);
- -- No attributes are copied. All attributes including the time stamp
- -- values are set to normal default values for file creation.
-
- -- Note: The default is Time_Stamps, which corresponds to the normal
- -- default on Windows style systems. Full corresponds to the typical
- -- effect of "cp -p" on Unix systems, and None corresponds to the typical
- -- effect of "cp" on Unix systems.
-
- -- Note: Time_Stamps and Full are not supported on VMS and VxWorks
-
- procedure Copy_File
- (Name : String;
- Pathname : String;
- Success : out Boolean;
- Mode : Copy_Mode := Copy;
- Preserve : Attribute := Time_Stamps);
- -- Copy a file. Name must designate a single file (no wild cards allowed).
- -- Pathname can be a filename or directory name. In the latter case Name
- -- is copied into the directory preserving the same file name. Mode
- -- defines the kind of copy, see above with the default being a normal
- -- copy in which the target file must not already exist. Success is set to
- -- True or False indicating if the copy is successful (depending on the
- -- specified Mode).
- --
- -- Note: this procedure is only supported to a very limited extent on VMS.
- -- The only supported mode is Overwrite, and the only supported value for
- -- Preserve is None, resulting in the default action which for Overwrite
- -- is to leave attributes unchanged. Furthermore, the copy only works for
- -- simple text files.
-
- procedure Copy_Time_Stamps (Source, Dest : String; Success : out Boolean);
- -- Copy Source file time stamps (last modification and last access time
- -- stamps) to Dest file. Source and Dest must be valid filenames,
- -- furthermore Dest must be writable. Success will be set to True if the
- -- operation was successful and False otherwise.
- --
- -- Note: this procedure is not supported on VMS and VxWorks. On these
- -- platforms, Success is always set to False.
-
- function Read
- (FD : File_Descriptor;
- A : System.Address;
- N : Integer) return Integer;
- -- Read N bytes to address A from file referenced by FD. Returned value is
- -- count of bytes actually read, which can be less than N at EOF.
-
- function Write
- (FD : File_Descriptor;
- A : System.Address;
- N : Integer) return Integer;
- -- Write N bytes from address A to file referenced by FD. The returned
- -- value is the number of bytes written, which can be less than N if a
- -- disk full condition was detected.
-
- Seek_Cur : constant := 1;
- Seek_End : constant := 2;
- Seek_Set : constant := 0;
- -- Used to indicate origin for Lseek call
-
- procedure Lseek
- (FD : File_Descriptor;
- offset : Long_Integer;
- origin : Integer);
- pragma Import (C, Lseek, "__gnat_lseek");
- -- Sets the current file pointer to the indicated offset value, relative
- -- to the current position (origin = SEEK_CUR), end of file (origin =
- -- SEEK_END), or start of file (origin = SEEK_SET).
-
- function File_Length (FD : File_Descriptor) return Long_Integer;
- pragma Import (C, File_Length, "__gnat_file_length");
- -- Get length of file from file descriptor FD
-
- function File_Time_Stamp (Name : String) return OS_Time;
- -- Given the name of a file or directory, Name, obtains and returns the
- -- time stamp. This function can be used for an unopened file. Returns
- -- Invalid_Time is Name doesn't correspond to an existing file.
-
- function File_Time_Stamp (FD : File_Descriptor) return OS_Time;
- -- Get time stamp of file from file descriptor FD Returns Invalid_Time is
- -- FD doesn't correspond to an existing file.
-
- function Normalize_Pathname
- (Name : String;
- Directory : String := "";
- Resolve_Links : Boolean := True;
- Case_Sensitive : Boolean := True) return String;
- -- Returns a file name as an absolute path name, resolving all relative
- -- directories, and symbolic links. The parameter Directory is a fully
- -- resolved path name for a directory, or the empty string (the default).
- -- Name is the name of a file, which is either relative to the given
- -- directory name, if Directory is non-null, or to the current working
- -- directory if Directory is null. The result returned is the normalized
- -- name of the file. For most cases, if two file names designate the same
- -- file through different paths, Normalize_Pathname will return the same
- -- canonical name in both cases. However, there are cases when this is not
- -- true; for example, this is not true in Unix for two hard links
- -- designating the same file.
- --
- -- On Windows, the returned path will start with a drive letter except
- -- when Directory is not empty and does not include a drive letter. If
- -- Directory is empty (the default) and Name is a relative path or an
- -- absolute path without drive letter, the letter of the current drive
- -- will start the returned path. If Case_Sensitive is True (the default),
- -- then this drive letter will be forced to upper case ("C:\...").
- --
- -- If Resolve_Links is set to True, then the symbolic links, on systems
- -- that support them, will be fully converted to the name of the file or
- -- directory pointed to. This is slightly less efficient, since it
- -- requires system calls.
- --
- -- If Name cannot be resolved or is null on entry (for example if there is
- -- symbolic link circularity, e.g. A is a symbolic link for B, and B is a
- -- symbolic link for A), then Normalize_Pathname returns an empty string.
- --
- -- In VMS, if Name follows the VMS syntax file specification, it is first
- -- converted into Unix syntax. If the conversion fails, Normalize_Pathname
- -- returns an empty string.
- --
- -- For case-sensitive file systems, the value of Case_Sensitive parameter
- -- is ignored. For file systems that are not case-sensitive, such as
- -- Windows and OpenVMS, if this parameter is set to False, then the file
- -- and directory names are folded to lower case. This allows checking
- -- whether two files are the same by applying this function to their names
- -- and comparing the results. If Case_Sensitive is set to True, this
- -- function does not change the casing of file and directory names.
-
- function Is_Absolute_Path (Name : String) return Boolean;
- -- Returns True if Name is an absolute path name, i.e. it designates a
- -- file or directory absolutely rather than relative to another directory.
-
- function Is_Regular_File (Name : String) return Boolean;
- -- Determines if the given string, Name, is the name of an existing
- -- regular file. Returns True if so, False otherwise. Name may be an
- -- absolute path name or a relative path name, including a simple file
- -- name. If it is a relative path name, it is relative to the current
- -- working directory.
-
- function Is_Directory (Name : String) return Boolean;
- -- Determines if the given string, Name, is the name of a directory.
- -- Returns True if so, False otherwise. Name may be an absolute path
- -- name or a relative path name, including a simple file name. If it is
- -- a relative path name, it is relative to the current working directory.
-
- function Is_Readable_File (Name : String) return Boolean;
- -- Determines if the given string, Name, is the name of an existing file
- -- that is readable. Returns True if so, False otherwise. Note that this
- -- function simply interrogates the file attributes (e.g. using the C
- -- function stat), so it does not indicate a situation in which a file may
- -- not actually be readable due to some other process having exclusive
- -- access.
-
- function Is_Writable_File (Name : String) return Boolean;
- -- Determines if the given string, Name, is the name of an existing file
- -- that is writable. Returns True if so, False otherwise. Note that this
- -- function simply interrogates the file attributes (e.g. using the C
- -- function stat), so it does not indicate a situation in which a file may
- -- not actually be writeable due to some other process having exclusive
- -- access.
-
- function Is_Symbolic_Link (Name : String) return Boolean;
- -- Determines if the given string, Name, is the path of a symbolic link on
- -- systems that support it. Returns True if so, False if the path is not a
- -- symbolic link or if the system does not support symbolic links.
- --
- -- A symbolic link is an indirect pointer to a file; its directory entry
- -- contains the name of the file to which it is linked. Symbolic links may
- -- span file systems and may refer to directories.
-
- procedure Set_Writable (Name : String);
- -- Change the permissions on the named file to make it writable
- -- for its owner.
-
- procedure Set_Read_Only (Name : String);
- -- Change the permissions on the named file to make it non-writable
- -- for its owner.
-
- procedure Set_Executable (Name : String);
- -- Change the permissions on the named file to make it executable
- -- for its owner.
-
- function Locate_Exec_On_Path
- (Exec_Name : String) return String_Access;
- -- Try to locate an executable whose name is given by Exec_Name in the
- -- directories listed in the environment Path. If the Exec_Name doesn't
- -- have the executable suffix, it will be appended before the search.
- -- Otherwise works like Locate_Regular_File below.
- --
- -- Note that this function allocates some memory for the returned value.
- -- This memory needs to be deallocated after use.
-
- function Locate_Regular_File
- (File_Name : String;
- Path : String) return String_Access;
- -- Try to locate a regular file whose name is given by File_Name in the
- -- directories listed in Path. If a file is found, its full pathname is
- -- returned; otherwise, a null pointer is returned. If the File_Name given
- -- is an absolute pathname, then Locate_Regular_File just checks that the
- -- file exists and is a regular file. Otherwise, if the File_Name given
- -- includes directory information, Locate_Regular_File first checks if the
- -- file exists relative to the current directory. If it does not, or if
- -- the File_Name given is a simple file name, the Path argument is parsed
- -- according to OS conventions, and for each directory in the Path a check
- -- is made if File_Name is a relative pathname of a regular file from that
- -- directory.
- --
- -- Note that this function allocates some memory for the returned value.
- -- This memory needs to be deallocated after use.
-
- function Get_Debuggable_Suffix return String_Access;
- -- Return the debuggable suffix convention. Usually this is the same as
- -- the convention for Get_Executable_Suffix. The result is allocated on
- -- the heap and should be freed after use to avoid storage leaks.
-
- function Get_Target_Debuggable_Suffix return String_Access;
- -- Return the target debuggable suffix convention. Usually this is the
- -- same as the convention for Get_Executable_Suffix. The result is
- -- allocated on the heap and should be freed after use to avoid storage
- -- leaks.
-
- function Get_Executable_Suffix return String_Access;
- -- Return the executable suffix convention. The result is allocated on the
- -- heap and should be freed after use to avoid storage leaks.
-
- function Get_Object_Suffix return String_Access;
- -- Return the object suffix convention. The result is allocated on the heap
- -- and should be freed after use to avoid storage leaks.
-
- function Get_Target_Executable_Suffix return String_Access;
- -- Return the target executable suffix convention. The result is allocated
- -- on the heap and should be freed after use to avoid storage leaks.
-
- function Get_Target_Object_Suffix return String_Access;
- -- Return the target object suffix convention. The result is allocated on
- -- the heap and should be freed after use to avoid storage leaks.
-
- -- The following section contains low-level routines using addresses to
- -- pass file name and executable name. In each routine the name must be
- -- Nul-Terminated. For complete documentation refer to the equivalent
- -- routine (using String in place of C_File_Name) defined above.
-
- subtype C_File_Name is System.Address;
- -- This subtype is used to document that a parameter is the address of a
- -- null-terminated string containing the name of a file.
-
- -- All the following functions need comments ???
-
- function Open_Read
- (Name : C_File_Name;
- Fmode : Mode) return File_Descriptor;
-
- function Open_Read_Write
- (Name : C_File_Name;
- Fmode : Mode) return File_Descriptor;
-
- function Create_File
- (Name : C_File_Name;
- Fmode : Mode) return File_Descriptor;
-
- function Create_New_File
- (Name : C_File_Name;
- Fmode : Mode) return File_Descriptor;
-
- procedure Delete_File (Name : C_File_Name; Success : out Boolean);
-
- procedure Rename_File
- (Old_Name : C_File_Name;
- New_Name : C_File_Name;
- Success : out Boolean);
-
- procedure Copy_File
- (Name : C_File_Name;
- Pathname : C_File_Name;
- Success : out Boolean;
- Mode : Copy_Mode := Copy;
- Preserve : Attribute := Time_Stamps);
-
- procedure Copy_Time_Stamps
- (Source, Dest : C_File_Name;
- Success : out Boolean);
-
- function File_Time_Stamp (Name : C_File_Name) return OS_Time;
- -- Returns Invalid_Time is Name doesn't correspond to an existing file
-
- function Is_Regular_File (Name : C_File_Name) return Boolean;
- function Is_Directory (Name : C_File_Name) return Boolean;
- function Is_Readable_File (Name : C_File_Name) return Boolean;
- function Is_Writable_File (Name : C_File_Name) return Boolean;
- function Is_Symbolic_Link (Name : C_File_Name) return Boolean;
-
- function Locate_Regular_File
- (File_Name : C_File_Name;
- Path : C_File_Name) return String_Access;
-
- ------------------
- -- Subprocesses --
- ------------------
-
- subtype Argument_List is String_List;
- -- Type used for argument list in call to Spawn. The lower bound of the
- -- array should be 1, and the length of the array indicates the number of
- -- arguments.
-
- subtype Argument_List_Access is String_List_Access;
- -- Type used to return Argument_List without dragging in secondary stack.
- -- Note that there is a Free procedure declared for this subtype which
- -- frees the array and all referenced strings.
-
- procedure Normalize_Arguments (Args : in out Argument_List);
- -- Normalize all arguments in the list. This ensure that the argument list
- -- is compatible with the running OS and will works fine with Spawn and
- -- Non_Blocking_Spawn for example. If Normalize_Arguments is called twice
- -- on the same list it will do nothing the second time. Note that Spawn
- -- and Non_Blocking_Spawn call Normalize_Arguments automatically, but
- -- since there is a guarantee that a second call does nothing, this
- -- internal call will have no effect if Normalize_Arguments is called
- -- before calling Spawn. The call to Normalize_Arguments assumes that the
- -- individual referenced arguments in Argument_List are on the heap, and
- -- may free them and reallocate if they are modified.
-
- procedure Spawn
- (Program_Name : String;
- Args : Argument_List;
- Success : out Boolean);
- -- This procedure spawns a program with a given list of arguments. The
- -- first parameter of is the name of the executable. The second parameter
- -- contains the arguments to be passed to this program. Success is False
- -- if the named program could not be spawned or its execution completed
- -- unsuccessfully. Note that the caller will be blocked until the
- -- execution of the spawned program is complete. For maximum portability,
- -- use a full path name for the Program_Name argument. On some systems
- -- (notably Unix systems) a simple file name may also work (if the
- -- executable can be located in the path).
- --
- -- "Spawn" should not be used in tasking applications. Why not??? More
- -- documentation would be helpful here ??? Is it really tasking programs,
- -- or tasking activity that cause trouble ???
- --
- -- Note: Arguments in Args that contain spaces and/or quotes such as
- -- "--GCC=gcc -v" or "--GCC=""gcc -v""" are not portable across all
- -- operating systems, and would not have the desired effect if they were
- -- passed directly to the operating system. To avoid this problem, Spawn
- -- makes an internal call to Normalize_Arguments, which ensures that such
- -- arguments are modified in a manner that ensures that the desired effect
- -- is obtained on all operating systems. The caller may call
- -- Normalize_Arguments explicitly before the call (e.g. to print out the
- -- exact form of arguments passed to the operating system). In this case
- -- the guarantee a second call to Normalize_Arguments has no effect
- -- ensures that the internal call will not affect the result. Note that
- -- the implicit call to Normalize_Arguments may free and reallocate some
- -- of the individual arguments.
- --
- -- This function will always set Success to False under VxWorks and other
- -- similar operating systems which have no notion of the concept of
- -- dynamically executable file.
-
- function Spawn
- (Program_Name : String;
- Args : Argument_List) return Integer;
- -- Similar to the above procedure, but returns the actual status returned
- -- by the operating system, or -1 under VxWorks and any other similar
- -- operating systems which have no notion of separately spawnable programs.
- --
- -- "Spawn" should not be used in tasking applications.
-
- procedure Spawn
- (Program_Name : String;
- Args : Argument_List;
- Output_File_Descriptor : File_Descriptor;
- Return_Code : out Integer;
- Err_To_Out : Boolean := True);
- -- Similar to the procedure above, but redirects the output to the file
- -- designated by Output_File_Descriptor. If Err_To_Out is True, then the
- -- Standard Error output is also redirected.
- -- Return_Code is set to the status code returned by the operating system
- --
- -- "Spawn" should not be used in tasking applications.
-
- procedure Spawn
- (Program_Name : String;
- Args : Argument_List;
- Output_File : String;
- Success : out Boolean;
- Return_Code : out Integer;
- Err_To_Out : Boolean := True);
- -- Similar to the procedure above, but saves the output of the command to
- -- a file with the name Output_File.
- --
- -- Success is set to True if the command is executed and its output
- -- successfully written to the file. If Success is True, then Return_Code
- -- will be set to the status code returned by the operating system.
- -- Otherwise, Return_Code is undefined.
- --
- -- "Spawn" should not be used in tasking applications.
-
- type Process_Id is private;
- -- A private type used to identify a process activated by the following
- -- non-blocking calls. The only meaningful operation on this type is a
- -- comparison for equality.
-
- Invalid_Pid : constant Process_Id;
- -- A special value used to indicate errors, as described below
-
- function Pid_To_Integer (Pid : Process_Id) return Integer;
- -- Convert a process id to an Integer. Useful for writing hash functions
- -- for type Process_Id or to compare two Process_Id (e.g. for sorting).
-
- function Non_Blocking_Spawn
- (Program_Name : String;
- Args : Argument_List) return Process_Id;
- -- This is a non blocking call. The Process_Id of the spawned process is
- -- returned. Parameters are to be used as in Spawn. If Invalid_Pid is
- -- returned the program could not be spawned.
- --
- -- "Non_Blocking_Spawn" should not be used in tasking applications.
- --
- -- This function will always return Invalid_Pid under VxWorks, since there
- -- is no notion of executables under this OS.
-
- function Non_Blocking_Spawn
- (Program_Name : String;
- Args : Argument_List;
- Output_File_Descriptor : File_Descriptor;
- Err_To_Out : Boolean := True) return Process_Id;
- -- Similar to the procedure above, but redirects the output to the file
- -- designated by Output_File_Descriptor. If Err_To_Out is True, then the
- -- Standard Error output is also redirected. Invalid_Pid is returned
- -- if the program could not be spawned successfully.
- --
- -- "Non_Blocking_Spawn" should not be used in tasking applications.
- --
- -- This function will always return Invalid_Pid under VxWorks, since there
- -- is no notion of executables under this OS.
-
- function Non_Blocking_Spawn
- (Program_Name : String;
- Args : Argument_List;
- Output_File : String;
- Err_To_Out : Boolean := True) return Process_Id;
- -- Similar to the procedure above, but saves the output of the command to
- -- a file with the name Output_File.
- --
- -- Success is set to True if the command is executed and its output
- -- successfully written to the file. Invalid_Pid is returned if the output
- -- file could not be created or if the program could not be spawned
- -- successfully.
- --
- -- "Non_Blocking_Spawn" should not be used in tasking applications.
- --
- -- This function will always return Invalid_Pid under VxWorks, since there
- -- is no notion of executables under this OS.
-
- procedure Wait_Process (Pid : out Process_Id; Success : out Boolean);
- -- Wait for the completion of any of the processes created by previous
- -- calls to Non_Blocking_Spawn. The caller will be suspended until one of
- -- these processes terminates (normally or abnormally). If any of these
- -- subprocesses terminates prior to the call to Wait_Process (and has not
- -- been returned by a previous call to Wait_Process), then the call to
- -- Wait_Process is immediate. Pid identifies the process that has
- -- terminated (matching the value returned from Non_Blocking_Spawn).
- -- Success is set to True if this sub-process terminated successfully. If
- -- Pid = Invalid_Pid, there were no subprocesses left to wait on.
- --
- -- This function will always set success to False under VxWorks, since
- -- there is no notion of executables under this OS.
-
- function Argument_String_To_List
- (Arg_String : String) return Argument_List_Access;
- -- Take a string that is a program and its arguments and parse it into an
- -- Argument_List. Note that the result is allocated on the heap, and must
- -- be freed by the programmer (when it is no longer needed) to avoid
- -- memory leaks.
-
- -------------------
- -- Miscellaneous --
- -------------------
-
- function Getenv (Name : String) return String_Access;
- -- Get the value of the environment variable. Returns an access to the
- -- empty string if the environment variable does not exist or has an
- -- explicit null value (in some operating systems these are distinct
- -- cases, in others they are not; this interface abstracts away that
- -- difference. The argument is allocated on the heap (even in the null
- -- case), and needs to be freed explicitly when no longer needed to avoid
- -- memory leaks.
-
- procedure Setenv (Name : String; Value : String);
- -- Set the value of the environment variable Name to Value. This call
- -- modifies the current environment, but does not modify the parent
- -- process environment. After a call to Setenv, Getenv (Name) will always
- -- return a String_Access referencing the same String as Value. This is
- -- true also for the null string case (the actual effect may be to either
- -- set an explicit null as the value, or to remove the entry, this is
- -- operating system dependent). Note that any following calls to Spawn
- -- will pass an environment to the spawned process that includes the
- -- changes made by Setenv calls. This procedure is not available on VMS.
-
- procedure OS_Exit (Status : Integer);
- pragma Import (C, OS_Exit, "__gnat_os_exit");
- pragma No_Return (OS_Exit);
- -- Exit to OS with given status code (program is terminated). Note that
- -- this is abrupt termination. All tasks are immediately terminated. There
- -- is no finalization or other cleanup actions performed.
-
- procedure OS_Abort;
- pragma Import (C, OS_Abort, "abort");
- pragma No_Return (OS_Abort);
- -- Exit to OS signalling an abort (traceback or other appropriate
- -- diagnostic information should be given if possible, or entry made to
- -- the debugger if that is possible).
-
- function Errno return Integer;
- pragma Import (C, Errno, "__get_errno");
- -- Return the task-safe last error number
-
- procedure Set_Errno (Errno : Integer);
- pragma Import (C, Set_Errno, "__set_errno");
- -- Set the task-safe error number
-
- Directory_Separator : constant Character;
- -- The character that is used to separate parts of a pathname
-
- Path_Separator : constant Character;
- -- The character to separate paths in an environment variable value
-
-private
- pragma Import (C, Path_Separator, "__gnat_path_separator");
- pragma Import (C, Directory_Separator, "__gnat_dir_separator");
- pragma Import (C, Current_Time, "__gnat_current_time");
-
- type OS_Time is new Long_Integer;
- -- Type used for timestamps in the compiler. This type is used to hold
- -- time stamps, but may have a different representation than C's time_t.
- -- This type needs to match the declaration of OS_Time in adaint.h.
-
- -- Add pragma Inline statements for comparison operations on OS_Time. It
- -- would actually be nice to use pragma Import (Intrinsic) here, but this
- -- was not properly supported till GNAT 3.15a, so that would cause
- -- bootstrap path problems. To be changed later ???
-
- Invalid_Time : constant OS_Time := -1;
- -- This value should match the return valud by __gnat_file_time_*
-
- pragma Inline ("<");
- pragma Inline (">");
- pragma Inline ("<=");
- pragma Inline (">=");
-
- type Process_Id is new Integer;
- Invalid_Pid : constant Process_Id := -1;
-
-end GNAT.OS_Lib;
+package GNAT.OS_Lib renames System.OS_Lib;
OSDN Git Service
