← Back to branch summary

~ubuntu-branches/ubuntu/trusty/ocamlnet/trusty

« back to all changes in this revision

Viewing changes to src/netsys/netsys.ml

  • Committer: Bazaar Package Importer
  • Author(s): Stéphane Glondu
  • Date: 2011-09-02 14:12:33 UTC
  • mfrom: (18.2.3 sid)
  • Revision ID: james.westby@ubuntu.com-20110902141233-zbj0ygxb92u6gy4z
Tags: 3.4-1
http://bugs.debian.org/637147
* New upstream release
  - add a new NetcgiRequire directive to ease dependency management
    (Closes: #637147)
  - remove patches that were applied upstream:
    + Added-missing-shebang-lines-in-example-shell-scripts
    + Try-also-ocamlc-for-POSIX-threads

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/netsys/netsys.ml
1
 
(* $Id: netsys.ml 1121 2007-05-06 18:20:37Z gerd $ *)
2
 
 
3
 
open Unix
4
 
 
5
 
let rec restart f arg =
6
 
  try 
7
 
    f arg
8
 
  with
9
 
    | Unix.Unix_error(Unix.EINTR,_,_) ->
10
 
        restart f arg
 
1
(* $Id: netsys.ml 1662 2011-08-29 23:05:06Z gerd $ *)
 
2
 
 
3
open Printf
 
4
 
 
5
module Debug = struct
 
6
  let enable = ref false
 
7
end
 
8
 
 
9
let dlog = Netlog.Debug.mk_dlog "Netsys" Debug.enable
 
10
let dlogr = Netlog.Debug.mk_dlogr "Netsys" Debug.enable
 
11
 
 
12
let () =
 
13
  Netlog.Debug.register_module "Netsys" Debug.enable
 
14
 
 
15
 
 
16
exception Shutdown_not_supported
 
17
 
 
18
let is_win32 =
 
19
  Sys.os_type = "Win32"
 
20
 
 
21
external netsys_is_darwin : unit -> bool = "netsys_is_darwin"
 
22
 
 
23
let is_darwin =
 
24
  netsys_is_darwin()
 
25
 
 
26
external int64_of_file_descr : Unix.file_descr -> int64
 
27
  = "netsys_int64_of_file_descr"
 
28
  (* Also occurs in netsys_win32.ml! *)
 
29
 
 
30
let is_letter =
 
31
  function
 
32
    | 'a'..'z' -> true
 
33
    | 'A'..'Z' -> true
 
34
    | _ -> false
 
35
 
 
36
let is_absolute path =
 
37
  if is_win32 then
 
38
    (String.length path >= 3 &&
 
39
      is_letter path.[0] &&
 
40
      path.[1] = ':' &&
 
41
        (path.[2] = '/' || path.[2] = '\\')
 
42
    ) ||
 
43
      (String.length path >= 2 &&
 
44
         (path.[0] = '/' || path.[0] = '\\') &&
 
45
         (path.[1] = '/' || path.[1] = '\\')
 
46
      )
 
47
  else
 
48
    path <> "" && path.[0] = '/'
 
49
 
 
50
 
 
51
let restart = Netsys_impl_util.restart
 
52
let restart_tmo = Netsys_impl_util.restart_tmo
11
53
 
12
54
let restarting_select fd_rd fd_wr fd_oob tmo =
13
 
  let t0 = Unix.gettimeofday() in
14
 
  
15
 
  let rec tryagain t_elapsed =
16
 
    let tmo' = tmo -. t_elapsed in
17
 
    if tmo' >= 0.0 then
18
 
      try
19
 
        Unix.select fd_rd fd_wr fd_oob tmo'
20
 
      with
21
 
        | Unix.Unix_error(Unix.EINTR,_,_) ->
22
 
            let t1 = Unix.gettimeofday() in
23
 
            tryagain (t1 -. t0)
24
 
    else
25
 
      ([], [], [])
26
 
  in
27
 
 
28
 
  if tmo > 0.0 then
29
 
    tryagain 0.0
30
 
  else
31
 
    restart (Unix.select fd_rd fd_wr fd_oob) tmo
32
 
 
33
 
 
34
 
let rec really_write fd s pos len =
35
 
  if len > 0 then
36
 
    try
37
 
      let n = Unix.single_write fd s pos len in
38
 
      really_write fd s (pos+n) (len-n)
39
 
    with
40
 
      | Unix.Unix_error(Unix.EINTR, _, _) ->
41
 
          really_write fd s pos len
42
 
      | Unix.Unix_error( (Unix.EAGAIN | Unix.EWOULDBLOCK), _, _) ->
43
 
          ignore(restart (Unix.select [] [fd] []) (-1.0));
44
 
          really_write fd s pos len
45
 
  else
46
 
    ()
47
 
 
48
 
 
49
 
let blocking_read fd s pos len =
 
55
  restart_tmo (Unix.select fd_rd fd_wr fd_oob) tmo
 
56
 
 
57
let sleep t =
 
58
  let select =
 
59
    if is_win32 then Netsys_win32.real_select else Unix.select in
 
60
  let _,_,_ =
 
61
    select [] [] [] t in
 
62
  ()
 
63
 
 
64
let restarting_sleep t =
 
65
  restart_tmo sleep t
 
66
 
 
67
 
 
68
let getpeername fd =
 
69
  try
 
70
    Unix.getpeername fd
 
71
  with
 
72
    | Unix.Unix_error(Unix.EINVAL,a1,a2) ->
 
73
        (* SUS defines EINVAL as "socket has been shut down". This is a bit
 
74
         * surprising for developers of Open Source OS where this is reported
 
75
         * as ENOTCONN. We map it here.
 
76
         *)
 
77
        raise(Unix.Unix_error(Unix.ENOTCONN,a1,a2))
 
78
 
 
79
 
 
80
type fd_style =
 
81
    [ `Read_write
 
82
    | `Recv_send of Unix.sockaddr * Unix.sockaddr
 
83
    | `Recv_send_implied
 
84
    | `Recvfrom_sendto
 
85
    | `W32_pipe
 
86
    | `W32_pipe_server
 
87
    | `W32_event
 
88
    | `W32_process
 
89
    | `W32_input_thread
 
90
    | `W32_output_thread
 
91
    ]
 
92
 
 
93
 
 
94
let get_fd_style fd =
 
95
  let w32_obj_opt =
 
96
    try Some(Netsys_win32.lookup fd)
 
97
    with Not_found -> None in
 
98
  match w32_obj_opt with
 
99
    | Some (Netsys_win32.W32_pipe _) ->
 
100
        `W32_pipe
 
101
    | Some (Netsys_win32.W32_pipe_server _) ->
 
102
        `W32_pipe_server
 
103
    | Some (Netsys_win32.W32_event _) ->
 
104
        `W32_event
 
105
    | Some (Netsys_win32.W32_process _) ->
 
106
        `W32_process
 
107
    | Some (Netsys_win32.W32_input_thread _) ->
 
108
        `W32_input_thread
 
109
    | Some (Netsys_win32.W32_output_thread _) ->
 
110
        `W32_output_thread
 
111
    | None ->
 
112
        (* Check whether we have a socket or not: *)
 
113
        try
 
114
          let _socktype = Unix.getsockopt_int fd Unix.SO_TYPE in
 
115
          (* Now check whether the socket is connected or not: *)
 
116
          try
 
117
            let sockaddr = Unix.getsockname fd in
 
118
            let peeraddr = getpeername fd in
 
119
            (* fd is a connected socket *)
 
120
            `Recv_send(sockaddr,peeraddr)
 
121
          with
 
122
            | Unix.Unix_error(Unix.ENOTCONN,_,_) ->
 
123
                (* fd is an unconnected socket *)
 
124
                `Recvfrom_sendto
 
125
            | Unix.Unix_error(Unix.ENOTSOCK,_,_) -> 
 
126
                failwith "Got unexpected ENOTSOCK" (* hopefully we never see this *)
 
127
            | _e ->
 
128
                (* There are various error codes in use for socket types that
 
129
                   do not use addresses, e.g. socketpairs are considered
 
130
                   as not having addresses by some OS. Common are
 
131
                   EAFNOSUPPORT, EOPNOTSUPP, EINVAL. For simplicity we catch
 
132
                   here all, which is allowed as we already know that fd is a
 
133
                   socket.
 
134
                 *)
 
135
                `Recv_send_implied
 
136
        with
 
137
          | Unix.Unix_error((Unix.ENOTSOCK|Unix.EINVAL),_,_) -> 
 
138
              (* Note: EINVAL is used by some oldish OS in this case *)
 
139
              (* fd is not a socket *)
 
140
              `Read_write
 
141
          | Unix.Unix_error((Unix.ENOENT,_,_)) when is_win32 -> 
 
142
              `Read_write
 
143
          | e ->
 
144
              Netlog.log `Crit 
 
145
                ("get_fd_style: Exception: " ^ Netexn.to_string e);
 
146
              assert false
 
147
 
 
148
let string_of_sockaddr =
 
149
  function
 
150
    | Unix.ADDR_INET(inet,port) as addr ->
 
151
        ( match Unix.domain_of_sockaddr addr with
 
152
            | Unix.PF_INET ->
 
153
                Unix.string_of_inet_addr inet ^ ":" ^ string_of_int port
 
154
            | Unix.PF_INET6 ->
 
155
                "[" ^ Unix.string_of_inet_addr inet ^ "]:" ^ string_of_int port
 
156
            | _ ->
 
157
                assert false
 
158
        )
 
159
    | Unix.ADDR_UNIX path ->
 
160
        String.escaped path
 
161
 
 
162
let string_of_fd_style =
 
163
  function
 
164
    | `Read_write -> "Read_write"
 
165
    | `Recv_send (sockaddr,peeraddr) ->
 
166
        "Recv_send(" ^ string_of_sockaddr sockaddr ^ "," ^ 
 
167
          string_of_sockaddr peeraddr ^ ")"
 
168
    | `Recv_send_implied -> "Recv_send_implied"
 
169
    | `Recvfrom_sendto -> "Recvfrom_sendto"
 
170
    | `W32_pipe -> "W32_pipe"
 
171
    | `W32_pipe_server -> "W32_pipe_server"
 
172
    | `W32_event -> "W32_event"
 
173
    | `W32_process -> "W32_process" 
 
174
    | `W32_input_thread -> "W32_input_thread"
 
175
    | `W32_output_thread -> "W32_output_thread"
 
176
 
 
177
let string_of_fd fd =
 
178
  let st = get_fd_style fd in
 
179
  let fdi = int64_of_file_descr fd in
 
180
  match st with
 
181
    | `Read_write ->
 
182
        sprintf "fd<%Ld>" fdi
 
183
    | `Recv_send(sockaddr,peeraddr) ->
 
184
        sprintf "fd<%Ld=socket(%s,%s)>" 
 
185
          fdi (string_of_sockaddr sockaddr) (string_of_sockaddr peeraddr)
 
186
    | `Recv_send_implied ->
 
187
        sprintf "fd<%Ld=socket>" fdi
 
188
    | `Recvfrom_sendto ->
 
189
        sprintf "fd<%Ld=socket>" fdi
 
190
    | `W32_pipe ->
 
191
        let p = Netsys_win32.lookup_pipe fd in
 
192
        sprintf "fd<%Ld=w32_pipe(%s)>" fdi (Netsys_win32.pipe_name p)
 
193
    | `W32_pipe_server ->
 
194
        let p = Netsys_win32.lookup_pipe_server fd in
 
195
        sprintf "fd<%Ld=w32_pipe_server(%s)>" 
 
196
          fdi (Netsys_win32.pipe_server_name p)
 
197
    | `W32_event ->
 
198
        sprintf "fd<%Ld=w32_event>" fdi
 
199
    | `W32_process ->
 
200
        let p = Netsys_win32.lookup_process fd in
 
201
        sprintf "fd<%Ld=w32_process(%d)>" fdi (Netsys_win32.win_pid p)
 
202
    | `W32_input_thread ->
 
203
        sprintf "fd<%Ld=w32_input_thread>" fdi
 
204
    | `W32_output_thread ->
 
205
        sprintf "fd<%Ld=w32_output_thread>" fdi
 
206
 
 
207
 
 
208
let wait_until_readable fd_style fd tmo =
 
209
  dlogr (fun () -> sprintf "wait_until_readable fd=%Ld tmo=%f"
 
210
           (int64_of_file_descr fd) tmo);
 
211
  if Netsys_posix.have_poll() then
 
212
    restart_tmo
 
213
      (Netsys_posix.poll_single fd true false false) tmo
 
214
  else
 
215
    match fd_style with
 
216
      | `Read_write when is_win32 ->  (* effectively not supported! *)
 
217
          true
 
218
      | `W32_pipe ->
 
219
          let ph = Netsys_win32.lookup_pipe fd in
 
220
          Netsys_win32.pipe_wait_rd ph tmo
 
221
      | `W32_pipe_server ->
 
222
          let ph = Netsys_win32.lookup_pipe_server fd in
 
223
          Netsys_win32.pipe_wait_connect ph tmo
 
224
      | `W32_event ->
 
225
          let eo = Netsys_win32.lookup_event fd in
 
226
          Netsys_win32.event_wait eo tmo
 
227
      | `W32_input_thread ->
 
228
          let ithr = Netsys_win32.lookup_input_thread fd in
 
229
          let eo = Netsys_win32.input_thread_event ithr in
 
230
          Netsys_win32.event_wait eo tmo
 
231
      | `W32_process
 
232
      | `W32_output_thread ->
 
233
          sleep tmo; false (* never *)
 
234
      | _ ->
 
235
          let l,_,_ = restart_tmo (Unix.select [fd] [] []) tmo in
 
236
          l <> []
 
237
 
 
238
let wait_until_writable fd_style fd tmo =
 
239
  dlogr (fun () -> sprintf "wait_until_writable fd=%Ld tmo=%f"
 
240
           (int64_of_file_descr fd) tmo);
 
241
  if Netsys_posix.have_poll() then
 
242
    restart_tmo
 
243
      (Netsys_posix.poll_single fd false true false) tmo
 
244
  else
 
245
    match fd_style with
 
246
      | `Read_write when is_win32 ->  (* effectively not supported! *)
 
247
          true
 
248
      | `W32_pipe ->
 
249
          let ph = Netsys_win32.lookup_pipe fd in
 
250
          Netsys_win32.pipe_wait_wr ph tmo
 
251
      | `W32_pipe_server ->
 
252
          let ph = Netsys_win32.lookup_pipe_server fd in
 
253
          Netsys_win32.pipe_wait_connect ph tmo
 
254
      | `W32_event ->
 
255
          let eo = Netsys_win32.lookup_event fd in
 
256
          Netsys_win32.event_wait eo tmo
 
257
      | `W32_output_thread ->
 
258
          let othr = Netsys_win32.lookup_output_thread fd in
 
259
          let eo = Netsys_win32.output_thread_event othr in
 
260
          Netsys_win32.event_wait eo tmo
 
261
      | `W32_input_thread 
 
262
      | `W32_process ->
 
263
          sleep tmo; false (* never *)
 
264
      | _ ->
 
265
          let _,l,_ = restart_tmo (Unix.select [] [fd] []) tmo in
 
266
          l <> []
 
267
 
 
268
let wait_until_prird fd_style fd tmo =
 
269
  dlogr (fun () -> sprintf "wait_until_prird fd=%Ld tmo=%f"
 
270
           (int64_of_file_descr fd) tmo);
 
271
  if Netsys_posix.have_poll() then
 
272
    restart_tmo
 
273
      (Netsys_posix.poll_single fd false false true) tmo
 
274
  else
 
275
    match fd_style with
 
276
      | `Read_write when is_win32 ->  (* effectively not supported! *)
 
277
          true
 
278
      | `W32_pipe ->
 
279
          sleep tmo; false (* never *)
 
280
      | `W32_pipe_server ->
 
281
          let ph = Netsys_win32.lookup_pipe_server fd in
 
282
          Netsys_win32.pipe_wait_connect ph tmo
 
283
      | `W32_event ->
 
284
          let eo = Netsys_win32.lookup_event fd in
 
285
          Netsys_win32.event_wait eo tmo
 
286
      | `W32_input_thread
 
287
      | `W32_output_thread
 
288
      | `W32_process ->
 
289
          sleep tmo; false (* never *)
 
290
      | _ ->
 
291
          let _,_,l = restart_tmo (Unix.select [] [] [fd]) tmo in
 
292
          l <> []
 
293
 
 
294
 
 
295
let is_readable fd_style fd = wait_until_readable fd_style fd 0.0
 
296
let is_writable fd_style fd = wait_until_writable fd_style fd 0.0
 
297
let is_prird fd_style fd = wait_until_prird fd_style fd 0.0
 
298
 
 
299
 
 
300
let gwrite fd_style fd s pos len =
 
301
  dlogr (fun () -> sprintf "gwrite fd=%Ld len=%d"
 
302
           (int64_of_file_descr fd) len);
 
303
  match fd_style with
 
304
    | `Read_write ->
 
305
        Unix.single_write fd s pos len
 
306
    | `Recv_send _ 
 
307
    | `Recv_send_implied ->
 
308
        Unix.send fd s pos len []
 
309
    | `Recvfrom_sendto ->
 
310
        failwith "Netsys.gwrite: the socket is unconnected"
 
311
    | `W32_pipe ->
 
312
        let ph = Netsys_win32.lookup_pipe fd in
 
313
        Netsys_win32.pipe_write ph s pos len
 
314
    | `W32_pipe_server ->
 
315
        failwith "Netsys.gwrite: cannot write to pipe servers"
 
316
    | `W32_event ->
 
317
        failwith "Netsys.gwrite: cannot write to event descriptor"
 
318
    | `W32_process ->
 
319
        failwith "Netsys.gwrite: cannot write to process descriptor"
 
320
    | `W32_input_thread ->
 
321
        failwith "Netsys.gwrite: cannot write to input thread"
 
322
    | `W32_output_thread ->
 
323
        let othr = Netsys_win32.lookup_output_thread fd in
 
324
        Netsys_win32.output_thread_write othr s pos len
 
325
 
 
326
 
 
327
let rec really_gwrite fd_style fd s pos len =
 
328
  try
 
329
    let n = gwrite fd_style fd s pos len in
 
330
    if n > 0 then
 
331
      really_gwrite fd_style fd s (pos+n) (len-n)
 
332
  with
 
333
    | Unix.Unix_error(Unix.EINTR, _, _) ->
 
334
        really_gwrite fd_style fd s pos len
 
335
    | Unix.Unix_error( (Unix.EAGAIN | Unix.EWOULDBLOCK), _, _) ->
 
336
        ignore(wait_until_writable fd_style fd (-1.0));
 
337
        really_gwrite fd_style fd s pos len
 
338
 
 
339
 
 
340
let gread fd_style fd s pos len =
 
341
  dlogr (fun () -> sprintf "gread fd=%Ld len=%d"
 
342
           (int64_of_file_descr fd) len);
 
343
  match fd_style with
 
344
    | `Read_write ->
 
345
        Unix.read fd s pos len
 
346
    | `Recv_send _ 
 
347
    | `Recv_send_implied ->
 
348
        Unix.recv fd s pos len []
 
349
    | `Recvfrom_sendto ->
 
350
        failwith "Netsys.gread: the socket is unconnected"
 
351
    | `W32_pipe ->
 
352
        let ph = Netsys_win32.lookup_pipe fd in
 
353
        Netsys_win32.pipe_read ph s pos len
 
354
    | `W32_pipe_server ->
 
355
        failwith "Netsys.gwrite: cannot read from pipe servers"
 
356
    | `W32_event ->
 
357
        failwith "Netsys.gread: cannot read from event descriptor"
 
358
    | `W32_process ->
 
359
        failwith "Netsys.gread: cannot read from process descriptor"
 
360
    | `W32_output_thread ->
 
361
        failwith "Netsys.gread: cannot read from output thread"
 
362
    | `W32_input_thread ->
 
363
        let ithr = Netsys_win32.lookup_input_thread fd in
 
364
        Netsys_win32.input_thread_read ithr s pos len
 
365
 
 
366
let blocking_gread fd_style fd s pos len =
50
367
  let rec loop pos len p =
51
 
    if len > 0 then
 
368
    if len >= 0 then
52
369
      try
53
 
        let n = Unix.read fd s pos len in
 
370
        let n = gread fd_style fd s pos len in
54
371
        if n=0 then
55
372
          p
56
373
        else
59
376
        | Unix.Unix_error(Unix.EINTR, _, _) ->
60
377
            loop pos len p
61
378
        | Unix.Unix_error( (Unix.EAGAIN | Unix.EWOULDBLOCK), _, _) ->
62
 
            ignore(restart (Unix.select [fd] [] []) (-1.0));
 
379
            ignore(wait_until_readable fd_style fd (-1.0));
63
380
            loop pos len p
64
381
    else
65
382
      p
67
384
  loop pos len 0
68
385
 
69
386
 
70
 
let really_read fd s pos len =
71
 
  if len > 0 then
72
 
    let p = blocking_read fd s pos len in
73
 
    if p < len then raise End_of_file;
74
 
    ()
75
 
  else
76
 
    ()
77
 
 
 
387
let really_gread fd_style fd s pos len =
 
388
  let p = blocking_gread fd_style fd s pos len in
 
389
  if p < len then raise End_of_file;
 
390
  ()
 
391
 
 
392
 
 
393
let wait_until_connected fd tmo =
 
394
  dlogr (fun () -> sprintf "wait_until_connected fd=%Ld tmo=%f"
 
395
           (int64_of_file_descr fd) tmo);
 
396
  if is_win32 then
 
397
    try
 
398
      let w32 = Netsys_win32.lookup fd in
 
399
      ( match w32 with
 
400
          | Netsys_win32.W32_pipe _ -> true   (* immediately connected *)
 
401
          | _ ->
 
402
              failwith "Netsys.wait_until_connected: bad descriptor type"
 
403
      )
 
404
    with
 
405
      | Not_found ->  (* socket case *)
 
406
          let l1,_,l2 = Netsys_win32.real_select [] [fd] [fd] tmo in
 
407
          l1 <> [] || l2 <> []
 
408
  else
 
409
    wait_until_writable `Recv_send fd tmo
 
410
 
 
411
 
 
412
let catch_exn label getdetail f arg =
 
413
  try
 
414
    f arg
 
415
  with
 
416
    | error ->
 
417
        let detail = getdetail arg in
 
418
        ( try  (* be careful here, logging might not work *)
 
419
            Netlog.logf `Crit
 
420
              "%s (%s): Exception %s"
 
421
              label detail (Netexn.to_string error)
 
422
          with
 
423
            | _ -> ()
 
424
        )
 
425
 
 
426
let is_std fd std_fd std_num =
 
427
  if is_win32 then
 
428
    Netsys_win32.is_crt_fd fd std_num
 
429
  else
 
430
    fd = std_fd
 
431
 
 
432
let is_stdin fd = is_std fd Unix.stdin 0
 
433
let is_stdout fd = is_std fd Unix.stdout 1
 
434
let is_stderr fd = is_std fd Unix.stderr 2
 
435
 
 
436
let set_close_on_exec fd =
 
437
  if is_win32 then
 
438
    Netsys_win32.modify_close_on_exec fd true
 
439
  else
 
440
    Unix.set_close_on_exec fd
 
441
 
 
442
 
 
443
let clear_close_on_exec fd =
 
444
  if is_win32 then
 
445
    Netsys_win32.modify_close_on_exec fd false
 
446
  else
 
447
    Unix.clear_close_on_exec fd
 
448
 
 
449
 
 
450
let gshutdown fd_style fd cmd =
 
451
  dlogr (fun () -> sprintf "gshutdown fd=%Ld cmd=%s"
 
452
           (int64_of_file_descr fd) 
 
453
           (match cmd with
 
454
              | Unix.SHUTDOWN_SEND -> "SEND"
 
455
              | Unix.SHUTDOWN_RECEIVE -> "RECEIVE"
 
456
              | Unix.SHUTDOWN_ALL -> "ALL"
 
457
           )
 
458
        );
 
459
  match fd_style with
 
460
    | `Recv_send _
 
461
    | `Recv_send_implied ->
 
462
        ( try
 
463
            Unix.shutdown fd cmd
 
464
          with
 
465
            | Unix.Unix_error(Unix.ENOTCONN, _, _) -> ()
 
466
        )
 
467
    | `W32_pipe ->
 
468
        if cmd <> Unix.SHUTDOWN_ALL then
 
469
          raise(Unix.Unix_error(Unix.EPERM, "Netsys.gshutdown", ""));
 
470
        let p = Netsys_win32.lookup_pipe fd in
 
471
        Netsys_win32.pipe_shutdown p
 
472
    | `W32_pipe_server ->
 
473
        if cmd <> Unix.SHUTDOWN_ALL then
 
474
          raise(Unix.Unix_error(Unix.EPERM, "Netsys.gshutdown", ""));
 
475
        let p = Netsys_win32.lookup_pipe_server fd in
 
476
        Netsys_win32.pipe_shutdown_server p
 
477
    | `W32_output_thread ->
 
478
        if cmd <> Unix.SHUTDOWN_RECEIVE then (
 
479
          let othr = Netsys_win32.lookup_output_thread fd in
 
480
          Netsys_win32.close_output_thread othr
 
481
        )
 
482
    | _ ->
 
483
        raise Shutdown_not_supported
 
484
 
 
485
 
 
486
let gclose fd_style fd =
 
487
  dlogr (fun () -> sprintf "gclose fd=%Ld" (int64_of_file_descr fd));
 
488
  let fd_detail fd =
 
489
    Printf.sprintf "fd %Ld" (int64_of_file_descr fd) in
 
490
  let pipe_detail (fd,p) =
 
491
    Printf.sprintf "fd %Ld as pipe %s" 
 
492
      (int64_of_file_descr fd)
 
493
      (Netsys_win32.pipe_name p) in
 
494
  let psrv_detail (fd,p) =
 
495
    Printf.sprintf "fd %Ld as pipe server %s" 
 
496
      (int64_of_file_descr fd)
 
497
      (Netsys_win32.pipe_server_name p) in
 
498
  let ithr_detail (fd,p) =
 
499
    Printf.sprintf "fd %Ld as input thread for %Ld" 
 
500
      (int64_of_file_descr fd)
 
501
      (int64_of_file_descr(Netsys_win32.input_thread_descr p)) in
 
502
  let othr_detail (fd,p) =
 
503
    Printf.sprintf "fd %Ld as output thread for %Ld" 
 
504
      (int64_of_file_descr fd)
 
505
      (int64_of_file_descr(Netsys_win32.output_thread_descr p)) in
 
506
  match fd_style with
 
507
    | `Read_write 
 
508
    | `Recvfrom_sendto ->
 
509
        catch_exn
 
510
          "Unix.close" fd_detail
 
511
          Unix.close fd
 
512
    | `Recv_send _
 
513
    | `Recv_send_implied ->
 
514
        catch_exn
 
515
          "Unix.shutdown" fd_detail
 
516
          (fun fd ->
 
517
             try
 
518
               Unix.shutdown fd Unix.SHUTDOWN_ALL
 
519
             with
 
520
               | Unix.Unix_error(Unix.ENOTCONN, _, _) -> ()
 
521
          )
 
522
          fd;
 
523
        catch_exn
 
524
          "Unix.close" fd_detail
 
525
          Unix.close fd
 
526
    | `W32_pipe ->
 
527
        let p = Netsys_win32.lookup_pipe fd in
 
528
        catch_exn
 
529
          "Netsys_win32.pipe_shutdown" pipe_detail
 
530
          (fun (fd,p) -> Netsys_win32.pipe_shutdown p)
 
531
          (fd,p);
 
532
        catch_exn
 
533
          "Unix.close" fd_detail
 
534
          Unix.close fd;
 
535
        Netsys_win32.unregister fd
 
536
    | `W32_pipe_server ->
 
537
        let p = Netsys_win32.lookup_pipe_server fd in
 
538
        catch_exn
 
539
          "Netsys_win32.pipe_server_shutdown" psrv_detail
 
540
          (fun (fd,p) -> Netsys_win32.pipe_shutdown_server p)
 
541
          (fd,p);
 
542
        catch_exn
 
543
          "Unix.close" fd_detail
 
544
          Unix.close fd;
 
545
        Netsys_win32.unregister fd
 
546
    | `W32_event | `W32_process ->
 
547
        (* Events are automatically closed *)
 
548
        catch_exn
 
549
          "Unix.close" fd_detail
 
550
          Unix.close fd;
 
551
        Netsys_win32.unregister fd
 
552
    | `W32_input_thread ->
 
553
        let ithr = Netsys_win32.lookup_input_thread fd in
 
554
        catch_exn
 
555
          "Netsys_win32.cancel_input_thread" ithr_detail
 
556
          (fun (fd,ithr) -> Netsys_win32.cancel_input_thread ithr)
 
557
          (fd,ithr);
 
558
        catch_exn
 
559
          "Unix.close" fd_detail
 
560
          Unix.close fd;
 
561
        Netsys_win32.unregister fd
 
562
    | `W32_output_thread ->
 
563
        let othr = Netsys_win32.lookup_output_thread fd in
 
564
        catch_exn
 
565
          "Netsys_win32.cancel_output_thread" othr_detail
 
566
          (fun (fd,othr) -> Netsys_win32.cancel_output_thread othr)
 
567
          (fd,othr);
 
568
        catch_exn
 
569
          "Unix.close" fd_detail
 
570
          Unix.close fd;
 
571
        Netsys_win32.unregister fd
 
572
 
 
573
 
 
574
 
 
575
external unix_error_of_code : int -> Unix.error = "netsys_unix_error_of_code"
 
576
 
 
577
 
 
578
let connect_check fd =
 
579
  let do_check =
 
580
    if is_win32 then
 
581
      try
 
582
        let w32 = Netsys_win32.lookup fd in
 
583
        ( match w32 with
 
584
            | Netsys_win32.W32_pipe _ -> false  (* immediately connected *)
 
585
            | _ ->
 
586
                failwith "Netsys.connect_check: bad descriptor type"
 
587
      )
 
588
    with
 
589
      | Not_found ->  (* socket case *)
 
590
          true
 
591
    else
 
592
      true in
 
593
  if do_check then (
 
594
    let e_code = Unix.getsockopt_int fd Unix.SO_ERROR in
 
595
    try
 
596
      ignore(getpeername fd); 
 
597
      ()
 
598
    with
 
599
      | Unix.Unix_error(Unix.ENOTCONN,_,_) ->
 
600
          let detail =
 
601
            try
 
602
              let own_addr = Unix.getsockname fd in
 
603
              string_of_sockaddr own_addr
 
604
            with _ -> "n/a" in
 
605
          raise(Unix.Unix_error(unix_error_of_code e_code,
 
606
                                "connect_check", detail))
 
607
  )
 
608
 
 
609
(* Misc *)
78
610
 
79
611
let domain_of_inet_addr addr =
80
612
  Unix.domain_of_sockaddr(Unix.ADDR_INET(addr,0))
81
613
 
82
 
 
83
 
(* Misc *)
84
 
 
85
 
let int_of_file_descr =
86
 
  match Sys.os_type with
87
 
    | "Unix" | "Cygwin" ->
88
 
        (fun fd -> (Obj.magic (fd:file_descr) : int))
89
 
    | _ ->
90
 
        invalid_arg "Netsys.int_of_file_descr"
91
 
 
92
 
let file_descr_of_int =
93
 
  match Sys.os_type with
94
 
    | "Unix" | "Cygwin" ->
95
 
        (fun n -> (Obj.magic (n:int) : file_descr))
96
 
    | _ ->
97
 
        invalid_arg "Netsys.file_descr_of_int"
98
 
 
 
614
let protostring_of_inet_addr ip = (Obj.magic ip)
 
615
 
 
616
let inet_addr_of_protostring s =
 
617
  let l = String.length s in
 
618
  if l = 4 || l = 16 then (Obj.magic s) else
 
619
    invalid_arg "Netsys.inet_addr_of_protostring"
99
620
 
100
621
external _exit : int -> unit = "netsys__exit";;
101
 
 
102
 
(* Limits  & resources *)
103
 
 
104
 
external sysconf_open_max : unit -> int = "netsys_sysconf_open_max";;
105
 
 
106
 
(* Process groups, sessions, terminals *)
107
 
 
108
 
external getpgid : int -> int = "netsys_getpgid";;
109
 
let getpgrp() = getpgid 0;;
110
 
external setpgid : int -> int -> unit = "netsys_setpgid";;
111
 
let setpgrp() = setpgid 0 0;;
112
 
 
113
 
external tcgetpgrp : file_descr -> int = "netsys_tcgetpgrp";;
114
 
external tcsetpgrp : file_descr -> int -> unit = "netsys_tcsetpgrp";;
115
 
 
116
 
external ctermid : unit -> string = "netsys_ctermid";;
117
 
external ttyname : file_descr -> string = "netsys_ttyname";;
118
 
 
119
 
external getsid : int -> int = "netsys_getsid";;
120
 
 
121
 
(* Users and groups *)
122
 
 
123
 
external setreuid : int -> int -> unit = "netsys_setreuid";;
124
 
external setregid : int -> int -> unit = "netsys_setregid";;
125
 
 
126
 
(* POSIX shared memory *)
127
 
 
128
 
external have_posix_shm : unit -> bool = "netsys_have_posix_shm"
129
 
type shm_open_flag =
 
622
(* same external also in netsys_signal.ml *)
 
623
 
 
624
 
 
625
external mcast_set_loop : Unix.file_descr -> bool -> unit 
 
626
  = "netsys_mcast_set_loop"
 
627
external mcast_set_ttl : Unix.file_descr -> int -> unit 
 
628
  = "netsys_mcast_set_ttl"
 
629
external mcast_add_membership : 
 
630
  Unix.file_descr -> Unix.inet_addr -> Unix.inet_addr -> unit 
 
631
  = "netsys_mcast_add_membership"
 
632
external mcast_drop_membership : 
 
633
  Unix.file_descr -> Unix.inet_addr -> Unix.inet_addr -> unit 
 
634
  = "netsys_mcast_drop_membership"
 
635
 
 
636
 
 
637
let f_moncontrol = ref (fun _ -> ())
 
638
 
 
639
let moncontrol b =
 
640
  !f_moncontrol b
 
641
 
 
642
let set_moncontrol f =
 
643
  f_moncontrol := f
 
644
 
 
645
 
 
646
 
 
647
(* Compatibility with older ocamlnet versions *)
 
648
 
 
649
let really_write = really_gwrite `Read_write
 
650
let blocking_read = blocking_gread `Read_write
 
651
let really_read = really_gread `Read_write
 
652
 
 
653
let int_of_file_descr = Netsys_posix.int_of_file_descr
 
654
let file_descr_of_int = Netsys_posix.file_descr_of_int
 
655
 
 
656
let have_posix_shm = Netsys_posix.have_posix_shm
 
657
 
 
658
type shm_open_flag = 
 
659
    Netsys_posix.shm_open_flag =
130
660
  | SHM_O_RDONLY
131
661
  | SHM_O_RDWR
132
662
  | SHM_O_CREAT
133
663
  | SHM_O_EXCL
134
664
  | SHM_O_TRUNC
135
 
external shm_open : string -> shm_open_flag list -> int -> file_descr
136
 
  = "netsys_shm_open"
137
 
external shm_unlink : string -> unit = "netsys_shm_unlink"
 
665
 
 
666
let shm_open = Netsys_posix.shm_open
 
667
let shm_unlink = Netsys_posix.shm_unlink