← Back to branch summary

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

« back to all changes in this revision

Viewing changes to src/netsys/netsys_posix.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_posix.ml
 
1
(* $Id: netsys_posix.ml 1629 2011-06-16 12:07:10Z gerd $ *)
 
2
 
 
3
open Unix
 
4
open Printf
 
5
 
 
6
 
 
7
module Debug = struct
 
8
  let enable = ref false
 
9
end
 
10
 
 
11
let dlog = Netlog.Debug.mk_dlog "Netsys_posix" Debug.enable
 
12
let dlogr = Netlog.Debug.mk_dlogr "Netsys_posix" Debug.enable
 
13
 
 
14
let () =
 
15
  Netlog.Debug.register_module "Netsys_posix" Debug.enable
 
16
 
 
17
external int64_of_file_descr : Unix.file_descr -> int64
 
18
  = "netsys_int64_of_file_descr"
 
19
 
 
20
let int_of_file_descr =
 
21
  match Sys.os_type with
 
22
    | "Unix" | "Cygwin" ->
 
23
        (fun fd -> (Obj.magic (fd:file_descr) : int))
 
24
    | _ ->
 
25
        (fun fd -> invalid_arg "Netsys.int_of_file_descr")
 
26
 
 
27
let file_descr_of_int =
 
28
  match Sys.os_type with
 
29
    | "Unix" | "Cygwin" ->
 
30
        (fun n -> (Obj.magic (n:int) : file_descr))
 
31
    | _ ->
 
32
        (fun n -> invalid_arg "Netsys.file_descr_of_int")
 
33
 
 
34
(* Limits  & resources *)
 
35
 
 
36
external sysconf_open_max : unit -> int = "netsys_sysconf_open_max";;
 
37
 
 
38
(* misc *)
 
39
 
 
40
external fchdir : Unix.file_descr -> unit = "netsys_fchdir" ;;
 
41
external fdopendir : Unix.file_descr -> Unix.dir_handle = "netsys_fdopendir" ;;
 
42
 
 
43
(* Process groups, sessions, terminals *)
 
44
 
 
45
external getpgid : int -> int = "netsys_getpgid";;
 
46
let getpgrp() = getpgid 0;;
 
47
external setpgid : int -> int -> unit = "netsys_setpgid";;
 
48
let setpgrp() = setpgid 0 0;;
 
49
 
 
50
external tcgetpgrp : file_descr -> int = "netsys_tcgetpgrp";;
 
51
external tcsetpgrp : file_descr -> int -> unit = "netsys_tcsetpgrp";;
 
52
 
 
53
external ctermid : unit -> string = "netsys_ctermid";;
 
54
external ttyname : file_descr -> string = "netsys_ttyname";;
 
55
 
 
56
external getsid : int -> int = "netsys_getsid";;
 
57
 
 
58
let with_tty f =
 
59
  let fd = 
 
60
    try Unix.openfile (ctermid()) [Unix.O_RDWR] 0 
 
61
    with _ -> failwith "Netsys_posix.with_tty: cannot open terminal" in
 
62
  try
 
63
    let r = f fd in
 
64
    Unix.close fd;
 
65
    r
 
66
  with error -> Unix.close fd; raise error
 
67
 
 
68
 
 
69
let descr_input_line fd = (* unbuffered! *)
 
70
  let b = Buffer.create 80 in
 
71
  let s = String.create 1 in
 
72
 
 
73
  let rec loop () =
 
74
    try
 
75
      let n = Unix.read fd s 0 1 in
 
76
      if n > 0 && s.[0] <> '\n' then (
 
77
        Buffer.add_string b s;
 
78
        raise(Unix.Unix_error(Unix.EINTR,"",""))
 
79
      )
 
80
    with
 
81
      | Unix.Unix_error(Unix.EINTR,_,_) ->
 
82
          loop()
 
83
  in
 
84
 
 
85
  loop();
 
86
  Buffer.contents b
 
87
 
 
88
 
 
89
 
 
90
let tty_read_password ?(tty=Unix.stdin) prompt =
 
91
  if Unix.isatty tty then (
 
92
    let cleanup = ref [] in
 
93
    let f = Unix.out_channel_of_descr tty in
 
94
    output_string f prompt;
 
95
    flush f;
 
96
    Unix.tcdrain tty;
 
97
    Unix.tcflush tty Unix.TCIFLUSH;
 
98
    let p = Unix.tcgetattr tty in
 
99
    try
 
100
      let p' =
 
101
        { p with
 
102
            Unix.c_echo = false;
 
103
            Unix.c_echoe = false;
 
104
            Unix.c_echok = false;
 
105
            Unix.c_echonl = false
 
106
        } in
 
107
      Unix.tcsetattr tty Unix.TCSAFLUSH p';
 
108
      cleanup := (fun () -> Unix.tcsetattr tty Unix.TCSAFLUSH p) :: !cleanup;
 
109
      let old_sigint = 
 
110
        Sys.signal Sys.sigint (Sys.Signal_handle(fun _ -> raise Sys.Break)) in
 
111
      cleanup := (fun () -> Sys.set_signal Sys.sigint old_sigint) :: !cleanup;
 
112
      let pw = descr_input_line tty in
 
113
      output_string f "\n";
 
114
      flush f;
 
115
      List.iter (fun f -> f()) !cleanup;
 
116
      pw
 
117
    with
 
118
      | error ->
 
119
          List.iter (fun f -> f()) !cleanup;
 
120
          if error = Sys.Break then (
 
121
            output_string f "\n";
 
122
            flush f
 
123
          );
 
124
          raise error
 
125
  )
 
126
  else
 
127
    descr_input_line tty
 
128
 
 
129
 
 
130
(* Users and groups *)
 
131
 
 
132
external setreuid : int -> int -> unit = "netsys_setreuid";;
 
133
external setregid : int -> int -> unit = "netsys_setregid";;
 
134
 
 
135
(* poll *)
 
136
 
 
137
external pollfd_size : unit -> int = "netsys_pollfd_size"
 
138
 
 
139
let the_pollfd_size = pollfd_size()
 
140
 
 
141
let _have_poll = the_pollfd_size > 0
 
142
let have_poll() = _have_poll
 
143
 
 
144
type poll_req_events = int
 
145
type poll_act_events = int
 
146
type poll_cell =
 
147
    { mutable poll_fd : Unix.file_descr;
 
148
      mutable poll_req_events : poll_req_events;
 
149
      mutable poll_act_events : poll_act_events;
 
150
    }
 
151
type poll_mem
 
152
type poll_array =
 
153
  | Poll_mem of poll_mem * int (*length*)
 
154
  | Poll_emu of poll_cell array
 
155
 
 
156
let null_poll_cell =
 
157
  { poll_fd = Unix.stdin;
 
158
    poll_req_events = 0;
 
159
    poll_act_events = 0
 
160
  }
 
161
 
 
162
external mk_poll_mem : int -> poll_mem
 
163
  = "netsys_mk_poll_mem"
 
164
 
 
165
external set_poll_mem : poll_mem -> int -> Unix.file_descr -> int -> int -> unit
 
166
  = "netsys_set_poll_mem"
 
167
 
 
168
external get_poll_mem : poll_mem -> int -> (Unix.file_descr * int * int)
 
169
  = "netsys_get_poll_mem"
 
170
 
 
171
external blit_poll_mem : poll_mem -> int -> poll_mem -> int -> int -> unit
 
172
  = "netsys_blit_poll_mem"
 
173
 
 
174
external poll_constants : unit -> int array = "netsys_poll_constants"
 
175
 
 
176
let the_poll_constants = poll_constants()
 
177
 
 
178
let const_rd_event = the_poll_constants.(0)
 
179
let const_pri_event = the_poll_constants.(1)
 
180
let const_wr_event = the_poll_constants.(2)
 
181
let const_err_event = the_poll_constants.(3)
 
182
let const_hup_event = the_poll_constants.(4)
 
183
let const_nval_event = the_poll_constants.(5)
 
184
 
 
185
let poll_req_events rd wr pri =
 
186
  (if rd then const_rd_event else 0) lor
 
187
  (if wr then const_wr_event else 0) lor
 
188
  (if pri then const_pri_event else 0)
 
189
 
 
190
let poll_req_triple p =
 
191
  (p land const_rd_event <> 0,
 
192
   p land const_wr_event <> 0,
 
193
   p land const_pri_event <> 0
 
194
  )
 
195
 
 
196
let poll_null_events() = 0
 
197
 
 
198
let poll_result p = p <> 0
 
199
let poll_rd_result p = p land const_rd_event <> 0
 
200
let poll_wr_result p = p land const_wr_event <> 0
 
201
let poll_pri_result p = p land const_pri_event <> 0
 
202
let poll_err_result p = p land const_err_event <> 0
 
203
let poll_hup_result p = p land const_hup_event <> 0
 
204
let poll_nval_result p = p land const_nval_event <> 0
 
205
 
 
206
let poll_array_length =
 
207
  function
 
208
    | Poll_mem(_,n) -> n
 
209
    | Poll_emu e -> Array.length e
 
210
 
 
211
let set_poll_cell a k c =
 
212
  if k < 0 || k >= poll_array_length a then
 
213
    invalid_arg "Netsys.set_poll_cell";
 
214
  match a with
 
215
    | Poll_mem(s,_) ->
 
216
        set_poll_mem s k c.poll_fd c.poll_req_events (* c.poll_revents *) 0 
 
217
    | Poll_emu e ->
 
218
        e.(k) <- { c with poll_fd = c.poll_fd } (* copy *)
 
219
 
 
220
let get_poll_cell a k =
 
221
  if k < 0 || k >= poll_array_length a then
 
222
    invalid_arg "Netsys.get_poll_cell";
 
223
  match a with
 
224
    | Poll_mem(s,_) ->
 
225
        let (fd, ev, rev) = get_poll_mem s k in
 
226
        { poll_fd = fd; poll_req_events = ev; poll_act_events = rev }
 
227
    | Poll_emu e ->
 
228
        let c = e.(k) in
 
229
        { c with poll_fd = c.poll_fd }   (* copy *)
 
230
 
 
231
let blit_poll_array a1 k1 a2 k2 len =
 
232
  let l1 = poll_array_length a1 in
 
233
  let l2 = poll_array_length a2 in
 
234
  if len < 0 || k1 < 0 || k1+len > l1 || k2 < 0 || k2+len > l2 then
 
235
    invalid_arg "Netsys.get_poll_cell";
 
236
  match (a1, a2) with
 
237
    | (Poll_mem(s1,_), Poll_mem(s2,_)) ->
 
238
        blit_poll_mem s1 k1 s2 k2 len
 
239
    | (Poll_emu e1, Poll_emu e2) ->
 
240
        Array.blit e1 k1 e2 k2 len
 
241
    | _ ->
 
242
        assert false
 
243
 
 
244
let create_poll_array n =
 
245
  if _have_poll then (
 
246
    let s = mk_poll_mem n in
 
247
    Poll_mem(s,n)
 
248
  )
 
249
  else (
 
250
    let e = Array.create n null_poll_cell in
 
251
    Poll_emu e
 
252
  )
 
253
 
 
254
external netsys_poll : poll_mem -> int -> int -> int = "netsys_poll"
 
255
 
 
256
 
 
257
let concat_fd_list l =
 
258
  String.concat "," 
 
259
    (List.map
 
260
       (fun fd -> 
 
261
          Int64.to_string(int64_of_file_descr fd))
 
262
       l
 
263
    )
 
264
 
 
265
 
 
266
(* win32 only: *)
 
267
external netsys_real_select : 
 
268
         Unix.file_descr list -> 
 
269
         Unix.file_descr list -> 
 
270
         Unix.file_descr list -> 
 
271
         float ->
 
272
           (Unix.file_descr list * Unix.file_descr list * Unix.file_descr list)
 
273
  = "netsys_real_select"
 
274
 
 
275
let real_select = 
 
276
  if Sys.os_type = "Win32" then
 
277
    netsys_real_select
 
278
  else
 
279
    Unix.select
 
280
 
 
281
 
 
282
let do_poll a k tmo =
 
283
  match a with
 
284
    | Poll_mem(s,_) ->
 
285
        netsys_poll s k tmo
 
286
    | Poll_emu e ->
 
287
        (* Emulate poll using Unix.select. This is slow! *)
 
288
        let tmo' =
 
289
          if tmo < 0 then (-1.0) else float tmo *. 0.001 in
 
290
        let l_inp = ref [] in
 
291
        let l_out = ref [] in
 
292
        let l_pri = ref [] in
 
293
        for j = 0 to k-1 do
 
294
          let c = e.(j) in
 
295
          let (f_inp, f_out, f_pri) = poll_req_triple c.poll_req_events in
 
296
          if f_inp then l_inp := c.poll_fd :: !l_inp;
 
297
          if f_out then l_out := c.poll_fd :: !l_out;
 
298
          if f_pri then l_pri := c.poll_fd :: !l_pri;
 
299
        done;
 
300
        dlogr (fun () ->
 
301
                 sprintf "poll_emulation request in=%s out=%s pri=%s tmo=%f"
 
302
                   (concat_fd_list !l_inp)
 
303
                   (concat_fd_list !l_out)
 
304
                   (concat_fd_list !l_pri)
 
305
                   tmo');
 
306
        let (o_inp, o_out, o_pri) = 
 
307
          real_select !l_inp !l_out !l_pri tmo' in
 
308
        dlogr (fun () ->
 
309
                 sprintf "poll_emulation result in=%s out=%s pri=%s"
 
310
                   (concat_fd_list o_inp)
 
311
                   (concat_fd_list o_out)
 
312
                   (concat_fd_list o_pri));
 
313
        let a_inp = Array.of_list o_inp in
 
314
        let a_out = Array.of_list o_out in
 
315
        let a_pri = Array.of_list o_pri in
 
316
        Array.sort Pervasives.compare a_inp;
 
317
        Array.sort Pervasives.compare a_out;
 
318
        Array.sort Pervasives.compare a_pri;
 
319
        let n = ref 0 in
 
320
        for j = 0 to k-1 do
 
321
          let c = e.(j) in
 
322
          let g_inp = Netsys_impl_util.mem_sorted_array c.poll_fd a_inp in
 
323
          let g_out = Netsys_impl_util.mem_sorted_array c.poll_fd a_out in
 
324
          let g_pri = Netsys_impl_util.mem_sorted_array c.poll_fd a_pri in
 
325
          let rev =
 
326
            (if g_inp then const_rd_event else 0) lor
 
327
            (if g_out then const_wr_event else 0) lor
 
328
            (if g_pri then const_pri_event else 0) in
 
329
          c.poll_act_events <- rev;
 
330
          if rev <> 0 then incr n
 
331
        done;
 
332
        !n
 
333
 
 
334
 
 
335
let poll a k tmo =
 
336
  if k < 0 || k > poll_array_length a then
 
337
    invalid_arg "Netsys.poll";
 
338
  let r =
 
339
    Netsys_impl_util.slice_time_ms
 
340
      (fun tmo0 ->
 
341
         (* tmo0 is now an int in milliseconds *)
 
342
         let n = do_poll a k tmo0 in
 
343
         if n = 0 then None else Some n
 
344
      )
 
345
      tmo in
 
346
  match r with
 
347
    | None -> 0
 
348
    | Some n -> n
 
349
 
 
350
 
 
351
let restarting_poll a k tmo =
 
352
  Netsys_impl_util.restart_tmo (poll a k) tmo
 
353
 
 
354
let poll_single fd r w pri tmo =
 
355
  let a = create_poll_array 1 in
 
356
  set_poll_cell a 0 { poll_fd = fd; 
 
357
                      poll_req_events = poll_req_events r w pri;
 
358
                      poll_act_events = poll_null_events()
 
359
                    };
 
360
  poll a 1 tmo > 0
 
361
 
 
362
 
 
363
let act_events_of_int n = n
 
364
let int_of_act_events n = n
 
365
 
 
366
let req_events_of_int n = n
 
367
let int_of_req_events n = n
 
368
 
 
369
 
 
370
(* post fork handlers *)
 
371
 
 
372
class type post_fork_handler =
 
373
object
 
374
  method name : string
 
375
  method run : unit -> unit
 
376
end
 
377
 
 
378
module PFH = struct
 
379
  type t = post_fork_handler
 
380
  let compare = Pervasives.compare
 
381
end
 
382
 
 
383
module PFH_Set = Set.Make(PFH)
 
384
 
 
385
let post_fork_registry = ref PFH_Set.empty
 
386
let post_fork_mutex = !Netsys_oothr.provider # create_mutex()
 
387
 
 
388
let register_post_fork_handler pfh =
 
389
  post_fork_mutex # lock();
 
390
  post_fork_registry := PFH_Set.add pfh !post_fork_registry;
 
391
  post_fork_mutex # unlock()
 
392
 
 
393
let remove_post_fork_handler pfh =
 
394
  post_fork_mutex # lock();
 
395
  post_fork_registry := PFH_Set.remove pfh !post_fork_registry;
 
396
  post_fork_mutex # unlock()
 
397
 
 
398
let run_post_fork_handlers() =
 
399
  PFH_Set.iter
 
400
    (fun pfh ->
 
401
       try pfh#run()
 
402
       with
 
403
         | error ->
 
404
             prerr_endline("Netsys_posix: Exception in post fork handler "
 
405
                           ^ pfh#name ^ ": " ^ Netexn.to_string error)
 
406
    )
 
407
    !post_fork_registry
 
408
 
 
409
 
 
410
(* "at" *)
 
411
 
 
412
type at_flag = AT_EACCESS | AT_SYMLINK_NOFOLLOW | AT_REMOVEDIR
 
413
 
 
414
(* The stubs assume these type definitions: *)
 
415
type open_flag1 = Unix.open_flag =
 
416
    O_RDONLY | O_WRONLY | O_RDWR | O_NONBLOCK | O_APPEND | O_CREAT | O_TRUNC
 
417
  | O_EXCL | O_NOCTTY | O_DSYNC | O_SYNC | O_RSYNC
 
418
 
 
419
type access_permission1 = Unix.access_permission =
 
420
    R_OK | W_OK | X_OK | F_OK
 
421
 
 
422
 
 
423
external netsys_at_fdcwd : unit -> Unix.file_descr =
 
424
    "netsys_at_fdcwd"
 
425
 
 
426
let at_fdcwd = netsys_at_fdcwd()
 
427
 
 
428
external have_at : unit -> bool 
 
429
  = "netsys_have_at"
 
430
external openat :  Unix.file_descr -> string -> Unix.open_flag list -> 
 
431
                   Unix.file_perm ->  Unix.file_descr
 
432
  = "netsys_openat"
 
433
external faccessat : Unix.file_descr -> string -> Unix.access_permission list ->
 
434
                     at_flag list -> unit
 
435
  = "netsys_faccessat"
 
436
external mkdirat : Unix.file_descr -> string -> int -> unit 
 
437
  = "netsys_mkdirat"
 
438
external renameat : Unix.file_descr -> string -> Unix.file_descr -> string -> 
 
439
                    unit
 
440
  = "netsys_renameat"
 
441
external linkat : Unix.file_descr -> string -> Unix.file_descr -> string ->
 
442
                  at_flag list -> unit
 
443
  = "netsys_linkat"
 
444
external unlinkat : Unix.file_descr -> string -> at_flag list -> unit
 
445
  = "netsys_unlinkat"
 
446
external symlinkat : string -> Unix.file_descr -> string -> unit
 
447
  = "netsys_symlinkat"
 
448
external mkfifoat : Unix.file_descr -> string -> int -> unit
 
449
  = "netsys_mkfifoat"
 
450
external readlinkat : Unix.file_descr -> string -> string
 
451
  = "netsys_readlinkat"
 
452
 
 
453
 
 
454
(* Spawn *)
 
455
 
 
456
type wd_spec =
 
457
  | Wd_keep
 
458
  | Wd_chdir of string
 
459
  | Wd_fchdir of Unix.file_descr
 
460
 
 
461
type pg_spec =
 
462
  | Pg_keep
 
463
  | Pg_new_bg_group
 
464
  | Pg_new_fg_group
 
465
  | Pg_join_group of int
 
466
 
 
467
type fd_action =
 
468
  | Fda_close of Unix.file_descr
 
469
  | Fda_close_ignore of Unix.file_descr
 
470
  | Fda_close_except of bool array
 
471
  | Fda_dup2 of Unix.file_descr * Unix.file_descr
 
472
 
 
473
type sig_action =
 
474
  | Sig_default of int
 
475
  | Sig_ignore of int
 
476
 
 
477
external netsys_spawn : wd_spec -> pg_spec -> fd_action list -> 
 
478
                        sig_action list -> string array ->
 
479
                        string -> string array -> int
 
480
  = "netsys_spawn_byte" "netsys_spawn_nat"
 
481
 
 
482
let spawn ?(chdir = Wd_keep) ?(pg = Pg_keep) ?(fd_actions = [])
 
483
          ?(sig_actions = []) ?(env = Unix.environment()) cmd args =
 
484
  (* Fixup: if pg = Pg_new_fg_group, we remove any Sig_default for
 
485
     SIGTTOU from sig_actions. Because of special handling, the effect
 
486
     of Sig_default is enforced by the implementation, but this must be
 
487
     done at [execve] time.
 
488
   *)
 
489
  let sig_actions =
 
490
    if pg = Pg_new_fg_group then
 
491
      List.filter 
 
492
        (fun spec -> spec <> Sig_default Sys.sigttou)
 
493
        sig_actions
 
494
    else
 
495
      sig_actions in
 
496
  netsys_spawn chdir pg fd_actions sig_actions env cmd args
 
497
 
 
498
 
 
499
type watched_subprocess = 
 
500
    { atom_idx : int;
 
501
      mutable alive : bool;
 
502
      mutable allocated : bool;
 
503
    }
 
504
 
 
505
external netsys_watch_subprocess : int -> int -> bool -> Unix.file_descr * int
 
506
  = "netsys_watch_subprocess"
 
507
 
 
508
external netsys_ignore_subprocess : int -> unit
 
509
  = "netsys_ignore_subprocess"
 
510
 
 
511
external netsys_forget_subprocess : int -> unit
 
512
  = "netsys_forget_subprocess"
 
513
 
 
514
external netsys_get_subprocess_status : int -> Unix.process_status option
 
515
  = "netsys_get_subprocess_status"
 
516
 
 
517
external install_subprocess_handler : unit -> unit
 
518
  = "netsys_install_sigchld_handler"
 
519
 
 
520
external subprocess_cleanup_after_fork : unit -> unit
 
521
  = "netsys_subprocess_cleanup_after_fork"
 
522
 
 
523
external netsys_kill_subprocess : int -> int -> unit
 
524
  = "netsys_kill_subprocess"
 
525
 
 
526
external netsys_killpg_subprocess : int -> int -> unit
 
527
  = "netsys_killpg_subprocess"
 
528
 
 
529
external kill_all_subprocesses : int -> bool -> bool -> unit
 
530
  = "netsys_kill_all_subprocesses"
 
531
 
 
532
external killpg_all_subprocesses : int -> bool -> unit
 
533
  = "netsys_killpg_all_subprocesses"
 
534
 
 
535
let forget_subprocess ws =
 
536
  if ws.allocated then (
 
537
    netsys_forget_subprocess ws.atom_idx;
 
538
    ws.allocated <- false;
 
539
  );
 
540
  ws.alive <- false
 
541
 
 
542
let watch_subprocess pid pgid kill_flag =
 
543
  if pid <= 0 || pgid < 0 then
 
544
    invalid_arg "Netsys_posix.watch_subprocess";
 
545
  let fd, atom_idx = netsys_watch_subprocess pid pgid kill_flag in
 
546
  let ws = { atom_idx = atom_idx; alive = true; allocated = true } in
 
547
  Gc.finalise forget_subprocess ws;
 
548
  (fd, ws)
 
549
 
 
550
let ignore_subprocess ws =
 
551
  if not ws.alive then
 
552
    failwith "Netsys_posix.ignore_subprocess: stale reference";
 
553
  netsys_ignore_subprocess ws.atom_idx;
 
554
  ws.alive <- false
 
555
 
 
556
let get_subprocess_status ws =
 
557
  if not ws.alive then
 
558
    failwith "Netsys_posix.get_subprocess_status: stale reference";
 
559
  netsys_get_subprocess_status ws.atom_idx
 
560
 
 
561
let kill_subprocess signal ws =
 
562
  if ws.alive then
 
563
    netsys_kill_subprocess signal ws.atom_idx
 
564
 
 
565
let killpg_subprocess signal ws =
 
566
  if ws.alive then
 
567
    netsys_killpg_subprocess signal ws.atom_idx
 
568
 
 
569
 
 
570
let () =
 
571
  register_post_fork_handler
 
572
    ( object 
 
573
        method name = "subprocess_cleanup_after_fork"
 
574
        method run = subprocess_cleanup_after_fork
 
575
      end
 
576
    )
 
577
 
 
578
let register_subprocess_handler() =
 
579
  Netsys_signal.register_exclusive_handler
 
580
    ~name:"Sigchld handler in Netsys_posix"
 
581
    ~signal:Sys.sigchld
 
582
    ~install:install_subprocess_handler
 
583
    ()
 
584
 
 
585
 
 
586
(* locales *)
 
587
 
 
588
type langinfo =
 
589
    { nl_CODESET : string;
 
590
      nl_D_T_FMT : string;
 
591
      nl_D_FMT : string;
 
592
      nl_T_FMT : string;
 
593
      nl_T_FMT_AMPM : string;
 
594
      nl_AM_STR : string;
 
595
      nl_PM_STR : string;
 
596
      nl_DAY_1 : string;
 
597
      nl_DAY_2 : string;
 
598
      nl_DAY_3 : string;
 
599
      nl_DAY_4 : string;
 
600
      nl_DAY_5 : string;
 
601
      nl_DAY_6 : string;
 
602
      nl_DAY_7 : string;
 
603
      nl_ABDAY_1 : string;
 
604
      nl_ABDAY_2 : string;  
 
605
      nl_ABDAY_3 : string;  
 
606
      nl_ABDAY_4 : string;  
 
607
      nl_ABDAY_5 : string;  
 
608
      nl_ABDAY_6 : string;  
 
609
      nl_ABDAY_7 : string;  
 
610
      nl_MON_1 : string;  
 
611
      nl_MON_2 : string;  
 
612
      nl_MON_3 : string;  
 
613
      nl_MON_4 : string;  
 
614
      nl_MON_5 : string;  
 
615
      nl_MON_6 : string;  
 
616
      nl_MON_7 : string;  
 
617
      nl_MON_8 : string;  
 
618
      nl_MON_9 : string;  
 
619
      nl_MON_10 : string;  
 
620
      nl_MON_11 : string;  
 
621
      nl_MON_12 : string;  
 
622
      nl_ABMON_1 : string;  
 
623
      nl_ABMON_2 : string;  
 
624
      nl_ABMON_3 : string;  
 
625
      nl_ABMON_4 : string;  
 
626
      nl_ABMON_5 : string;  
 
627
      nl_ABMON_6 : string;  
 
628
      nl_ABMON_7 : string;  
 
629
      nl_ABMON_8 : string;  
 
630
      nl_ABMON_9 : string;  
 
631
      nl_ABMON_10 : string;  
 
632
      nl_ABMON_11 : string;  
 
633
      nl_ABMON_12 : string;  
 
634
      nl_ERA : string;  
 
635
      nl_ERA_D_FMT : string;  
 
636
      nl_ERA_D_T_FMT : string;  
 
637
      nl_ERA_T_FMT : string;  
 
638
      nl_ALT_DIGITS : string;  
 
639
      nl_RADIXCHAR : string;  
 
640
      nl_THOUSEP : string;  
 
641
      nl_YESEXPR : string;  
 
642
      nl_NOEXPR : string;  
 
643
      nl_CRNCYSTR : string;  
 
644
    }
 
645
 
 
646
external netsys_query_langinfo : string -> langinfo = "netsys_query_langinfo"
 
647
 
 
648
let cached_langinfo = ref None
 
649
 
 
650
let query_langinfo locale =
 
651
  if locale = "" then (
 
652
    match !cached_langinfo with
 
653
      | None ->
 
654
          let li = netsys_query_langinfo "" in
 
655
          cached_langinfo := Some li;
 
656
          li
 
657
      | Some li -> li
 
658
  )
 
659
  else
 
660
    netsys_query_langinfo locale
 
661
 
 
662
 
 
663
 
 
664
(* syslog *)
 
665
 
 
666
type level = Netlog.level
 
667
 
 
668
type m_level =
 
669
  | LOG_EMERG | LOG_ALERT | LOG_CRIT | LOG_ERR | LOG_WARNING 
 
670
  | LOG_NOTICE | LOG_INFO | LOG_DEBUG
 
671
 
 
672
let trans_level =
 
673
  [ `Emerg, LOG_EMERG;
 
674
    `Alert, LOG_ALERT;
 
675
    `Crit, LOG_CRIT;
 
676
    `Err, LOG_ERR;
 
677
    `Warning, LOG_WARNING;
 
678
    `Notice, LOG_NOTICE;
 
679
    `Info, LOG_INFO;
 
680
    `Debug, LOG_DEBUG
 
681
  ]
 
682
 
 
683
type syslog_facility =
 
684
    [ `Authpriv
 
685
    | `Cron
 
686
    | `Daemon
 
687
    | `Ftp
 
688
    | `Kern
 
689
    | `Local0
 
690
    | `Local1
 
691
    | `Local2
 
692
    | `Local3
 
693
    | `Local4
 
694
    | `Local5
 
695
    | `Local6
 
696
    | `Local7
 
697
    | `Lpr
 
698
    | `Mail
 
699
    | `News
 
700
    | `Syslog
 
701
    | `User
 
702
    | `Uucp
 
703
    | `Default
 
704
    ]
 
705
 
 
706
type m_syslog_facility = 
 
707
  | LOG_AUTHPRIV
 
708
  | LOG_CRON
 
709
  | LOG_DAEMON
 
710
  | LOG_FTP
 
711
  | LOG_KERN
 
712
  | LOG_LOCAL0
 
713
  | LOG_LOCAL1
 
714
  | LOG_LOCAL2
 
715
  | LOG_LOCAL3
 
716
  | LOG_LOCAL4
 
717
  | LOG_LOCAL5
 
718
  | LOG_LOCAL6
 
719
  | LOG_LOCAL7
 
720
  | LOG_LPR
 
721
  | LOG_MAIL
 
722
  | LOG_NEWS
 
723
  | LOG_SYSLOG
 
724
  | LOG_USER
 
725
  | LOG_UUCP
 
726
  | LOG_DEFAULT
 
727
 
 
728
let trans_facility =
 
729
  [ `Authpriv, LOG_AUTHPRIV;
 
730
    `Cron, LOG_CRON;
 
731
    `Daemon, LOG_DAEMON;
 
732
    `Ftp, LOG_FTP;
 
733
    `Kern, LOG_KERN;
 
734
    `Local0, LOG_LOCAL0;
 
735
    `Local1, LOG_LOCAL1;
 
736
    `Local2, LOG_LOCAL2;
 
737
    `Local3, LOG_LOCAL3;
 
738
    `Local4, LOG_LOCAL4;
 
739
    `Local5, LOG_LOCAL5;
 
740
    `Local6, LOG_LOCAL6;
 
741
    `Local7, LOG_LOCAL7;
 
742
    `Lpr, LOG_LPR;
 
743
    `Mail, LOG_MAIL;
 
744
    `News, LOG_NEWS;
 
745
    `Syslog, LOG_SYSLOG;
 
746
    `User, LOG_USER;
 
747
    `Uucp, LOG_UUCP;
 
748
    `Default, LOG_DEFAULT;
 
749
  ]
 
750
 
 
751
type syslog_option =
 
752
    [ `Cons
 
753
    | `Ndelay
 
754
    | `Odelay
 
755
    | `Nowait
 
756
    | `Pid
 
757
    ]
 
758
 
 
759
type m_syslog_option =
 
760
  | LOG_CONS
 
761
  | LOG_NDELAY
 
762
  | LOG_ODELAY
 
763
  | LOG_NOWAIT
 
764
  | LOG_PID
 
765
 
 
766
let trans_syslog_option =
 
767
  [ `Cons, LOG_CONS;
 
768
    `Ndelay, LOG_NDELAY;
 
769
    `Odelay, LOG_ODELAY;
 
770
    `Nowait, LOG_NOWAIT;
 
771
    `Pid, LOG_PID;
 
772
  ]
 
773
 
 
774
external netsys_openlog : 
 
775
  string option -> m_syslog_option list -> m_syslog_facility -> unit
 
776
  = "netsys_openlog"
 
777
 
 
778
external netsys_syslog :
 
779
  m_syslog_facility -> m_level -> string -> unit
 
780
  = "netsys_syslog"
 
781
 
 
782
external netsys_closelog : unit -> unit = "netsys_closelog"
 
783
 
 
784
let openlog id_opt opts fac =
 
785
  try
 
786
    netsys_openlog
 
787
      id_opt
 
788
      ( List.map
 
789
          (fun p -> List.assoc p trans_syslog_option)
 
790
        opts
 
791
      )
 
792
      ( List.assoc fac trans_facility )
 
793
  with
 
794
    | Not_found -> assert false
 
795
          
 
796
let syslog fac lev msg =
 
797
  try
 
798
    netsys_syslog
 
799
      ( List.assoc fac trans_facility )
 
800
      ( List.assoc lev trans_level )
 
801
      msg
 
802
  with
 
803
    | Not_found -> assert false
 
804
 
 
805
let closelog = netsys_closelog
 
806
 
 
807
 
 
808
(* Sync *)
 
809
 
 
810
external fsync : Unix.file_descr -> unit = "netsys_fsync"
 
811
external fdatasync : Unix.file_descr -> unit = "netsys_fdatasync"
 
812
 
 
813
 
 
814
(* Optional POSIX functions *)
 
815
 
 
816
external have_fadvise : unit -> bool = "netsys_have_posix_fadvise"
 
817
type advice =
 
818
  | POSIX_FADV_NORMAL
 
819
  | POSIX_FADV_SEQUENTIAL
 
820
  | POSIX_FADV_RANDOM
 
821
  | POSIX_FADV_NOREUSE
 
822
  | POSIX_FADV_WILLNEED
 
823
  | POSIX_FADV_DONTNEED
 
824
  | FADV_NORMAL
 
825
  | FADV_SEQUENTIAL
 
826
  | FADV_RANDOM
 
827
  | FADV_NOREUSE
 
828
  | FADV_WILLNEED
 
829
  | FADV_DONTNEED
 
830
external fadvise : Unix.file_descr -> int64 -> int64 -> advice -> unit
 
831
                 = "netsys_fadvise"
 
832
 
 
833
external have_fallocate : unit -> bool = "netsys_have_posix_fallocate"
 
834
external fallocate : Unix.file_descr -> int64 -> int64 -> unit
 
835
                   = "netsys_fallocate"
 
836
 
 
837
(* POSIX shared memory *)
 
838
 
 
839
external have_posix_shm : unit -> bool = "netsys_have_posix_shm"
 
840
type shm_open_flag =
 
841
  | SHM_O_RDONLY
 
842
  | SHM_O_RDWR
 
843
  | SHM_O_CREAT
 
844
  | SHM_O_EXCL
 
845
  | SHM_O_TRUNC
 
846
external shm_open : string -> shm_open_flag list -> int -> file_descr
 
847
  = "netsys_shm_open"
 
848
external shm_unlink : string -> unit = "netsys_shm_unlink"
 
849
 
 
850
let shm_create prefix size =
 
851
  let pid = Unix.getpid() in
 
852
  let t = Unix.gettimeofday() in
 
853
  let rec loop n =
 
854
    let id = sprintf "%d/%f/%d" pid t n in
 
855
    let dg = Digest.to_hex (Digest.string id) in
 
856
    let dg8 = String.sub dg 0 8 in
 
857
    let name = sprintf "%s_%s" prefix dg8 in
 
858
    try
 
859
      let fd =
 
860
        shm_open
 
861
          name [SHM_O_RDWR; SHM_O_CREAT; SHM_O_EXCL ] 0o600 in
 
862
      Unix.fchmod fd 0o600;
 
863
      Unix.ftruncate fd size;
 
864
      (fd, name)
 
865
    with
 
866
      | Unix.Unix_error(Unix.EEXIST,_,_) ->
 
867
          loop (n+1) in
 
868
  loop 0
 
869
 
 
870
 
 
871
type sem_kind = [ `Named | `Anonymous ]
 
872
 
 
873
type sem_rep
 
874
 
 
875
type 'sem_kind semaphore =
 
876
    Netsys_types.memory * sem_rep
 
877
      (* We keep a reference to the bigarray to prevent that it is
 
878
         collected while a semaphore is stored in it
 
879
       *)
 
880
 
 
881
type named_semaphore = [ `Named ] semaphore
 
882
type anon_sempahore = [ `Anonymous ] semaphore
 
883
 
 
884
type sem_open_flag =
 
885
  | SEM_O_CREAT
 
886
  | SEM_O_EXCL
 
887
 
 
888
type sem_wait_behavior =
 
889
  | SEM_WAIT_BLOCK
 
890
  | SEM_WAIT_NONBLOCK
 
891
 
 
892
let dummy_mem =
 
893
  Bigarray.Array1.create Bigarray.char Bigarray.c_layout 0
 
894
 
 
895
external have_posix_semaphores : unit -> bool 
 
896
  = "netsys_have_sem"
 
897
 
 
898
external netsys_sem_size : unit -> int
 
899
  = "netsys_sem_size"
 
900
 
 
901
external netsys_sem_value_max : unit -> int
 
902
  = "netsys_sem_value_max"
 
903
 
 
904
let sem_size = netsys_sem_size()
 
905
 
 
906
let sem_value_max = netsys_sem_value_max()
 
907
 
 
908
 
 
909
external netsys_sem_open :
 
910
  string -> sem_open_flag list -> int -> int -> sem_rep
 
911
  = "netsys_sem_open"
 
912
 
 
913
let sem_open name flags mode init_value =
 
914
  if init_value < 0 || init_value > sem_value_max then
 
915
    invalid_arg "Netsys_posix.sem_open";
 
916
  let sr = netsys_sem_open name flags mode init_value in
 
917
  (dummy_mem, sr)
 
918
 
 
919
external netsys_sem_close : sem_rep -> unit 
 
920
  = "netsys_sem_close"
 
921
 
 
922
let sem_close (_,sr) = netsys_sem_close sr
 
923
 
 
924
external sem_unlink : string -> unit 
 
925
  = "netsys_sem_unlink"
 
926
 
 
927
let sem_create prefix initval =
 
928
  let pid = Unix.getpid() in
 
929
  let t = Unix.gettimeofday() in
 
930
  let rec loop n =
 
931
    let id = sprintf "%d/%f/%d" pid t n in
 
932
    let dg = Digest.to_hex (Digest.string id) in
 
933
    let dg8 = String.sub dg 0 8 in
 
934
    let name = sprintf "%s_%s" prefix dg8 in
 
935
    try
 
936
      let sem =
 
937
        sem_open
 
938
          name [SEM_O_CREAT; SEM_O_EXCL] 0o600 initval in
 
939
      (sem, name)
 
940
    with
 
941
      | Unix.Unix_error(Unix.EEXIST,_,_) ->
 
942
          loop (n+1) in
 
943
  loop 0
 
944
 
 
945
 
 
946
external netsys_sem_init : 
 
947
  Netsys_types.memory -> int -> bool -> int -> sem_rep
 
948
  = "netsys_sem_init"
 
949
 
 
950
let sem_init mem pos pshared init_value =
 
951
  if pos < 0 || pos > Bigarray.Array1.dim mem - sem_size then
 
952
    invalid_arg "Netsys_posix.sem_init";
 
953
  if init_value < 0 || init_value > sem_value_max then
 
954
    invalid_arg "Netsys_posix.sem_init";
 
955
  let sr = netsys_sem_init mem pos pshared init_value in
 
956
  (mem,sr)
 
957
 
 
958
external netsys_as_sem : Netsys_types.memory -> int -> sem_rep
 
959
  = "netsys_as_sem"
 
960
 
 
961
let as_sem mem pos = 
 
962
  if pos < 0 || pos > Bigarray.Array1.dim mem - sem_size then
 
963
    invalid_arg "Netsys_posix.as_sem";
 
964
  let sr = netsys_as_sem mem pos in
 
965
  (mem,sr)
 
966
 
 
967
external netsys_sem_destroy : sem_rep -> unit
 
968
  = "netsys_sem_destroy"
 
969
 
 
970
let sem_destroy (_,sr) = netsys_sem_destroy sr
 
971
  
 
972
external netsys_sem_getvalue : sem_rep -> int
 
973
  = "netsys_sem_getvalue"
 
974
 
 
975
let sem_getvalue (_,sr) = netsys_sem_getvalue sr
 
976
 
 
977
external netsys_sem_post : sem_rep -> unit
 
978
  = "netsys_sem_post"
 
979
 
 
980
let sem_post (_,sr) = netsys_sem_post sr
 
981
 
 
982
external netsys_sem_wait : sem_rep -> sem_wait_behavior -> unit
 
983
  = "netsys_sem_wait"
 
984
 
 
985
let sem_wait (_,sr) b = netsys_sem_wait sr b
 
986
 
 
987
 
 
988
type ioprio_target =
 
989
  | Ioprio_process of int
 
990
  | Ioprio_pgrp of int
 
991
  | Ioprio_user of int
 
992
 
 
993
type ioprio =
 
994
  | Noprio
 
995
  | Real_time of int
 
996
  | Best_effort of int
 
997
  | Idle
 
998
 
 
999
external ioprio_get : ioprio_target -> ioprio = "netsys_ioprio_get"
 
1000
external ioprio_set : ioprio_target -> ioprio -> unit = "netsys_ioprio_set"
 
1001
 
 
1002
let have_ioprio() =
 
1003
  try let _ = ioprio_get(Ioprio_process(Unix.getpid())) in true
 
1004
  with _ -> false