1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
module Flag = C.Types.Process.Flag
module Redirection = C.Types.Process.Redirection
type t = [ `Process ] Handle.t
type redirection = int * Redirection.t
let no_redirection =
let redirection = Ctypes.make Redirection.t in
Ctypes.setf redirection Redirection.flags Redirection.ignore;
redirection
let to_parent_pipe
?(readable_in_child = true)
?(writable_in_child = true)
?(overlapped = false)
~fd ~parent_pipe () =
let redirection = Ctypes.make Redirection.t in
let flags =
let accumulate = Helpers.Bit_field.accumulate in
Redirection.create_pipe
|> accumulate Redirection.readable_pipe readable_in_child
|> accumulate Redirection.writable_pipe writable_in_child
|> accumulate Redirection.overlapped_pipe overlapped
in
Ctypes.setf redirection Redirection.flags flags;
Ctypes.setf redirection Redirection.stream Handle.(coerce parent_pipe);
(fd, redirection)
let inherit_fd ~fd ~from_parent_fd () =
let redirection = Ctypes.make Redirection.t in
Ctypes.setf redirection Redirection.flags Redirection.inherit_fd;
Ctypes.setf redirection Redirection.fd from_parent_fd;
(fd, redirection)
let inherit_stream ~fd ~from_parent_stream () =
let redirection = Ctypes.make Redirection.t in
Ctypes.setf redirection Redirection.flags Redirection.inherit_stream;
Ctypes.setf redirection Redirection.stream Handle.(coerce from_parent_stream);
(fd, redirection)
let stdin = 0
let stdout = 1
let stderr = 2
let find_redirection child_fd redirections =
try
redirections
|> List.find (fun (fd, _) -> fd = child_fd)
|> snd
with Not_found ->
no_redirection
let max_redirected_fd redirections =
redirections
|> List.map fst
|> List.fold_left max 3
let build_redirection_array redirections =
let length = max_redirected_fd redirections in
let array = Ctypes.CArray.make Redirection.t length in
for index = 0 to length - 1 do
Ctypes.CArray.set array index (find_redirection index redirections)
done;
(Ctypes.CArray.start array, length)
let trampoline =
C.Functions.Process.get_trampoline ()
let null_callback =
C.Functions.Process.get_null_callback ()
let c_string_array strings =
strings @ [""]
|> Ctypes.(CArray.of_list string)
|> Ctypes.CArray.start
let spawn
?loop
?on_exit
?environment
?working_directory
?(redirect = [])
?uid
?gid
?windows_verbatim_arguments
?detached
?windows_hide
?windows_hide_console
?windows_hide_gui
path arguments =
let loop = Loop.or_default loop in
let process = Handle.allocate C.Types.Process.t in
let callback =
match on_exit with
| Some callback ->
Handle.set_reference process (fun exit_status term_signal ->
try callback process ~exit_status ~term_signal
with exn -> Error.unhandled_exception exn);
trampoline
| None ->
null_callback
in
let env, env_count, set_env =
match environment with
| Some env ->
let env = List.map (fun (key, value) -> key ^ "=" ^ value) env in
(env, List.length env, true)
| None ->
([], 0, false)
in
let cwd, do_cwd =
match working_directory with
| Some dir -> (dir, true)
| None -> ("", false)
in
let flags = 0 in
let uid_or_gid_flag id flag flags =
match id with
| Some id -> (id, flags lor flag)
| None -> (0, flags)
in
let uid, flags = uid_or_gid_flag uid Flag.setuid flags in
let gid, flags = uid_or_gid_flag gid Flag.setgid flags in
let maybe_flag argument flag flags =
match argument with
| Some true -> flags lor flag
| _ -> flags
in
let flags =
flags
|> maybe_flag windows_verbatim_arguments Flag.windows_verbatim_arguments
|> maybe_flag detached Flag.detached
|> maybe_flag windows_hide Flag.windows_hide
|> maybe_flag windows_hide_console Flag.windows_hide_console
|> maybe_flag windows_hide_gui Flag.windows_hide_gui
in
let redirections, redirection_count = build_redirection_array redirect in
let result =
C.Functions.Process.spawn
loop
process
callback
(Ctypes.ocaml_string_start path)
(c_string_array arguments)
(List.length arguments)
(c_string_array env)
env_count
set_env
(Ctypes.ocaml_string_start cwd)
do_cwd
flags
redirection_count
redirections
uid
gid
in
if result < 0 then begin
Handle.close process ignore
end;
Error.to_result process result
let disable_stdio_inheritance =
C.Functions.Process.disable_stdio_inheritance
let kill process signal =
C.Functions.Process.process_kill process signal
|> Error.to_result ()
let kill_pid ~pid signal =
C.Functions.Process.kill pid signal
|> Error.to_result ()
let pid =
C.Functions.Process.get_pid