l4/pkg/ocaml/contrib/otherlibs/threads/unix.ml

   1 (***********************************************************************)
   2 (*                                                                     *)
   3 (*                           Objective Caml                            *)
   4 (*                                                                     *)
   5 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
   6 (*                                                                     *)
   7 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
   8 (*  en Automatique.  All rights reserved.  This file is distributed    *)
   9 (*  under the terms of the GNU Library General Public License, with    *)
  10 (*  the special exception on linking described in file ../../LICENSE.  *)
  11 (*                                                                     *)
  12 (***********************************************************************)
  13
  14 (* $Id: unix.ml 8972 2008-08-01 16:29:44Z mauny $ *)
  15
  16 (* An alternate implementation of the Unix module from ../unix
  17    which is safe in conjunction with bytecode threads. *)
  18
  19 (* Type definitions that matter for thread operations *)
  20
  21 type file_descr = int
  22
  23 type process_status =
  24     WEXITED of int
  25   | WSIGNALED of int
  26   | WSTOPPED of int
  27
  28 (* We can't call functions from Thread because of type circularities,
  29    so we redefine here the functions that we need *)
  30
  31 type resumption_status =
  32     Resumed_wakeup
  33   | Resumed_delay
  34   | Resumed_join
  35   | Resumed_io
  36   | Resumed_select of file_descr list * file_descr list * file_descr list
  37   | Resumed_wait of int * process_status
  38
  39 external thread_initialize : unit -> unit = "thread_initialize"
  40 external thread_wait_read : file_descr -> unit = "thread_wait_read"
  41 external thread_wait_write : file_descr -> unit = "thread_wait_write"
  42 external thread_select :
  43   file_descr list * file_descr list * file_descr list * float
  44        -> resumption_status
  45   = "thread_select"
  46 external thread_wait_pid : int -> resumption_status = "thread_wait_pid"
  47 external thread_delay : float -> unit = "thread_delay"
  48
  49 let wait_read fd = thread_wait_read fd
  50 let wait_write fd = thread_wait_write fd
  51 let select_aux arg = thread_select arg
  52 let wait_pid_aux pid = thread_wait_pid pid
  53 let delay duration = thread_delay duration
  54
  55 (* Make sure that threads are initialized (PR#1516). *)
  56
  57 let _ = thread_initialize()
  58
  59 (* Back to the Unix module *)
  60
  61 type error =
  62     E2BIG
  63   | EACCES
  64   | EAGAIN
  65   | EBADF
  66   | EBUSY
  67   | ECHILD
  68   | EDEADLK
  69   | EDOM
  70   | EEXIST
  71   | EFAULT
  72   | EFBIG
  73   | EINTR
  74   | EINVAL
  75   | EIO
  76   | EISDIR
  77   | EMFILE
  78   | EMLINK
  79   | ENAMETOOLONG
  80   | ENFILE
  81   | ENODEV
  82   | ENOENT
  83   | ENOEXEC
  84   | ENOLCK
  85   | ENOMEM
  86   | ENOSPC
  87   | ENOSYS
  88   | ENOTDIR
  89   | ENOTEMPTY
  90   | ENOTTY
  91   | ENXIO
  92   | EPERM
  93   | EPIPE
  94   | ERANGE
  95   | EROFS
  96   | ESPIPE
  97   | ESRCH
  98   | EXDEV
  99   | EWOULDBLOCK
 100   | EINPROGRESS
 101   | EALREADY
 102   | ENOTSOCK
 103   | EDESTADDRREQ
 104   | EMSGSIZE
 105   | EPROTOTYPE
 106   | ENOPROTOOPT
 107   | EPROTONOSUPPORT
 108   | ESOCKTNOSUPPORT
 109   | EOPNOTSUPP
 110   | EPFNOSUPPORT
 111   | EAFNOSUPPORT
 112   | EADDRINUSE
 113   | EADDRNOTAVAIL
 114   | ENETDOWN
 115   | ENETUNREACH
 116   | ENETRESET
 117   | ECONNABORTED
 118   | ECONNRESET
 119   | ENOBUFS
 120   | EISCONN
 121   | ENOTCONN
 122   | ESHUTDOWN
 123   | ETOOMANYREFS
 124   | ETIMEDOUT
 125   | ECONNREFUSED
 126   | EHOSTDOWN
 127   | EHOSTUNREACH
 128   | ELOOP
 129   | EOVERFLOW
 130   | EUNKNOWNERR of int
 131
 132 exception Unix_error of error * string * string
 133
 134 let _ = Callback.register_exception "Unix.Unix_error"
 135                                     (Unix_error(E2BIG, "", ""))
 136
 137 external error_message : error -> string = "unix_error_message"
 138
 139 let handle_unix_error f arg =
 140   try
 141     f arg
 142   with Unix_error(err, fun_name, arg) ->
 143     prerr_string Sys.argv.(0);
 144     prerr_string ": \"";
 145     prerr_string fun_name;
 146     prerr_string "\" failed";
 147     if String.length arg > 0 then begin
 148       prerr_string " on \"";
 149       prerr_string arg;
 150       prerr_string "\""
 151     end;
 152     prerr_string ": ";
 153     prerr_endline (error_message err);
 154     exit 2
 155
 156 external environment : unit -> string array = "unix_environment"
 157 external getenv: string -> string = "caml_sys_getenv"
 158 external putenv: string -> string -> unit = "unix_putenv"
 159
 160 type interval_timer =
 161     ITIMER_REAL
 162   | ITIMER_VIRTUAL
 163   | ITIMER_PROF
 164
 165 type interval_timer_status =
 166   { it_interval: float;                 (* Period *)
 167     it_value: float }                   (* Current value of the timer *)
 168
 169 external getitimer: interval_timer -> interval_timer_status = "unix_getitimer"
 170 external setitimer:
 171   interval_timer -> interval_timer_status -> interval_timer_status
 172   = "unix_setitimer"
 173
 174 type wait_flag =
 175     WNOHANG
 176   | WUNTRACED
 177
 178 let stdin = 0
 179 let stdout = 1
 180 let stderr = 2
 181
 182 type open_flag =
 183     O_RDONLY
 184   | O_WRONLY
 185   | O_RDWR
 186   | O_NONBLOCK
 187   | O_APPEND
 188   | O_CREAT
 189   | O_TRUNC
 190   | O_EXCL
 191   | O_NOCTTY
 192   | O_DSYNC
 193   | O_SYNC
 194   | O_RSYNC
 195
 196 type file_perm = int
 197
 198
 199 external openfile : string -> open_flag list -> file_perm -> file_descr
 200            = "unix_open"
 201
 202 external close : file_descr -> unit = "unix_close"
 203 external unsafe_read : file_descr -> string -> int -> int -> int = "unix_read"
 204 external unsafe_write : file_descr -> string -> int -> int -> int
 205     = "unix_write"
 206 external unsafe_single_write : file_descr -> string -> int -> int -> int
 207     = "unix_single_write"
 208
 209 let rec read fd buf ofs len =
 210   try
 211     if ofs < 0 || len < 0 || ofs > String.length buf - len
 212     then invalid_arg "Unix.read"
 213     else unsafe_read fd buf ofs len
 214   with Unix_error((EAGAIN | EWOULDBLOCK), _, _) ->
 215     wait_read fd; read fd buf ofs len
 216
 217 let rec write fd buf ofs len =
 218   try
 219     if ofs < 0 || len < 0 || ofs > String.length buf - len
 220     then invalid_arg "Unix.write"
 221     else unsafe_write fd buf ofs len
 222   with Unix_error((EAGAIN | EWOULDBLOCK), _, _) ->
 223     wait_write fd; write fd buf ofs len
 224
 225 let rec single_write fd buf ofs len =
 226   try
 227     if ofs < 0 || len < 0 || ofs > String.length buf - len
 228     then invalid_arg "Unix.partial_write"
 229     else unsafe_single_write fd buf ofs len
 230   with Unix_error((EAGAIN | EWOULDBLOCK), _, _) ->
 231     wait_write fd; single_write fd buf ofs len
 232
 233 external in_channel_of_descr : file_descr -> in_channel
 234                              = "caml_ml_open_descriptor_in"
 235 external out_channel_of_descr : file_descr -> out_channel
 236                               = "caml_ml_open_descriptor_out"
 237 external descr_of_in_channel : in_channel -> file_descr
 238                              = "caml_channel_descriptor"
 239 external descr_of_out_channel : out_channel -> file_descr
 240                               = "caml_channel_descriptor"
 241
 242 type seek_command =
 243     SEEK_SET
 244   | SEEK_CUR
 245   | SEEK_END
 246
 247 external lseek : file_descr -> int -> seek_command -> int = "unix_lseek"
 248 external truncate : string -> int -> unit = "unix_truncate"
 249 external ftruncate : file_descr -> int -> unit = "unix_ftruncate"
 250
 251 type file_kind =
 252     S_REG
 253   | S_DIR
 254   | S_CHR
 255   | S_BLK
 256   | S_LNK
 257   | S_FIFO
 258   | S_SOCK
 259
 260 type stats =
 261   { st_dev : int;
 262     st_ino : int;
 263     st_kind : file_kind;
 264     st_perm : file_perm;
 265     st_nlink : int;
 266     st_uid : int;
 267     st_gid : int;
 268     st_rdev : int;
 269     st_size : int;
 270     st_atime : float;
 271     st_mtime : float;
 272     st_ctime : float }
 273
 274 external stat : string -> stats = "unix_stat"
 275 external lstat : string -> stats = "unix_lstat"
 276 external fstat : file_descr -> stats = "unix_fstat"
 277 external isatty : file_descr -> bool = "unix_isatty"
 278 external unlink : string -> unit = "unix_unlink"
 279 external rename : string -> string -> unit = "unix_rename"
 280 external link : string -> string -> unit = "unix_link"
 281
 282 module LargeFile =
 283   struct
 284     external lseek : file_descr -> int64 -> seek_command -> int64
 285                    = "unix_lseek_64"
 286     external truncate : string -> int64 -> unit = "unix_truncate_64"
 287     external ftruncate : file_descr -> int64 -> unit = "unix_ftruncate_64"
 288     type stats =
 289       { st_dev : int;
 290         st_ino : int;
 291         st_kind : file_kind;
 292         st_perm : file_perm;
 293         st_nlink : int;
 294         st_uid : int;
 295         st_gid : int;
 296         st_rdev : int;
 297         st_size : int64;
 298         st_atime : float;
 299         st_mtime : float;
 300         st_ctime : float;
 301       }
 302     external stat : string -> stats = "unix_stat_64"
 303     external lstat : string -> stats = "unix_lstat_64"
 304     external fstat : file_descr -> stats = "unix_fstat_64"
 305   end
 306
 307 type access_permission =
 308     R_OK
 309   | W_OK
 310   | X_OK
 311   | F_OK
 312
 313 external chmod : string -> file_perm -> unit = "unix_chmod"
 314 external fchmod : file_descr -> file_perm -> unit = "unix_fchmod"
 315 external chown : string -> int -> int -> unit = "unix_chown"
 316 external fchown : file_descr -> int -> int -> unit = "unix_fchown"
 317 external umask : int -> int = "unix_umask"
 318 external access : string -> access_permission list -> unit = "unix_access"
 319
 320 external dup : file_descr -> file_descr = "unix_dup"
 321 external dup2 : file_descr -> file_descr -> unit = "unix_dup2"
 322 external set_nonblock : file_descr -> unit = "unix_set_nonblock"
 323 external clear_nonblock : file_descr -> unit = "unix_clear_nonblock"
 324 external set_close_on_exec : file_descr -> unit = "unix_set_close_on_exec"
 325 external clear_close_on_exec : file_descr -> unit = "unix_clear_close_on_exec"
 326
 327 external mkdir : string -> file_perm -> unit = "unix_mkdir"
 328 external rmdir : string -> unit = "unix_rmdir"
 329 external chdir : string -> unit = "unix_chdir"
 330 external getcwd : unit -> string = "unix_getcwd"
 331 external chroot : string -> unit = "unix_chroot"
 332
 333 type dir_handle
 334
 335 external opendir : string -> dir_handle = "unix_opendir"
 336 external readdir : dir_handle -> string = "unix_readdir"
 337 external rewinddir : dir_handle -> unit = "unix_rewinddir"
 338 external closedir : dir_handle -> unit = "unix_closedir"
 339
 340 external _pipe : unit -> file_descr * file_descr = "unix_pipe"
 341
 342 let pipe() =
 343   let (out_fd, in_fd as fd_pair) = _pipe() in
 344   set_nonblock in_fd;
 345   set_nonblock out_fd;
 346   fd_pair
 347
 348 external symlink : string -> string -> unit = "unix_symlink"
 349 external readlink : string -> string = "unix_readlink"
 350 external mkfifo : string -> file_perm -> unit = "unix_mkfifo"
 351
 352 let select readfds writefds exceptfds delay =
 353   match select_aux (readfds, writefds, exceptfds, delay) with
 354     Resumed_select(r, w, e) -> (r, w, e)
 355   | _ -> ([], [], [])
 356
 357 type lock_command =
 358     F_ULOCK
 359   | F_LOCK
 360   | F_TLOCK
 361   | F_TEST
 362   | F_RLOCK
 363   | F_TRLOCK
 364
 365 external lockf : file_descr -> lock_command -> int -> unit = "unix_lockf"
 366
 367 external _execv : string -> string array -> 'a = "unix_execv"
 368 external _execve : string -> string array -> string array -> 'a = "unix_execve"
 369 external _execvp : string -> string array -> 'a = "unix_execvp"
 370 external _execvpe : string -> string array -> string array -> 'a
 371                   = "unix_execvpe"
 372
 373 (* Disable the timer interrupt before doing exec, because some OS
 374    keep sending timer interrupts to the exec'ed code.
 375    Also restore blocking mode on stdin, stdout and stderr,
 376    since this is what most programs expect! *)
 377
 378 let safe_clear_nonblock fd =
 379   try clear_nonblock fd with Unix_error(_,_,_) -> ()
 380 let safe_set_nonblock fd =
 381   try set_nonblock fd with Unix_error(_,_,_) -> ()
 382
 383 let do_exec fn =
 384   let oldtimer =
 385     setitimer ITIMER_VIRTUAL {it_interval = 0.0; it_value = 0.0} in
 386   safe_clear_nonblock stdin;
 387   safe_clear_nonblock stdout;
 388   safe_clear_nonblock stderr;
 389   try
 390     fn ()
 391   with Unix_error(_,_,_) as exn ->
 392     ignore(setitimer ITIMER_VIRTUAL oldtimer);
 393     safe_set_nonblock stdin;
 394     safe_set_nonblock stdout;
 395     safe_set_nonblock stderr;
 396     raise exn
 397
 398 let execv proc args =
 399   do_exec (fun () -> _execv proc args)
 400
 401 let execve proc args env =
 402   do_exec (fun () -> _execve proc args env)
 403
 404 let execvp proc args =
 405   do_exec (fun () -> _execvp proc args)
 406
 407 let execvpe proc args =
 408   do_exec (fun () -> _execvpe proc args)
 409
 410 external fork : unit -> int = "unix_fork"
 411 external _waitpid : wait_flag list -> int -> int * process_status
 412                   = "unix_waitpid"
 413
 414 let wait_pid pid =
 415   match wait_pid_aux pid with
 416     Resumed_wait(pid, status) -> (pid, status)
 417   | _ -> invalid_arg "Thread.wait_pid"
 418
 419 let wait () = wait_pid (-1)
 420
 421 let waitpid flags pid =
 422   if List.mem WNOHANG flags
 423   then _waitpid flags pid
 424   else wait_pid pid
 425
 426 external getpid : unit -> int = "unix_getpid"
 427 external getppid : unit -> int = "unix_getppid"
 428 external nice : int -> int = "unix_nice"
 429
 430 external kill : int -> int -> unit = "unix_kill"
 431 type sigprocmask_command = SIG_SETMASK | SIG_BLOCK | SIG_UNBLOCK
 432 external sigprocmask: sigprocmask_command -> int list -> int list
 433         = "unix_sigprocmask"
 434 external sigpending: unit -> int list = "unix_sigpending"
 435 external sigsuspend: int list -> unit = "unix_sigsuspend"
 436
 437 let pause() =
 438   let sigs = sigprocmask SIG_BLOCK [] in sigsuspend sigs
 439
 440 type process_times =
 441   { tms_utime : float;
 442     tms_stime : float;
 443     tms_cutime : float;
 444     tms_cstime : float }
 445
 446 type tm =
 447   { tm_sec : int;
 448     tm_min : int;
 449     tm_hour : int;
 450     tm_mday : int;
 451     tm_mon : int;
 452     tm_year : int;
 453     tm_wday : int;
 454     tm_yday : int;
 455     tm_isdst : bool }
 456
 457 external time : unit -> float = "unix_time"
 458 external gettimeofday : unit -> float = "unix_gettimeofday"
 459 external gmtime : float -> tm = "unix_gmtime"
 460 external localtime : float -> tm = "unix_localtime"
 461 external mktime : tm -> float * tm = "unix_mktime"
 462 external alarm : int -> int = "unix_alarm"
 463
 464 let sleep secs = delay (float secs)
 465
 466 external times : unit -> process_times = "unix_times"
 467 external utimes : string -> float -> float -> unit = "unix_utimes"
 468
 469 external getuid : unit -> int = "unix_getuid"
 470 external geteuid : unit -> int = "unix_geteuid"
 471 external setuid : int -> unit = "unix_setuid"
 472 external getgid : unit -> int = "unix_getgid"
 473 external getegid : unit -> int = "unix_getegid"
 474 external setgid : int -> unit = "unix_setgid"
 475 external getgroups : unit -> int array = "unix_getgroups"
 476
 477 type passwd_entry =
 478   { pw_name : string;
 479     pw_passwd : string;
 480     pw_uid : int;
 481     pw_gid : int;
 482     pw_gecos : string;
 483     pw_dir : string;
 484     pw_shell : string }
 485
 486 type group_entry =
 487   { gr_name : string;
 488     gr_passwd : string;
 489     gr_gid : int;
 490     gr_mem : string array }
 491
 492
 493 external getlogin : unit -> string = "unix_getlogin"
 494 external getpwnam : string -> passwd_entry = "unix_getpwnam"
 495 external getgrnam : string -> group_entry = "unix_getgrnam"
 496 external getpwuid : int -> passwd_entry = "unix_getpwuid"
 497 external getgrgid : int -> group_entry = "unix_getgrgid"
 498
 499 type inet_addr = string
 500
 501 external inet_addr_of_string : string -> inet_addr
 502                                     = "unix_inet_addr_of_string"
 503 external string_of_inet_addr : inet_addr -> string
 504                                     = "unix_string_of_inet_addr"
 505
 506 let inet_addr_any = inet_addr_of_string "0.0.0.0"
 507 let inet_addr_loopback = inet_addr_of_string "127.0.0.1"
 508 let inet6_addr_any =
 509   try inet_addr_of_string "::" with Failure _ -> inet_addr_any
 510 let inet6_addr_loopback =
 511   try inet_addr_of_string "::1" with Failure _ -> inet_addr_loopback
 512
 513 let is_inet6_addr s = String.length s = 16
 514
 515 type socket_domain =
 516     PF_UNIX
 517   | PF_INET
 518   | PF_INET6
 519
 520 type socket_type =
 521     SOCK_STREAM
 522   | SOCK_DGRAM
 523   | SOCK_RAW
 524   | SOCK_SEQPACKET
 525
 526 type sockaddr =
 527     ADDR_UNIX of string
 528   | ADDR_INET of inet_addr * int
 529
 530 let domain_of_sockaddr = function
 531     ADDR_UNIX _ -> PF_UNIX
 532   | ADDR_INET(a, _) -> if is_inet6_addr a then PF_INET6 else PF_INET
 533
 534 type shutdown_command =
 535     SHUTDOWN_RECEIVE
 536   | SHUTDOWN_SEND
 537   | SHUTDOWN_ALL
 538
 539 type msg_flag =
 540     MSG_OOB
 541   | MSG_DONTROUTE
 542   | MSG_PEEK
 543
 544 external _socket : socket_domain -> socket_type -> int -> file_descr
 545                                   = "unix_socket"
 546 external _socketpair :
 547         socket_domain -> socket_type -> int -> file_descr * file_descr
 548                                   = "unix_socketpair"
 549
 550 let socket dom typ proto =
 551   let s = _socket dom typ proto in
 552   set_nonblock s;
 553   s
 554
 555 let socketpair dom typ proto =
 556   let (s1, s2 as spair) = _socketpair dom typ proto in
 557   set_nonblock s1; set_nonblock s2;
 558   spair
 559
 560 external _accept : file_descr -> file_descr * sockaddr = "unix_accept"
 561
 562 let rec accept req =
 563   wait_read req;
 564   try
 565     let (s, caller as result) = _accept req in
 566     set_nonblock s;
 567     result
 568   with Unix_error((EAGAIN | EWOULDBLOCK), _, _) -> accept req
 569
 570 external bind : file_descr -> sockaddr -> unit = "unix_bind"
 571 external listen : file_descr -> int -> unit = "unix_listen"
 572 external shutdown : file_descr -> shutdown_command -> unit = "unix_shutdown"
 573 external getsockname : file_descr -> sockaddr = "unix_getsockname"
 574 external getpeername : file_descr -> sockaddr = "unix_getpeername"
 575
 576 external _connect : file_descr -> sockaddr -> unit = "unix_connect"
 577
 578 let connect s addr =
 579   try
 580     _connect s addr
 581   with Unix_error((EINPROGRESS | EWOULDBLOCK | EAGAIN), _, _) ->
 582     wait_write s;
 583     (* Check if it really worked *)
 584     ignore(getpeername s)
 585
 586 external unsafe_recv :
 587   file_descr -> string -> int -> int -> msg_flag list -> int
 588                                   = "unix_recv"
 589 external unsafe_recvfrom :
 590   file_descr -> string -> int -> int -> msg_flag list -> int * sockaddr
 591                                   = "unix_recvfrom"
 592 external unsafe_send :
 593   file_descr -> string -> int -> int -> msg_flag list -> int
 594                                   = "unix_send"
 595 external unsafe_sendto :
 596   file_descr -> string -> int -> int -> msg_flag list -> sockaddr -> int
 597                                   = "unix_sendto" "unix_sendto_native"
 598
 599 let rec recv fd buf ofs len flags =
 600   try
 601     if ofs < 0 || len < 0 || ofs > String.length buf - len
 602     then invalid_arg "Unix.recv"
 603     else unsafe_recv fd buf ofs len flags
 604   with Unix_error((EAGAIN | EWOULDBLOCK), _, _) ->
 605     wait_read fd; recv fd buf ofs len flags
 606
 607 let rec recvfrom fd buf ofs len flags =
 608   try
 609     if ofs < 0 || len < 0 || ofs > String.length buf - len
 610     then invalid_arg "Unix.recvfrom"
 611     else unsafe_recvfrom fd buf ofs len flags
 612   with Unix_error((EAGAIN | EWOULDBLOCK), _, _) ->
 613     wait_read fd;
 614     recvfrom fd buf ofs len flags
 615
 616 let rec send fd buf ofs len flags =
 617   try
 618     if ofs < 0 || len < 0 || ofs > String.length buf - len
 619     then invalid_arg "Unix.send"
 620     else unsafe_send fd buf ofs len flags
 621   with Unix_error((EAGAIN | EWOULDBLOCK), _, _) ->
 622     wait_write fd;
 623     send fd buf ofs len flags
 624
 625 let rec sendto fd buf ofs len flags addr =
 626   try
 627     if ofs < 0 || len < 0 || ofs > String.length buf - len
 628     then invalid_arg "Unix.sendto"
 629     else unsafe_sendto fd buf ofs len flags addr
 630   with Unix_error((EAGAIN | EWOULDBLOCK), _, _) ->
 631     wait_write fd;
 632     sendto fd buf ofs len flags addr
 633
 634 type socket_bool_option =
 635     SO_DEBUG
 636   | SO_BROADCAST
 637   | SO_REUSEADDR
 638   | SO_KEEPALIVE
 639   | SO_DONTROUTE
 640   | SO_OOBINLINE
 641   | SO_ACCEPTCONN
 642   | TCP_NODELAY
 643   | IPV6_ONLY
 644
 645
 646 type socket_int_option =
 647     SO_SNDBUF
 648   | SO_RCVBUF
 649   | SO_ERROR
 650   | SO_TYPE
 651   | SO_RCVLOWAT
 652   | SO_SNDLOWAT
 653
 654 type socket_optint_option = SO_LINGER
 655
 656 type socket_float_option =
 657     SO_RCVTIMEO
 658   | SO_SNDTIMEO
 659
 660 type socket_error_option = SO_ERROR
 661
 662 module SO: sig
 663   type ('opt, 'v) t
 664   val bool: (socket_bool_option, bool) t
 665   val int: (socket_int_option, int) t
 666   val optint: (socket_optint_option, int option) t
 667   val float: (socket_float_option, float) t
 668   val error: (socket_error_option, error option) t
 669   val get: ('opt, 'v) t -> file_descr -> 'opt -> 'v
 670   val set: ('opt, 'v) t -> file_descr -> 'opt -> 'v -> unit
 671 end = struct
 672   type ('opt, 'v) t = int
 673   let bool = 0
 674   let int = 1
 675   let optint = 2
 676   let float = 3
 677   let error = 4
 678   external get: ('opt, 'v) t -> file_descr -> 'opt -> 'v
 679               = "unix_getsockopt"
 680   external set: ('opt, 'v) t -> file_descr -> 'opt -> 'v -> unit
 681               = "unix_setsockopt"
 682 end
 683
 684 let getsockopt fd opt = SO.get SO.bool fd opt
 685 let setsockopt fd opt v = SO.set SO.bool fd opt v
 686
 687 let getsockopt_int fd opt = SO.get SO.int fd opt
 688 let setsockopt_int fd opt v = SO.set SO.int fd opt v
 689
 690 let getsockopt_optint fd opt = SO.get SO.optint fd opt
 691 let setsockopt_optint fd opt v = SO.set SO.optint fd opt v
 692
 693 let getsockopt_float fd opt = SO.get SO.float fd opt
 694 let setsockopt_float fd opt v = SO.set SO.float fd opt v
 695
 696 let getsockopt_error fd = SO.get SO.error fd SO_ERROR
 697
 698 type host_entry =
 699   { h_name : string;
 700     h_aliases : string array;
 701     h_addrtype : socket_domain;
 702     h_addr_list : inet_addr array }
 703
 704 type protocol_entry =
 705   { p_name : string;
 706     p_aliases : string array;
 707     p_proto : int }
 708
 709 type service_entry =
 710   { s_name : string;
 711     s_aliases : string array;
 712     s_port : int;
 713     s_proto : string }
 714
 715 external gethostname : unit -> string = "unix_gethostname"
 716 external gethostbyname : string -> host_entry = "unix_gethostbyname"
 717 external gethostbyaddr : inet_addr -> host_entry = "unix_gethostbyaddr"
 718 external getprotobyname : string -> protocol_entry
 719                                          = "unix_getprotobyname"
 720 external getprotobynumber : int -> protocol_entry
 721                                          = "unix_getprotobynumber"
 722 external getservbyname : string -> string -> service_entry
 723                                          = "unix_getservbyname"
 724 external getservbyport : int -> string -> service_entry
 725                                          = "unix_getservbyport"
 726 type addr_info =
 727   { ai_family : socket_domain;
 728     ai_socktype : socket_type;
 729     ai_protocol : int;
 730     ai_addr : sockaddr;
 731     ai_canonname : string }
 732
 733 type getaddrinfo_option =
 734     AI_FAMILY of socket_domain
 735   | AI_SOCKTYPE of socket_type
 736   | AI_PROTOCOL of int
 737   | AI_NUMERICHOST
 738   | AI_CANONNAME
 739   | AI_PASSIVE
 740
 741 external getaddrinfo_system
 742   : string -> string -> getaddrinfo_option list -> addr_info list
 743   = "unix_getaddrinfo"
 744
 745 let getaddrinfo_emulation node service opts =
 746   (* Parse options *)
 747   let opt_socktype = ref None
 748   and opt_protocol = ref 0
 749   and opt_passive = ref false in
 750   List.iter
 751     (function AI_SOCKTYPE s -> opt_socktype := Some s
 752             | AI_PROTOCOL p -> opt_protocol := p
 753             | AI_PASSIVE -> opt_passive := true
 754             | _ -> ())
 755     opts;
 756   (* Determine socket types and port numbers *)
 757   let get_port ty kind =
 758     if service = "" then [ty, 0] else
 759       try
 760         [ty, int_of_string service]
 761       with Failure _ ->
 762       try
 763         [ty, (getservbyname service kind).s_port]
 764       with Not_found -> []
 765   in
 766   let ports =
 767     match !opt_socktype with
 768     | None ->
 769         get_port SOCK_STREAM "tcp" @ get_port SOCK_DGRAM "udp"
 770     | Some SOCK_STREAM ->
 771         get_port SOCK_STREAM "tcp"
 772     | Some SOCK_DGRAM ->
 773         get_port SOCK_DGRAM "udp"
 774     | Some ty ->
 775         if service = "" then [ty, 0] else [] in
 776   (* Determine IP addresses *)
 777   let addresses =
 778     if node = "" then
 779       if List.mem AI_PASSIVE opts
 780       then [inet_addr_any, "0.0.0.0"]
 781       else [inet_addr_loopback, "127.0.0.1"]
 782     else
 783       try
 784         [inet_addr_of_string node, node]
 785       with Failure _ ->
 786       try
 787         let he = gethostbyname node in
 788         List.map
 789           (fun a -> (a, he.h_name))
 790           (Array.to_list he.h_addr_list)
 791       with Not_found ->
 792         [] in
 793   (* Cross-product of addresses and ports *)
 794   List.flatten
 795     (List.map
 796       (fun (ty, port) ->
 797         List.map
 798           (fun (addr, name) ->
 799             { ai_family = PF_INET;
 800               ai_socktype = ty;
 801               ai_protocol = !opt_protocol;
 802               ai_addr = ADDR_INET(addr, port);
 803               ai_canonname = name })
 804           addresses)
 805       ports)
 806
 807 let getaddrinfo node service opts =
 808   try
 809     List.rev(getaddrinfo_system node service opts)
 810   with Invalid_argument _ ->
 811     getaddrinfo_emulation node service opts
 812
 813 type name_info =
 814   { ni_hostname : string;
 815     ni_service : string }
 816
 817 type getnameinfo_option =
 818     NI_NOFQDN
 819   | NI_NUMERICHOST
 820   | NI_NAMEREQD
 821   | NI_NUMERICSERV
 822   | NI_DGRAM
 823
 824 external getnameinfo_system
 825   : sockaddr -> getnameinfo_option list -> name_info
 826   = "unix_getnameinfo"
 827
 828 let getnameinfo_emulation addr opts =
 829   match addr with
 830   | ADDR_UNIX f ->
 831       { ni_hostname = ""; ni_service = f } (* why not? *)
 832   | ADDR_INET(a, p) ->
 833       let hostname =
 834         try
 835           if List.mem NI_NUMERICHOST opts then raise Not_found;
 836           (gethostbyaddr a).h_name
 837         with Not_found ->
 838           if List.mem NI_NAMEREQD opts then raise Not_found;
 839           string_of_inet_addr a in
 840       let service =
 841         try
 842           if List.mem NI_NUMERICSERV opts then raise Not_found;
 843           let kind = if List.mem NI_DGRAM opts then "udp" else "tcp" in
 844           (getservbyport p kind).s_name
 845         with Not_found ->
 846           string_of_int p in
 847       { ni_hostname = hostname; ni_service = service }
 848
 849 let getnameinfo addr opts =
 850   try
 851     getnameinfo_system addr opts
 852   with Invalid_argument _ ->
 853     getnameinfo_emulation addr opts
 854
 855 type terminal_io = {
 856     mutable c_ignbrk: bool;
 857     mutable c_brkint: bool;
 858     mutable c_ignpar: bool;
 859     mutable c_parmrk: bool;
 860     mutable c_inpck: bool;
 861     mutable c_istrip: bool;
 862     mutable c_inlcr: bool;
 863     mutable c_igncr: bool;
 864     mutable c_icrnl: bool;
 865     mutable c_ixon: bool;
 866     mutable c_ixoff: bool;
 867     mutable c_opost: bool;
 868     mutable c_obaud: int;
 869     mutable c_ibaud: int;
 870     mutable c_csize: int;
 871     mutable c_cstopb: int;
 872     mutable c_cread: bool;
 873     mutable c_parenb: bool;
 874     mutable c_parodd: bool;
 875     mutable c_hupcl: bool;
 876     mutable c_clocal: bool;
 877     mutable c_isig: bool;
 878     mutable c_icanon: bool;
 879     mutable c_noflsh: bool;
 880     mutable c_echo: bool;
 881     mutable c_echoe: bool;
 882     mutable c_echok: bool;
 883     mutable c_echonl: bool;
 884     mutable c_vintr: char;
 885     mutable c_vquit: char;
 886     mutable c_verase: char;
 887     mutable c_vkill: char;
 888     mutable c_veof: char;
 889     mutable c_veol: char;
 890     mutable c_vmin: int;
 891     mutable c_vtime: int;
 892     mutable c_vstart: char;
 893     mutable c_vstop: char
 894   }
 895
 896 external tcgetattr: file_descr -> terminal_io = "unix_tcgetattr"
 897
 898 type setattr_when = TCSANOW | TCSADRAIN | TCSAFLUSH
 899
 900 external tcsetattr: file_descr -> setattr_when -> terminal_io -> unit
 901                   = "unix_tcsetattr"
 902 external tcsendbreak: file_descr -> int -> unit = "unix_tcsendbreak"
 903 external tcdrain: file_descr -> unit = "unix_tcdrain"
 904
 905 type flush_queue = TCIFLUSH | TCOFLUSH | TCIOFLUSH
 906
 907 external tcflush: file_descr -> flush_queue -> unit = "unix_tcflush"
 908
 909 type flow_action = TCOOFF | TCOON | TCIOFF | TCION
 910
 911 external tcflow: file_descr -> flow_action -> unit = "unix_tcflow"
 912
 913 external setsid : unit -> int = "unix_setsid"
 914
 915 (* High-level process management (system, popen) *)
 916
 917 let system cmd =
 918   match fork() with
 919      0 -> begin try
 920             execv "/bin/sh" [| "/bin/sh"; "-c"; cmd |]
 921           with _ ->
 922             exit 127
 923           end
 924   | id -> snd(waitpid [] id)
 925
 926 let rec safe_dup fd =
 927   let new_fd = dup fd in
 928   if new_fd >= 3 then
 929     new_fd
 930   else begin
 931     let res = safe_dup fd in
 932     close new_fd;
 933     res
 934   end
 935
 936 let safe_close fd =
 937   try close fd with Unix_error(_,_,_) -> ()
 938
 939 let perform_redirections new_stdin new_stdout new_stderr =
 940   let newnewstdin = safe_dup new_stdin in
 941   let newnewstdout = safe_dup new_stdout in
 942   let newnewstderr = safe_dup new_stderr in
 943   safe_close new_stdin;
 944   safe_close new_stdout;
 945   safe_close new_stderr;
 946   dup2 newnewstdin stdin; close newnewstdin;
 947   dup2 newnewstdout stdout; close newnewstdout;
 948   dup2 newnewstderr stderr; close newnewstderr
 949
 950 let create_process cmd args new_stdin new_stdout new_stderr =
 951   match fork() with
 952     0 ->
 953       begin try
 954         perform_redirections new_stdin new_stdout new_stderr;
 955         execvp cmd args
 956       with _ ->
 957         exit 127
 958       end
 959   | id -> id
 960
 961 let create_process_env cmd args env new_stdin new_stdout new_stderr =
 962   match fork() with
 963     0 ->
 964       begin try
 965         perform_redirections new_stdin new_stdout new_stderr;
 966         execvpe cmd args env
 967       with _ ->
 968         exit 127
 969       end
 970   | id -> id
 971
 972 type popen_process =
 973     Process of in_channel * out_channel
 974   | Process_in of in_channel
 975   | Process_out of out_channel
 976   | Process_full of in_channel * out_channel * in_channel
 977
 978 let popen_processes = (Hashtbl.create 7 : (popen_process, int) Hashtbl.t)
 979
 980 let open_proc cmd proc input output toclose =
 981   match fork() with
 982      0 -> if input <> stdin then begin dup2 input stdin; close input end;
 983           if output <> stdout then begin dup2 output stdout; close output end;
 984           List.iter close toclose;
 985           begin try execv "/bin/sh" [| "/bin/sh"; "-c"; cmd |]
 986           with _ -> exit 127
 987           end
 988   | id -> Hashtbl.add popen_processes proc id
 989
 990 let open_process_in cmd =
 991   let (in_read, in_write) = pipe() in
 992   let inchan = in_channel_of_descr in_read in
 993   open_proc cmd (Process_in inchan) stdin in_write [in_read];
 994   close in_write;
 995   inchan
 996
 997 let open_process_out cmd =
 998   let (out_read, out_write) = pipe() in
 999   let outchan = out_channel_of_descr out_write in
1000   open_proc cmd (Process_out outchan) out_read stdout [out_write];
1001   close out_read;
1002   outchan
1003
1004 let open_process cmd =
1005   let (in_read, in_write) = pipe() in
1006   let (out_read, out_write) = pipe() in
1007   let inchan = in_channel_of_descr in_read in
1008   let outchan = out_channel_of_descr out_write in
1009   open_proc cmd (Process(inchan, outchan)) out_read in_write
1010                                            [in_read; out_write];
1011   close out_read;
1012   close in_write;
1013   (inchan, outchan)
1014
1015 let open_proc_full cmd env proc input output error toclose =
1016   match fork() with
1017      0 -> dup2 input stdin; close input;
1018           dup2 output stdout; close output;
1019           dup2 error stderr; close error;
1020           List.iter close toclose;
1021           begin try execve "/bin/sh" [| "/bin/sh"; "-c"; cmd |] env
1022           with _ -> exit 127
1023           end
1024   | id -> Hashtbl.add popen_processes proc id
1025
1026 let open_process_full cmd env =
1027   let (in_read, in_write) = pipe() in
1028   let (out_read, out_write) = pipe() in
1029   let (err_read, err_write) = pipe() in
1030   let inchan = in_channel_of_descr in_read in
1031   let outchan = out_channel_of_descr out_write in
1032   let errchan = in_channel_of_descr err_read in
1033   open_proc_full cmd env (Process_full(inchan, outchan, errchan))
1034                  out_read in_write err_write [in_read; out_write; err_read];
1035   close out_read;
1036   close in_write;
1037   close err_write;
1038   (inchan, outchan, errchan)
1039
1040 let find_proc_id fun_name proc =
1041   try
1042     let pid = Hashtbl.find popen_processes proc in
1043     Hashtbl.remove popen_processes proc;
1044     pid
1045   with Not_found ->
1046     raise(Unix_error(EBADF, fun_name, ""))
1047
1048 let rec waitpid_non_intr pid =
1049   try waitpid [] pid
1050   with Unix_error (EINTR, _, _) -> waitpid_non_intr pid
1051
1052 let close_process_in inchan =
1053   let pid = find_proc_id "close_process_in" (Process_in inchan) in
1054   close_in inchan;
1055   snd(waitpid_non_intr pid)
1056
1057 let close_process_out outchan =
1058   let pid = find_proc_id "close_process_out" (Process_out outchan) in
1059   close_out outchan;
1060   snd(waitpid_non_intr pid)
1061
1062 let close_process (inchan, outchan) =
1063   let pid = find_proc_id "close_process" (Process(inchan, outchan)) in
1064   close_in inchan;
1065   begin try close_out outchan with Sys_error _ -> () end;
1066   snd(waitpid_non_intr pid)
1067
1068 let close_process_full (inchan, outchan, errchan) =
1069   let pid =
1070     find_proc_id "close_process_full"
1071                  (Process_full(inchan, outchan, errchan)) in
1072   close_in inchan;
1073   begin try close_out outchan with Sys_error _ -> () end;
1074   close_in errchan;
1075   snd(waitpid_non_intr pid)
1076
1077 (* High-level network functions *)
1078
1079 let open_connection sockaddr =
1080   let sock =
1081     socket (domain_of_sockaddr sockaddr) SOCK_STREAM 0 in
1082   try
1083     connect sock sockaddr;
1084     (in_channel_of_descr sock, out_channel_of_descr sock)
1085   with exn ->
1086     close sock; raise exn
1087
1088 let shutdown_connection inchan =
1089   shutdown (descr_of_in_channel inchan) SHUTDOWN_SEND
1090
1091 let establish_server server_fun sockaddr =
1092   let sock =
1093     socket (domain_of_sockaddr sockaddr) SOCK_STREAM 0 in
1094   setsockopt sock SO_REUSEADDR true;
1095   bind sock sockaddr;
1096   listen sock 5;
1097   while true do
1098     let (s, caller) = accept sock in
1099     (* The "double fork" trick, the process which calls server_fun will not
1100        leave a zombie process *)
1101     match fork() with
1102        0 -> if fork() <> 0 then exit 0; (* The son exits, the grandson works *)
1103             let inchan = in_channel_of_descr s in
1104             let outchan = out_channel_of_descr s in
1105             server_fun inchan outchan;
1106             close_out outchan;
1107             (* The file descriptor was already closed by close_out.
1108                close_in inchan;
1109             *)
1110             exit 0
1111     | id -> close s; ignore(waitpid [] id) (* Reclaim the son *)
1112   done
1113