/
batUnix.ml
167 lines (127 loc) · 5.44 KB
/
batUnix.ml
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
(*
* ExtUnix - additional and modified functions for Unix and Unix-compatible systems.
* Copyright (C) 1996 Xavier Leroy
* Copyright (C) 2009 David Teller, LIFO, Universite d'Orleans
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
* License as published by the Free Software Foundation; either
* version 2.1 of the License, or (at your option) any later version,
* with the special exception on linking described in file LICENSE.
*
* This library is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
*)
open Unix
open BatInnerIO
(**
{6 Thread-safety internals}
*)
let lock = ref BatConcurrent.nolock
(**
{6 Tracking additional information on inputs/outputs}
{b Note} Having [input]/[output] as objects would have made this
easier. Here, we need to maintain an external weak hashtable to
track low-level information on our [input]s/[output]s.
*)
module Wrapped_in = BatInnerWeaktbl.Make(Input) (*input -> in_channel *)
module Wrapped_out= BatInnerWeaktbl.Make(Output)(*output -> out_channel*)
let wrapped_in = Wrapped_in.create 16
let wrapped_out = Wrapped_out.create 16
let input_add k v =
BatConcurrent.sync !lock (Wrapped_in.add wrapped_in k) v
let input_get k =
BatConcurrent.sync !lock (Wrapped_in.find wrapped_in) k
let output_add k v =
BatConcurrent.sync !lock (Wrapped_out.add wrapped_out k) v
let output_get k =
BatConcurrent.sync !lock (Wrapped_out.find wrapped_out) k
let wrap_in ?autoclose ?cleanup cin =
let input = BatInnerIO.input_channel ?autoclose ?cleanup cin in
BatConcurrent.sync !lock (Wrapped_in.add wrapped_in input) cin;
input
let wrap_out ?cleanup cout =
let output = cast_output (BatInnerIO.output_channel ?cleanup cout) in
BatConcurrent.sync !lock (Wrapped_out.add wrapped_out output) cout;
output
let _ =
input_add stdin Pervasives.stdin;
output_add stdout Pervasives.stdout;
output_add stderr Pervasives.stderr
(**
{6 File descriptors}
*)
let input_of_descr ?autoclose ?cleanup fd =
wrap_in ?autoclose ?cleanup (in_channel_of_descr fd)
let descr_of_input cin =
try descr_of_in_channel (input_get cin)
with Not_found -> raise (Invalid_argument "Unix.descr_of_in_channel")
let output_of_descr ?cleanup fd =
wrap_out ?cleanup (out_channel_of_descr fd)
let descr_of_output cout =
try descr_of_out_channel (output_get (cast_output cout))
with Not_found -> raise (Invalid_argument "Unix.descr_of_out_channel")
let in_channel_of_descr fd = input_of_descr ~autoclose:false ~cleanup:true fd
let descr_of_in_channel = descr_of_input
let out_channel_of_descr fd = output_of_descr ~cleanup:true fd
let descr_of_out_channel = descr_of_output
(**
{6 Processes}
*)
let open_process_in ?autoclose ?(cleanup=true) s =
wrap_in ?autoclose ~cleanup (open_process_in s)
let open_process_out ?(cleanup=true) s =
wrap_out ~cleanup (open_process_out s)
let open_process ?autoclose ?(cleanup=true) s =
let (cin, cout) = open_process s in
(wrap_in ?autoclose cin, wrap_out ~cleanup cout)
let open_process_full ?autoclose ?(cleanup=true) s args =
let (a,b,c) = open_process_full s args in
(wrap_in ?autoclose ~cleanup a, wrap_out ~cleanup b, wrap_in ?autoclose ~cleanup c)
(**@TODO in a future version, [close_process_in] should also work
on processes opened with [open_process] or [open_process_full].
Same thing for [close_process_out].*)
let close_process_in cin =
try close_process_in (input_get cin)
with Not_found -> raise (Unix_error(EBADF, "close_process_in", ""))
let close_process_out cout =
try close_process_out (output_get cout)
with Not_found -> raise (Unix_error(EBADF, "close_process_out", ""))
let close_process (cin, cout) =
try
let pin = input_get cin
and pout= output_get cout in
close_process (pin, pout)
with Not_found -> raise (Unix_error(EBADF, "close_process", ""))
let close_process_full (cin, cout, cin2) =
try close_process_full (input_get cin, output_get cout, input_get cin2)
with Not_found -> raise (Unix_error(EBADF, "close_process_full", ""))
(**
{6 Network}
*)
let ( <| ) f x = f x
let ( *** ) f g = fun (x,y) -> (f x, g y)
let shutdown_connection cin =
try shutdown_connection (input_get cin)
with Not_found -> raise (Invalid_argument "Unix.descr_of_in_channel")
let open_connection ?autoclose addr =
let (cin, cout) = open_connection addr in
let (cin',cout')= (wrap_in ?autoclose ~cleanup:true cin, wrap_out ~cleanup:true cout) in
let close () = shutdown_connection cin' in
(inherit_in cin' ~close, inherit_out cout' ~close)
let establish_server ?autoclose ?cleanup f addr =
let f' cin cout = f (wrap_in ?autoclose ?cleanup cin) (wrap_out cout) in
establish_server f' addr
(**
{6 Tools}
*)
let is_directory fn = (lstat fn).st_kind = S_DIR
let rec restart_on_EINTR f x =
try f x
with Unix_error(EINTR, _, _) -> restart_on_EINTR f x