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