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