OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

g-os_lib.ads, [...] (Non_Blocking_Spawn): Two new versions with output file descriptor and with output file name. 

2005-06-14  Vincent Celier  <celier@adacore.com>
	    Cyrille Comar  <comar@adacore.com>

	* g-os_lib.ads, g-os_lib.adb (Non_Blocking_Spawn): Two new versions
	with output file descriptor and with output file name.
	(Dup, Dup2): Now global procedures as they are used by two subprograms
	(Copy): Allocate the 200K buffer on the heap rather than on the stack.

From-SVN: r101042
This commit is contained in:
Vincent Celier 2005-06-16 10:41:09 +02:00 committed by Arnaud Charlet
parent de972f9de7
commit e5a97c1329
2 changed files with 148 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

124
gcc/ada/g-os_lib.adb
View File

@ -35,20 +35,32 @@ with System.Case_Util;
with System.CRTL;
with System.Soft_Links;
with Unchecked_Conversion;
with Unchecked_Deallocation;
with System; use System;
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");
OpenVMS : Boolean;
-- Note: OpenVMS should be a constant, but it cannot be, because it
-- prevents bootstrapping on some platforms.
On_Windows : constant Boolean := Directory_Separator = '\';
pragma Import (Ada, OpenVMS, "system__openvms");
-- Needed to avoid doing useless checks when non on a VMS platform (see
-- Normalize_Pathname).
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
@ -354,19 +366,28 @@ package body GNAT.OS_Lib is
procedure Copy (From, To : File_Descriptor) is
Buf_Size : constant := 200_000;
Buffer : array (1 .. Buf_Size) of Character;
R : Integer;
W : Integer;
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
if From = Invalid_FD or else To = Invalid_FD then
raise Copy_Error;
end if;
-- Allocate the buffer on the heap
Buffer := new Buf;
loop
R := Read (From, Buffer (1)'Address, Buf_Size);
@ -386,6 +407,8 @@ package body GNAT.OS_Lib is
Close (From, Status_From);
Close (To, Status_To);
Free (Buffer);
raise Copy_Error;
end if;
end loop;
@ -393,6 +416,8 @@ package body GNAT.OS_Lib is
Close (From, Status_From);
Close (To, Status_To);
Free (Buffer);
if not (Status_From and Status_To) then
raise Copy_Error;
end if;
@ -1334,6 +1359,89 @@ package body GNAT.OS_Lib is
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;
-- We need to initialize Saved_Error to Invalid_FD to avoid
-- a compiler warning that this variable may be used before
-- it is initialized (which can not happen, but the compiler
-- is not smart enough to figure this out).
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 --
-------------------------
@ -2167,12 +2275,6 @@ package body GNAT.OS_Lib is
Return_Code : out Integer;
Err_To_Out : Boolean := True)
is
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");
Saved_Output : File_Descriptor;
Saved_Error : File_Descriptor := Invalid_FD;
-- We need to initialize Saved_Error to Invalid_FD to avoid

36
gcc/ada/g-os_lib.ads
View File

@ -114,7 +114,6 @@ package GNAT.OS_Lib is
subtype Second_Type is Integer range 0 .. 59;
-- Declarations similar to those in Calendar, breaking down the 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;
@ -715,6 +714,41 @@ package GNAT.OS_Lib is
-- This function will always return Invalid_Id 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_Id 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_Id 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_Id 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_Id 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