1(* This is a terrible hack that plays on the internal representation
2   of file descriptors.  The result is a number (as a string)
3   that the fdstatus.exe auxiliary program can use to check whether
4   the fd is open. *)
5
6let string_of_fd (fd: Unix.file_descr) : string =
7  match Sys.os_type with
8  | "Unix" | "Cygwin" ->  string_of_int (Obj.magic fd : int)
9  | "Win32" ->
10      if Sys.word_size = 32 then
11        Int32.to_string (Obj.magic fd : int32)
12      else
13        Int64.to_string (Obj.magic fd : int64)
14  | _ -> assert false
15
16let _ =
17  let f0 = Unix.(openfile "tmp.txt" [O_WRONLY; O_CREAT; O_TRUNC] 0o600) in
18  let f1 = Unix.(openfile "tmp.txt" [O_RDONLY; O_KEEPEXEC] 0) in
19  let f2 = Unix.(openfile "tmp.txt" [O_RDONLY; O_CLOEXEC] 0) in
20  let d0 = Unix.dup f0 in
21  let d1 = Unix.dup ~cloexec:false f1 in
22  let d2 = Unix.dup ~cloexec:true f2 in
23  let (p0, p0') = Unix.pipe () in
24  let (p1, p1') = Unix.pipe ~cloexec:false () in
25  let (p2, p2') = Unix.pipe ~cloexec:true () in
26  let s0 = Unix.(socket PF_INET SOCK_STREAM 0) in
27  let s1 = Unix.(socket ~cloexec:false PF_INET SOCK_STREAM 0) in
28  let s2 = Unix.(socket ~cloexec:true PF_INET SOCK_STREAM 0) in
29  let (x0, x0') =
30    try Unix.(socketpair PF_UNIX SOCK_STREAM 0)
31    with Invalid_argument _ -> (p0, p0') in
32    (* socketpair not available under Win32; keep the same output *)
33  let (x1, x1') =
34    try Unix.(socketpair ~cloexec:false PF_UNIX SOCK_STREAM 0)
35    with Invalid_argument _ -> (p1, p1') in
36  let (x2, x2') =
37    try Unix.(socketpair ~cloexec:true PF_UNIX SOCK_STREAM 0)
38    with Invalid_argument _ -> (p2, p2') in
39
40  let fds = [| f0;f1;f2; d0;d1;d2;
41               p0;p0';p1;p1';p2;p2';
42               s0;s1;s2;
43               x0;x0';x1;x1';x2;x2' |] in
44  let pid =
45    Unix.create_process
46      (Filename.concat Filename.current_dir_name "fdstatus.exe")
47      (Array.append [| "fdstatus" |] (Array.map string_of_fd fds))
48      Unix.stdin Unix.stdout Unix.stderr in
49  ignore (Unix.waitpid [] pid);
50  Array.iter (fun fd -> try Unix.close fd with Unix.Unix_error _ -> ()) fds;
51  Sys.remove "tmp.txt"
52