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
open StdLabels
external is_osx : unit -> bool = "spawn_is_osx" [@@noalloc]
let is_osx = is_osx ()
module Working_dir = struct
type t =
| Path of string
| Fd of Unix.file_descr
| Inherit
end
module Unix_backend = struct
type t =
| Fork
| Vfork
let default =
match Sys.getenv "SPAWN_USE_FORK" with
| _ -> Fork
| exception Not_found ->
if is_osx then Fork else Vfork
;;
end
let no_null s =
if String.contains s '\000'
then
Printf.ksprintf
invalid_arg
"Spawn.Env.of_list: NUL bytes are not allowed in the environment but found one in \
%S"
s
;;
module type Env = sig
type t
val of_list : string list -> t
end
module Env_win32 : Env = struct
type t = string
let of_list env =
if env = []
then "\000\000"
else (
let len = List.fold_left env ~init:1 ~f:(fun acc s -> acc + String.length s + 1) in
let buf = Buffer.create len in
List.iter env ~f:(fun s ->
no_null s;
Buffer.add_string buf s;
Buffer.add_char buf '\000');
Buffer.add_char buf '\000';
Buffer.contents buf)
;;
end
module Env_unix : Env = struct
type t = string list
let of_list l =
List.iter l ~f:no_null;
l
;;
end
module Env : Env = (val if Sys.win32 then (module Env_win32) else (module Env_unix) : Env)
module Pgid = struct
type t = int
let new_process_group = 0
let of_pid = function
| 0 -> raise (Invalid_argument "bad pid: 0 (hint: use [Pgid.new_process_group])")
| t -> if t < 0 then raise (Invalid_argument ("bad pid: " ^ string_of_int t)) else t
;;
end
external spawn_unix
: env:Env.t option
-> cwd:Working_dir.t
-> prog:string
-> argv:string list
-> stdin:Unix.file_descr
-> stdout:Unix.file_descr
-> stderr:Unix.file_descr
-> use_vfork:bool
-> setpgid:int option
-> sigprocmask:(Unix.sigprocmask_command * int list) option
-> int
= "spawn_unix_byte" "spawn_unix"
external spawn_windows
: env:Env.t option
-> cwd:string option
-> prog:string
-> cmdline:string
-> stdin:Unix.file_descr
-> stdout:Unix.file_descr
-> stderr:Unix.file_descr
-> int
= "spawn_windows_byte" "spawn_windows"
let maybe_quote f =
if String.contains f ' ' || String.contains f '\"' || String.contains f '\t' || f = ""
then Filename.quote f
else f
;;
let spawn_windows
~env
~cwd
~prog
~argv
~stdin
~stdout
~stderr
~use_vfork:_
~setpgid:_
~sigprocmask:_
=
let cwd =
match (cwd : Working_dir.t) with
| Path p -> Some p
| Fd _ -> invalid_arg "Spawn.spawn: [cwd=Fd _] is not supported on Windows"
| Inherit -> None
in
let cmdline = String.concat (List.map argv ~f:maybe_quote) ~sep:" " in
let prog =
match Filename.is_relative prog, cwd with
| true, Some p -> Filename.concat p prog
| _ -> prog
in
spawn_windows ~env ~cwd ~prog ~cmdline ~stdin ~stdout ~stderr
;;
let no_null s =
if String.contains s '\000'
then
Printf.ksprintf
invalid_arg
"Spawn.spawn: NUL bytes are not allowed in any of the arguments but found one in %S"
s
;;
let spawn
?env
?(cwd = Working_dir.Inherit)
~prog
~argv
?(stdin = Unix.stdin)
?(stdout = Unix.stdout)
?(stderr = Unix.stderr)
?(unix_backend = Unix_backend.default)
?setpgid
?sigprocmask
()
=
(match cwd with
| Path s -> no_null s
| Fd _ | Inherit -> ());
no_null prog;
List.iter argv ~f:no_null;
let backend = if Sys.win32 then spawn_windows else spawn_unix in
let use_vfork =
match unix_backend with
| Vfork -> true
| Fork -> false
in
backend ~env ~cwd ~prog ~argv ~stdin ~stdout ~stderr ~use_vfork ~setpgid ~sigprocmask
;;
external safe_pipe : unit -> Unix.file_descr * Unix.file_descr = "spawn_pipe"
let safe_pipe = if Sys.win32 then fun () -> Unix.pipe ~cloexec:true () else safe_pipe