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
|
(* TEST
include unix;
readonly_files = "fdstatus_aux.c fdstatus_main.ml";
(*
This test is temporarily disabled on the MinGW and MSVC ports,
because since fdstatus has been wrapped in an OCaml program,
it does not work as well as before.
Presumably this is because the OCaml runtime opens files, so that handles
that have actually been closed at execution look open and make the
test fail.
One possible fix for this would be to make it possible for ocamltest to
compile C-only programs, which will be a bit of work to handle the
output of msvc and will also duplicate what the OCaml compiler itself
already does.
*)
hasunix;
libunix;
{
program = "${test_build_directory}/cloexec.byte";
setup-ocamlc.byte-build-env;
program = "${test_build_directory}/fdstatus.exe";
all_modules = "fdstatus_aux.c fdstatus_main.ml";
ocamlc.byte;
program = "${test_build_directory}/cloexec.byte";
all_modules = "cloexec.ml";
ocamlc.byte;
check-ocamlc.byte-output;
run;
check-program-output;
}{
program = "${test_build_directory}/cloexec.opt";
setup-ocamlopt.byte-build-env;
program = "${test_build_directory}/fdstatus.exe";
all_modules = "fdstatus_aux.c fdstatus_main.ml";
ocamlopt.byte;
program = "${test_build_directory}/cloexec.opt";
all_modules = "cloexec.ml";
ocamlopt.byte;
check-ocamlopt.byte-output;
run;
check-program-output;
}
*)
(* This is a terrible hack that plays on the internal representation
of file descriptors. The result is a number (as a string)
that the fdstatus.exe auxiliary program can use to check whether
the fd is open. Moreover, since fdstatus.exe is an OCaml program,
we must take into account that the Windows OCaml runtime opens a few handles
for its own use, hence we do likewise to try to get handle numbers
Windows will not allocate to the OCaml runtime of fdstatus.exe *)
let string_of_fd (fd: Unix.file_descr) : string =
match Sys.os_type with
| "Unix" | "Cygwin" -> Int.to_string (Obj.magic fd : int)
| "Win32" ->
if Sys.word_size = 32 then
Int32.to_string (Obj.magic fd : int32)
else
Int64.to_string (Obj.magic fd : int64)
| _ -> assert false
let status_checker = "fdstatus.exe"
let _ =
let f0 = Unix.(openfile "tmp.txt" [O_WRONLY; O_CREAT; O_TRUNC] 0o600) in
let untested1 = Unix.(openfile "tmp.txt" [O_RDONLY; O_CLOEXEC] 0) in
let untested2 = Unix.(openfile "tmp.txt" [O_RDONLY; O_CLOEXEC] 0) in
let untested3 = Unix.(openfile "tmp.txt" [O_RDONLY; O_CLOEXEC] 0) in
let untested4 = Unix.(openfile "tmp.txt" [O_RDONLY; O_CLOEXEC] 0) in
let untested5 = Unix.(openfile "tmp.txt" [O_RDONLY; O_CLOEXEC] 0) in
let f1 = Unix.(openfile "tmp.txt" [O_RDONLY; O_KEEPEXEC] 0) in
let f2 = Unix.(openfile "tmp.txt" [O_RDONLY; O_CLOEXEC] 0) in
let d0 = Unix.dup f0 in
let d1 = Unix.dup ~cloexec:false f1 in
let d2 = Unix.dup ~cloexec:true f2 in
let (p0, p0') = Unix.pipe () in
let (p1, p1') = Unix.pipe ~cloexec:false () in
let (p2, p2') = Unix.pipe ~cloexec:true () in
let s0 = Unix.(socket PF_INET SOCK_STREAM 0) in
let s1 = Unix.(socket ~cloexec:false PF_INET SOCK_STREAM 0) in
let s2 = Unix.(socket ~cloexec:true PF_INET SOCK_STREAM 0) in
let (x0, x0') =
try Unix.(socketpair PF_UNIX SOCK_STREAM 0)
with Invalid_argument _ -> (p0, p0') in
(* socketpair not available under Win32; keep the same output *)
let (x1, x1') =
try Unix.(socketpair ~cloexec:false PF_UNIX SOCK_STREAM 0)
with Invalid_argument _ -> (p1, p1') in
let (x2, x2') =
try Unix.(socketpair ~cloexec:true PF_UNIX SOCK_STREAM 0)
with Invalid_argument _ -> (p2, p2') in
let fds = [| f0;f1;f2; d0;d1;d2;
p0;p0';p1;p1';p2;p2';
s0;s1;s2;
x0;x0';x1;x1';x2;x2' |] in
let untested =
[untested1; untested2; untested3; untested4; untested5]
in
let pid =
Unix.create_process
(Filename.concat Filename.current_dir_name status_checker)
(Array.append [| status_checker |] (Array.map string_of_fd fds))
Unix.stdin Unix.stdout Unix.stderr in
ignore (Unix.waitpid [] pid);
let close fd = try Unix.close fd with Unix.Unix_error _ -> () in
Array.iter close fds;
List.iter close untested;
Sys.remove "tmp.txt"
|
