1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- G N A T . E X P E C T . N O N _ B L O C K I N G _ S P A W N --
9 -- Copyright (C) 2002 Ada Core Technologies, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 2, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, USA. --
22 -- As a special exception, if other files instantiate generics from this --
23 -- unit, or you link this unit with other files to produce an executable, --
24 -- this unit does not by itself cause the resulting executable to be --
25 -- covered by the GNU General Public License. This exception does not --
26 -- however invalidate any other reasons why the executable file might be --
27 -- covered by the GNU Public License. --
29 -- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
31 ------------------------------------------------------------------------------
33 -- This is the default version. Used everywhere except VMS.
35 separate (GNAT
.Expect
)
36 procedure Non_Blocking_Spawn
37 (Descriptor
: out Process_Descriptor
'Class;
39 Args
: GNAT
.OS_Lib
.Argument_List
;
40 Buffer_Size
: Natural := 4096;
41 Err_To_Out
: Boolean := False)
43 function Fork
return Process_Id
;
44 pragma Import
(C
, Fork
, "__gnat_expect_fork");
45 -- Starts a new process if possible.
46 -- See the Unix command fork for more information. On systems that
47 -- don't support this capability (Windows...), this command does
48 -- nothing, and Fork will return Null_Pid.
50 Pipe1
, Pipe2
, Pipe3
: aliased Pipe_Type
;
53 Arg_List
: aliased array (1 .. Args
'Length + 2) of System
.Address
;
55 Command_With_Path
: String_Access
;
58 -- Create the rest of the pipes
61 (Descriptor
, Err_To_Out
, Pipe1
'Access, Pipe2
'Access, Pipe3
'Access);
65 Descriptor
.Pid
:= Fork
;
67 -- Are we now in the child (or, for Windows, still in the common
70 if Descriptor
.Pid
= Null_Pid
then
72 Command_With_Path
:= Locate_Exec_On_Path
(Command
);
74 -- Prepare an array of arguments to pass to C
75 Arg
:= new String (1 .. Command_With_Path
'Length + 1);
76 Arg
(1 .. Command_With_Path
'Length) := Command_With_Path
.all;
77 Arg
(Arg
'Last) := ASCII
.Nul
;
78 Arg_List
(1) := Arg
.all'Address;
80 for J
in Args
'Range loop
81 Arg
:= new String (1 .. Args
(J
)'Length + 1);
82 Arg
(1 .. Args
(J
)'Length) := Args
(J
).all;
83 Arg
(Arg
'Last) := ASCII
.Nul
;
84 Arg_List
(J
+ 2 - Args
'First) := Arg
.all'Address;
87 Arg_List
(Arg_List
'Last) := System
.Null_Address
;
89 -- This does not return on Unix systems
91 Set_Up_Child_Communications
92 (Descriptor
, Pipe1
, Pipe2
, Pipe3
, Command_With_Path
.all,
95 Free
(Command_With_Path
);
98 -- Did we have an error when spawning the child ?
100 if Descriptor
.Pid
< Null_Pid
then
103 -- We are now in the parent process
105 Set_Up_Parent_Communications
(Descriptor
, Pipe1
, Pipe2
, Pipe3
);
110 Descriptor
.Buffer_Size
:= Buffer_Size
;
112 if Buffer_Size
/= 0 then
113 Descriptor
.Buffer
:= new String (1 .. Positive (Buffer_Size
));
115 end Non_Blocking_Spawn
;