1(**************************************************************************) 2(* *) 3(* OCaml *) 4(* *) 5(* Xavier Leroy and Pascal Cuoq, 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 16(* Initialization *) 17 18external startup: unit -> unit = "win_startup" 19external cleanup: unit -> unit = "win_cleanup" 20 21let _ = startup(); at_exit cleanup 22 23(* Errors *) 24 25type error = 26 (* Errors defined in the POSIX standard *) 27 E2BIG (* Argument list too long *) 28 | EACCES (* Permission denied *) 29 | EAGAIN (* Resource temporarily unavailable; try again *) 30 | EBADF (* Bad file descriptor *) 31 | EBUSY (* Resource unavailable *) 32 | ECHILD (* No child process *) 33 | EDEADLK (* Resource deadlock would occur *) 34 | EDOM (* Domain error for math functions, etc. *) 35 | EEXIST (* File exists *) 36 | EFAULT (* Bad address *) 37 | EFBIG (* File too large *) 38 | EINTR (* Function interrupted by signal *) 39 | EINVAL (* Invalid argument *) 40 | EIO (* Hardware I/O error *) 41 | EISDIR (* Is a directory *) 42 | EMFILE (* Too many open files by the process *) 43 | EMLINK (* Too many links *) 44 | ENAMETOOLONG (* Filename too long *) 45 | ENFILE (* Too many open files in the system *) 46 | ENODEV (* No such device *) 47 | ENOENT (* No such file or directory *) 48 | ENOEXEC (* Not an executable file *) 49 | ENOLCK (* No locks available *) 50 | ENOMEM (* Not enough memory *) 51 | ENOSPC (* No space left on device *) 52 | ENOSYS (* Function not supported *) 53 | ENOTDIR (* Not a directory *) 54 | ENOTEMPTY (* Directory not empty *) 55 | ENOTTY (* Inappropriate I/O control operation *) 56 | ENXIO (* No such device or address *) 57 | EPERM (* Operation not permitted *) 58 | EPIPE (* Broken pipe *) 59 | ERANGE (* Result too large *) 60 | EROFS (* Read-only file system *) 61 | ESPIPE (* Invalid seek e.g. on a pipe *) 62 | ESRCH (* No such process *) 63 | EXDEV (* Invalid link *) 64 (* Additional errors, mostly BSD *) 65 | EWOULDBLOCK (* Operation would block *) 66 | EINPROGRESS (* Operation now in progress *) 67 | EALREADY (* Operation already in progress *) 68 | ENOTSOCK (* Socket operation on non-socket *) 69 | EDESTADDRREQ (* Destination address required *) 70 | EMSGSIZE (* Message too long *) 71 | EPROTOTYPE (* Protocol wrong type for socket *) 72 | ENOPROTOOPT (* Protocol not available *) 73 | EPROTONOSUPPORT (* Protocol not supported *) 74 | ESOCKTNOSUPPORT (* Socket type not supported *) 75 | EOPNOTSUPP (* Operation not supported on socket *) 76 | EPFNOSUPPORT (* Protocol family not supported *) 77 | EAFNOSUPPORT (* Address family not supported by protocol family *) 78 | EADDRINUSE (* Address already in use *) 79 | EADDRNOTAVAIL (* Can't assign requested address *) 80 | ENETDOWN (* Network is down *) 81 | ENETUNREACH (* Network is unreachable *) 82 | ENETRESET (* Network dropped connection on reset *) 83 | ECONNABORTED (* Software caused connection abort *) 84 | ECONNRESET (* Connection reset by peer *) 85 | ENOBUFS (* No buffer space available *) 86 | EISCONN (* Socket is already connected *) 87 | ENOTCONN (* Socket is not connected *) 88 | ESHUTDOWN (* Can't send after socket shutdown *) 89 | ETOOMANYREFS (* Too many references: can't splice *) 90 | ETIMEDOUT (* Connection timed out *) 91 | ECONNREFUSED (* Connection refused *) 92 | EHOSTDOWN (* Host is down *) 93 | EHOSTUNREACH (* No route to host *) 94 | ELOOP (* Too many levels of symbolic links *) 95 | EOVERFLOW 96 (* All other errors are mapped to EUNKNOWNERR *) 97 | EUNKNOWNERR of int (* Unknown error *) 98 99exception Unix_error of error * string * string 100 101let _ = Callback.register_exception "Unix.Unix_error" 102 (Unix_error(E2BIG, "", "")) 103 104external error_message : error -> string = "unix_error_message" 105 106let handle_unix_error f arg = 107 try 108 f arg 109 with Unix_error(err, fun_name, arg) -> 110 prerr_string Sys.argv.(0); 111 prerr_string ": \""; 112 prerr_string fun_name; 113 prerr_string "\" failed"; 114 if String.length arg > 0 then begin 115 prerr_string " on \""; 116 prerr_string arg; 117 prerr_string "\"" 118 end; 119 prerr_string ": "; 120 prerr_endline (error_message err); 121 exit 2 122 123external environment : unit -> string array = "unix_environment" 124external getenv: string -> string = "caml_sys_getenv" 125(* external unsafe_getenv: string -> string = "caml_sys_unsafe_getenv" *) 126external putenv: string -> string -> unit = "unix_putenv" 127 128type process_status = 129 WEXITED of int 130 | WSIGNALED of int 131 | WSTOPPED of int 132 133type wait_flag = 134 WNOHANG 135 | WUNTRACED 136 137type file_descr 138 139external execv : string -> string array -> 'a = "unix_execv" 140external execve : string -> string array -> string array -> 'a = "unix_execve" 141external execvp : string -> string array -> 'a = "unix_execvp" 142external execvpe : string -> string array -> string array -> 'a = "unix_execvpe" 143 144external waitpid : wait_flag list -> int -> int * process_status 145 = "win_waitpid" 146external getpid : unit -> int = "unix_getpid" 147 148let fork () = invalid_arg "Unix.fork not implemented" 149let wait () = invalid_arg "Unix.wait not implemented" 150let getppid () = invalid_arg "Unix.getppid not implemented" 151let nice _ = invalid_arg "Unix.nice not implemented" 152 153(* Basic file input/output *) 154 155external filedescr_of_fd : int -> file_descr = "win_handle_fd" 156 157let stdin = filedescr_of_fd 0 158let stdout = filedescr_of_fd 1 159let stderr = filedescr_of_fd 2 160 161type open_flag = 162 O_RDONLY 163 | O_WRONLY 164 | O_RDWR 165 | O_NONBLOCK 166 | O_APPEND 167 | O_CREAT 168 | O_TRUNC 169 | O_EXCL 170 | O_NOCTTY 171 | O_DSYNC 172 | O_SYNC 173 | O_RSYNC 174 | O_SHARE_DELETE 175 | O_CLOEXEC 176 | O_KEEPEXEC 177 178type file_perm = int 179 180external openfile : string -> open_flag list -> file_perm -> file_descr 181 = "unix_open" 182external close : file_descr -> unit = "unix_close" 183external unsafe_read : file_descr -> bytes -> int -> int -> int 184 = "unix_read" 185external unsafe_write : file_descr -> bytes -> int -> int -> int 186 = "unix_write" 187external unsafe_single_write : file_descr -> bytes -> int -> int -> int 188 = "unix_single_write" 189 190let read fd buf ofs len = 191 if ofs < 0 || len < 0 || ofs > Bytes.length buf - len 192 then invalid_arg "Unix.read" 193 else unsafe_read fd buf ofs len 194let write fd buf ofs len = 195 if ofs < 0 || len < 0 || ofs > Bytes.length buf - len 196 then invalid_arg "Unix.write" 197 else unsafe_write fd buf ofs len 198let single_write fd buf ofs len = 199 if ofs < 0 || len < 0 || ofs > Bytes.length buf - len 200 then invalid_arg "Unix.single_write" 201 else unsafe_single_write fd buf ofs len 202 203let write_substring fd buf ofs len = 204 write fd (Bytes.unsafe_of_string buf) ofs len 205 206let single_write_substring fd buf ofs len = 207 single_write fd (Bytes.unsafe_of_string buf) ofs len 208 209(* Interfacing with the standard input/output library *) 210 211external in_channel_of_descr: file_descr -> in_channel 212 = "win_inchannel_of_filedescr" 213external out_channel_of_descr: file_descr -> out_channel 214 = "win_outchannel_of_filedescr" 215external descr_of_in_channel : in_channel -> file_descr 216 = "win_filedescr_of_channel" 217external descr_of_out_channel : out_channel -> file_descr 218 = "win_filedescr_of_channel" 219 220(* Seeking and truncating *) 221 222type seek_command = 223 SEEK_SET 224 | SEEK_CUR 225 | SEEK_END 226 227external lseek : file_descr -> int -> seek_command -> int = "unix_lseek" 228 229let truncate _name _len = invalid_arg "Unix.truncate not implemented" 230let ftruncate _fd _len = invalid_arg "Unix.ftruncate not implemented" 231 232(* File statistics *) 233 234type file_kind = 235 S_REG 236 | S_DIR 237 | S_CHR 238 | S_BLK 239 | S_LNK 240 | S_FIFO 241 | S_SOCK 242 243type stats = 244 { st_dev : int; 245 st_ino : int; 246 st_kind : file_kind; 247 st_perm : file_perm; 248 st_nlink : int; 249 st_uid : int; 250 st_gid : int; 251 st_rdev : int; 252 st_size : int; 253 st_atime : float; 254 st_mtime : float; 255 st_ctime : float } 256 257external stat : string -> stats = "unix_stat" 258external lstat : string -> stats = "unix_lstat" 259external fstat : file_descr -> stats = "unix_fstat" 260let isatty fd = 261 match (fstat fd).st_kind with S_CHR -> true | _ -> false 262 263(* Operations on file names *) 264 265external unlink : string -> unit = "unix_unlink" 266external rename : string -> string -> unit = "unix_rename" 267external link : string -> string -> unit = "unix_link" 268 269(* Operations on large files *) 270 271module LargeFile = 272 struct 273 external lseek : file_descr -> int64 -> seek_command -> int64 274 = "unix_lseek_64" 275 let truncate _name _len = 276 invalid_arg "Unix.LargeFile.truncate not implemented" 277 let ftruncate _name _len = 278 invalid_arg "Unix.LargeFile.ftruncate not implemented" 279 type stats = 280 { st_dev : int; 281 st_ino : int; 282 st_kind : file_kind; 283 st_perm : file_perm; 284 st_nlink : int; 285 st_uid : int; 286 st_gid : int; 287 st_rdev : int; 288 st_size : int64; 289 st_atime : float; 290 st_mtime : float; 291 st_ctime : float; 292 } 293 external stat : string -> stats = "unix_stat_64" 294 external lstat : string -> stats = "unix_lstat_64" 295 external fstat : file_descr -> stats = "unix_fstat_64" 296 end 297 298(* File permissions and ownership *) 299 300type access_permission = 301 R_OK 302 | W_OK 303 | X_OK 304 | F_OK 305 306external chmod : string -> file_perm -> unit = "unix_chmod" 307let fchmod _fd _perm = invalid_arg "Unix.fchmod not implemented" 308let chown _file _perm = invalid_arg "Unix.chown not implemented" 309let fchown _fd _perm = invalid_arg "Unix.fchown not implemented" 310let umask _msk = invalid_arg "Unix.umask not implemented" 311 312external access : string -> access_permission list -> unit = "unix_access" 313 314(* Operations on file descriptors *) 315 316external dup : ?cloexec: bool -> file_descr -> file_descr = "unix_dup" 317external dup2 : 318 ?cloexec: bool -> file_descr -> file_descr -> unit = "unix_dup2" 319 320external set_nonblock : file_descr -> unit = "unix_set_nonblock" 321external clear_nonblock : file_descr -> unit = "unix_clear_nonblock" 322 323external set_close_on_exec : file_descr -> unit = "win_set_close_on_exec" 324external clear_close_on_exec : file_descr -> unit = "win_clear_close_on_exec" 325 326(* Directories *) 327 328external mkdir : string -> file_perm -> unit = "unix_mkdir" 329external rmdir : string -> unit = "unix_rmdir" 330external chdir : string -> unit = "unix_chdir" 331external getcwd : unit -> string = "unix_getcwd" 332let chroot _ = invalid_arg "Unix.chroot not implemented" 333 334type dir_entry = 335 Dir_empty 336 | Dir_read of string 337 | Dir_toread 338 339type dir_handle = 340 { dirname: string; mutable handle: int; mutable entry_read: dir_entry } 341 342external findfirst : string -> string * int = "win_findfirst" 343external findnext : int -> string= "win_findnext" 344 345let opendir dirname = 346 try 347 let (first_entry, handle) = findfirst (Filename.concat dirname "*.*") in 348 { dirname = dirname; handle = handle; entry_read = Dir_read first_entry } 349 with End_of_file -> 350 { dirname = dirname; handle = 0; entry_read = Dir_empty } 351 352let readdir d = 353 match d.entry_read with 354 Dir_empty -> raise End_of_file 355 | Dir_read name -> d.entry_read <- Dir_toread; name 356 | Dir_toread -> findnext d.handle 357 358external win_findclose : int -> unit = "win_findclose" 359 360let closedir d = 361 match d.entry_read with 362 Dir_empty -> () 363 | _ -> win_findclose d.handle 364 365let rewinddir d = 366 closedir d; 367 try 368 let (first_entry, handle) = findfirst (d.dirname ^ "\\*.*") in 369 d.handle <- handle; d.entry_read <- Dir_read first_entry 370 with End_of_file -> 371 d.handle <- 0; d.entry_read <- Dir_empty 372 373(* Pipes *) 374 375external pipe : 376 ?cloexec: bool -> unit -> file_descr * file_descr = "unix_pipe" 377 378let mkfifo _name _perm = invalid_arg "Unix.mkfifo not implemented" 379 380(* Symbolic links *) 381 382external readlink : string -> string = "unix_readlink" 383external symlink_stub : bool -> string -> string -> unit = "unix_symlink" 384 385let symlink ?to_dir source dest = 386 let to_dir = 387 match to_dir with 388 Some to_dir -> 389 to_dir 390 | None -> 391 try 392 LargeFile.((stat source).st_kind = S_DIR) 393 with _ -> 394 false 395 in 396 symlink_stub to_dir source dest 397 398external has_symlink : unit -> bool = "unix_has_symlink" 399 400(* Locking *) 401 402type lock_command = 403 F_ULOCK 404 | F_LOCK 405 | F_TLOCK 406 | F_TEST 407 | F_RLOCK 408 | F_TRLOCK 409 410external lockf : file_descr -> lock_command -> int -> unit = "unix_lockf" 411 412external terminate_process: int -> bool = "win_terminate_process" 413 414let kill pid signo = 415 if signo <> Sys.sigkill then 416 invalid_arg "Unix.kill" 417 else 418 if not (terminate_process pid) then 419 raise(Unix_error(ESRCH, "kill", "")) 420 (* could be more precise *) 421 422type sigprocmask_command = SIG_SETMASK | SIG_BLOCK | SIG_UNBLOCK 423let sigprocmask _cmd _sigs = invalid_arg "Unix.sigprocmask not implemented" 424let sigpending () = invalid_arg "Unix.sigpending not implemented" 425let sigsuspend _sigs = invalid_arg "Unix.sigsuspend not implemented" 426let pause () = invalid_arg "Unix.pause not implemented" 427 428(* Time functions *) 429 430type process_times = 431 { tms_utime : float; 432 tms_stime : float; 433 tms_cutime : float; 434 tms_cstime : float } 435 436type tm = 437 { tm_sec : int; 438 tm_min : int; 439 tm_hour : int; 440 tm_mday : int; 441 tm_mon : int; 442 tm_year : int; 443 tm_wday : int; 444 tm_yday : int; 445 tm_isdst : bool } 446 447external time : unit -> float = "unix_time" 448external gettimeofday : unit -> float = "unix_gettimeofday" 449external gmtime : float -> tm = "unix_gmtime" 450external localtime : float -> tm = "unix_localtime" 451external mktime : tm -> float * tm = "unix_mktime" 452let alarm _n = invalid_arg "Unix.alarm not implemented" 453external sleepf : float -> unit = "unix_sleep" 454let sleep n = sleepf (float n) 455external times: unit -> process_times = "unix_times" 456external utimes : string -> float -> float -> unit = "unix_utimes" 457 458type interval_timer = 459 ITIMER_REAL 460 | ITIMER_VIRTUAL 461 | ITIMER_PROF 462 463type interval_timer_status = 464 { it_interval: float; 465 it_value: float } 466 467let getitimer _it = invalid_arg "Unix.getitimer not implemented" 468let setitimer _it _tm = invalid_arg "Unix.setitimer not implemented" 469 470(* User id, group id *) 471 472let getuid () = 1 473let geteuid = getuid 474let setuid _id = invalid_arg "Unix.setuid not implemented" 475 476let getgid () = 1 477let getegid = getgid 478let setgid _id = invalid_arg "Unix.setgid not implemented" 479 480let getgroups () = [|1|] 481let setgroups _ = invalid_arg "Unix.setgroups not implemented" 482let initgroups _ _ = invalid_arg "Unix.initgroups not implemented" 483 484type passwd_entry = 485 { pw_name : string; 486 pw_passwd : string; 487 pw_uid : int; 488 pw_gid : int; 489 pw_gecos : string; 490 pw_dir : string; 491 pw_shell : string } 492 493type group_entry = 494 { gr_name : string; 495 gr_passwd : string; 496 gr_gid : int; 497 gr_mem : string array } 498 499let getlogin () = try Sys.getenv "USERNAME" with Not_found -> "" 500let getpwnam _x = raise Not_found 501let getgrnam = getpwnam 502let getpwuid = getpwnam 503let getgrgid = getpwnam 504 505(* Internet addresses *) 506 507type inet_addr = string 508 509let is_inet6_addr s = String.length s = 16 510 511external inet_addr_of_string : string -> inet_addr 512 = "unix_inet_addr_of_string" 513external string_of_inet_addr : inet_addr -> string 514 = "unix_string_of_inet_addr" 515 516let inet_addr_any = inet_addr_of_string "0.0.0.0" 517let inet_addr_loopback = inet_addr_of_string "127.0.0.1" 518let inet6_addr_any = 519 try inet_addr_of_string "::" with Failure _ -> inet_addr_any 520let inet6_addr_loopback = 521 try inet_addr_of_string "::1" with Failure _ -> inet_addr_loopback 522 523(* Sockets *) 524 525type socket_domain = 526 PF_UNIX 527 | PF_INET 528 | PF_INET6 529 530type socket_type = 531 SOCK_STREAM 532 | SOCK_DGRAM 533 | SOCK_RAW 534 | SOCK_SEQPACKET 535 536type sockaddr = 537 ADDR_UNIX of string 538 | ADDR_INET of inet_addr * int 539 540let domain_of_sockaddr = function 541 ADDR_UNIX _ -> PF_UNIX 542 | ADDR_INET(a, _) -> if is_inet6_addr a then PF_INET6 else PF_INET 543 544type shutdown_command = 545 SHUTDOWN_RECEIVE 546 | SHUTDOWN_SEND 547 | SHUTDOWN_ALL 548 549type msg_flag = 550 MSG_OOB 551 | MSG_DONTROUTE 552 | MSG_PEEK 553 554external socket : 555 ?cloexec: bool -> socket_domain -> socket_type -> int -> file_descr 556 = "unix_socket" 557let socketpair ?cloexec:_ _dom _ty _proto = invalid_arg "Unix.socketpair not implemented" 558external accept : 559 ?cloexec: bool -> file_descr -> file_descr * sockaddr = "unix_accept" 560external bind : file_descr -> sockaddr -> unit = "unix_bind" 561external connect : file_descr -> sockaddr -> unit = "unix_connect" 562external listen : file_descr -> int -> unit = "unix_listen" 563external shutdown : file_descr -> shutdown_command -> unit = "unix_shutdown" 564external getsockname : file_descr -> sockaddr = "unix_getsockname" 565external getpeername : file_descr -> sockaddr = "unix_getpeername" 566 567external unsafe_recv : 568 file_descr -> bytes -> int -> int -> msg_flag list -> int 569 = "unix_recv" 570external unsafe_recvfrom : 571 file_descr -> bytes -> int -> int -> msg_flag list -> int * sockaddr 572 = "unix_recvfrom" 573external unsafe_send : 574 file_descr -> bytes -> int -> int -> msg_flag list -> int 575 = "unix_send" 576external unsafe_sendto : 577 file_descr -> bytes -> int -> int -> msg_flag list -> sockaddr -> int 578 = "unix_sendto" "unix_sendto_native" 579 580let recv fd buf ofs len flags = 581 if ofs < 0 || len < 0 || ofs > Bytes.length buf - len 582 then invalid_arg "Unix.recv" 583 else unsafe_recv fd buf ofs len flags 584let recvfrom fd buf ofs len flags = 585 if ofs < 0 || len < 0 || ofs > Bytes.length buf - len 586 then invalid_arg "Unix.recvfrom" 587 else unsafe_recvfrom fd buf ofs len flags 588let send fd buf ofs len flags = 589 if ofs < 0 || len < 0 || ofs > Bytes.length buf - len 590 then invalid_arg "Unix.send" 591 else unsafe_send fd buf ofs len flags 592let sendto fd buf ofs len flags addr = 593 if ofs < 0 || len < 0 || ofs > Bytes.length buf - len 594 then invalid_arg "Unix.sendto" 595 else unsafe_sendto fd buf ofs len flags addr 596 597let send_substring fd buf ofs len flags = 598 send fd (Bytes.unsafe_of_string buf) ofs len flags 599 600let sendto_substring fd buf ofs len flags addr = 601 sendto fd (Bytes.unsafe_of_string buf) ofs len flags addr 602 603type socket_bool_option = 604 SO_DEBUG 605 | SO_BROADCAST 606 | SO_REUSEADDR 607 | SO_KEEPALIVE 608 | SO_DONTROUTE 609 | SO_OOBINLINE 610 | SO_ACCEPTCONN 611 | TCP_NODELAY 612 | IPV6_ONLY 613 614type socket_int_option = 615 SO_SNDBUF 616 | SO_RCVBUF 617 | SO_ERROR 618 | SO_TYPE 619 | SO_RCVLOWAT 620 | SO_SNDLOWAT 621 622type socket_optint_option = SO_LINGER 623 624type socket_float_option = 625 SO_RCVTIMEO 626 | SO_SNDTIMEO 627 628type socket_error_option = SO_ERROR 629 630module SO: sig 631 type ('opt, 'v) t 632 val bool: (socket_bool_option, bool) t 633 val int: (socket_int_option, int) t 634 val optint: (socket_optint_option, int option) t 635 val float: (socket_float_option, float) t 636 val error: (socket_error_option, error option) t 637 val get: ('opt, 'v) t -> file_descr -> 'opt -> 'v 638 val set: ('opt, 'v) t -> file_descr -> 'opt -> 'v -> unit 639end = struct 640 type ('opt, 'v) t = int 641 let bool = 0 642 let int = 1 643 let optint = 2 644 let float = 3 645 let error = 4 646 external get: ('opt, 'v) t -> file_descr -> 'opt -> 'v 647 = "unix_getsockopt" 648 external set: ('opt, 'v) t -> file_descr -> 'opt -> 'v -> unit 649 = "unix_setsockopt" 650end 651 652let getsockopt fd opt = SO.get SO.bool fd opt 653let setsockopt fd opt v = SO.set SO.bool fd opt v 654 655let getsockopt_int fd opt = SO.get SO.int fd opt 656let setsockopt_int fd opt v = SO.set SO.int fd opt v 657 658let getsockopt_optint fd opt = SO.get SO.optint fd opt 659let setsockopt_optint fd opt v = SO.set SO.optint fd opt v 660 661let getsockopt_float fd opt = SO.get SO.float fd opt 662let setsockopt_float fd opt v = SO.set SO.float fd opt v 663 664let getsockopt_error fd = SO.get SO.error fd SO_ERROR 665 666(* Host and protocol databases *) 667 668type host_entry = 669 { h_name : string; 670 h_aliases : string array; 671 h_addrtype : socket_domain; 672 h_addr_list : inet_addr array } 673 674type protocol_entry = 675 { p_name : string; 676 p_aliases : string array; 677 p_proto : int } 678 679type service_entry = 680 { s_name : string; 681 s_aliases : string array; 682 s_port : int; 683 s_proto : string } 684 685external gethostname : unit -> string = "unix_gethostname" 686external gethostbyname : string -> host_entry = "unix_gethostbyname" 687external gethostbyaddr : inet_addr -> host_entry = "unix_gethostbyaddr" 688external getprotobyname : string -> protocol_entry 689 = "unix_getprotobyname" 690external getprotobynumber : int -> protocol_entry 691 = "unix_getprotobynumber" 692 693external getservbyname : string -> string -> service_entry 694 = "unix_getservbyname" 695external getservbyport : int -> string -> service_entry 696 = "unix_getservbyport" 697 698type addr_info = 699 { ai_family : socket_domain; 700 ai_socktype : socket_type; 701 ai_protocol : int; 702 ai_addr : sockaddr; 703 ai_canonname : string } 704 705type getaddrinfo_option = 706 AI_FAMILY of socket_domain 707 | AI_SOCKTYPE of socket_type 708 | AI_PROTOCOL of int 709 | AI_NUMERICHOST 710 | AI_CANONNAME 711 | AI_PASSIVE 712 713external getaddrinfo_system 714 : string -> string -> getaddrinfo_option list -> addr_info list 715 = "unix_getaddrinfo" 716 717let getaddrinfo_emulation node service opts = 718 (* Parse options *) 719 let opt_socktype = ref None 720 and opt_protocol = ref 0 721 and opt_passive = ref false in 722 List.iter 723 (function AI_SOCKTYPE s -> opt_socktype := Some s 724 | AI_PROTOCOL p -> opt_protocol := p 725 | AI_PASSIVE -> opt_passive := true 726 | _ -> ()) 727 opts; 728 (* Determine socket types and port numbers *) 729 let get_port ty kind = 730 if service = "" then [ty, 0] else 731 try 732 [ty, int_of_string service] 733 with Failure _ -> 734 try 735 [ty, (getservbyname service kind).s_port] 736 with Not_found -> [] 737 in 738 let ports = 739 match !opt_socktype with 740 | None -> 741 get_port SOCK_STREAM "tcp" @ get_port SOCK_DGRAM "udp" 742 | Some SOCK_STREAM -> 743 get_port SOCK_STREAM "tcp" 744 | Some SOCK_DGRAM -> 745 get_port SOCK_DGRAM "udp" 746 | Some ty -> 747 if service = "" then [ty, 0] else [] in 748 (* Determine IP addresses *) 749 let addresses = 750 if node = "" then 751 if List.mem AI_PASSIVE opts 752 then [inet_addr_any, "0.0.0.0"] 753 else [inet_addr_loopback, "127.0.0.1"] 754 else 755 try 756 [inet_addr_of_string node, node] 757 with Failure _ -> 758 try 759 let he = gethostbyname node in 760 List.map 761 (fun a -> (a, he.h_name)) 762 (Array.to_list he.h_addr_list) 763 with Not_found -> 764 [] in 765 (* Cross-product of addresses and ports *) 766 List.flatten 767 (List.map 768 (fun (ty, port) -> 769 List.map 770 (fun (addr, name) -> 771 { ai_family = PF_INET; 772 ai_socktype = ty; 773 ai_protocol = !opt_protocol; 774 ai_addr = ADDR_INET(addr, port); 775 ai_canonname = name }) 776 addresses) 777 ports) 778 779let getaddrinfo node service opts = 780 try 781 List.rev(getaddrinfo_system node service opts) 782 with Invalid_argument _ -> 783 getaddrinfo_emulation node service opts 784 785type name_info = 786 { ni_hostname : string; 787 ni_service : string } 788 789type getnameinfo_option = 790 NI_NOFQDN 791 | NI_NUMERICHOST 792 | NI_NAMEREQD 793 | NI_NUMERICSERV 794 | NI_DGRAM 795 796external getnameinfo_system 797 : sockaddr -> getnameinfo_option list -> name_info 798 = "unix_getnameinfo" 799 800let getnameinfo_emulation addr opts = 801 match addr with 802 | ADDR_UNIX f -> 803 { ni_hostname = ""; ni_service = f } (* why not? *) 804 | ADDR_INET(a, p) -> 805 let hostname = 806 try 807 if List.mem NI_NUMERICHOST opts then raise Not_found; 808 (gethostbyaddr a).h_name 809 with Not_found -> 810 if List.mem NI_NAMEREQD opts then raise Not_found; 811 string_of_inet_addr a in 812 let service = 813 try 814 if List.mem NI_NUMERICSERV opts then raise Not_found; 815 let kind = if List.mem NI_DGRAM opts then "udp" else "tcp" in 816 (getservbyport p kind).s_name 817 with Not_found -> 818 string_of_int p in 819 { ni_hostname = hostname; ni_service = service } 820 821let getnameinfo addr opts = 822 try 823 getnameinfo_system addr opts 824 with Invalid_argument _ -> 825 getnameinfo_emulation addr opts 826 827(* High-level process management (system, popen) *) 828 829external win_create_process : string -> string -> string option -> 830 file_descr -> file_descr -> file_descr -> int 831 = "win_create_process" "win_create_process_native" 832 833let make_cmdline args = 834 let maybe_quote f = 835 if String.contains f ' ' || 836 String.contains f '\"' || 837 String.contains f '\t' || 838 f = "" 839 then Filename.quote f 840 else f in 841 String.concat " " (List.map maybe_quote (Array.to_list args)) 842 843let make_process_env env = 844 Array.iter 845 (fun s -> if String.contains s '\000' then raise(Unix_error(EINVAL, "", s))) 846 env; 847 String.concat "\000" (Array.to_list env) ^ "\000" 848 849let create_process prog args fd1 fd2 fd3 = 850 win_create_process prog (make_cmdline args) None fd1 fd2 fd3 851 852let create_process_env prog args env fd1 fd2 fd3 = 853 win_create_process prog (make_cmdline args) 854 (Some(make_process_env env)) 855 fd1 fd2 fd3 856 857external system: string -> process_status = "win_system" 858 859type popen_process = 860 Process of in_channel * out_channel 861 | Process_in of in_channel 862 | Process_out of out_channel 863 | Process_full of in_channel * out_channel * in_channel 864 865let popen_processes = (Hashtbl.create 7 : (popen_process, int) Hashtbl.t) 866 867let open_proc cmd optenv proc input output error = 868 let shell = 869 try Sys.getenv "COMSPEC" 870 with Not_found -> raise(Unix_error(ENOEXEC, "open_proc", cmd)) in 871 let pid = 872 win_create_process shell (shell ^ " /c " ^ cmd) optenv 873 input output error in 874 Hashtbl.add popen_processes proc pid 875 876let open_process_in cmd = 877 let (in_read, in_write) = pipe ~cloexec:true () in 878 let inchan = in_channel_of_descr in_read in 879 begin 880 try 881 open_proc cmd None (Process_in inchan) stdin in_write stderr 882 with e -> 883 close_in inchan; 884 close in_write; 885 raise e 886 end; 887 close in_write; 888 inchan 889 890let open_process_out cmd = 891 let (out_read, out_write) = pipe ~cloexec:true () in 892 let outchan = out_channel_of_descr out_write in 893 begin 894 try 895 open_proc cmd None (Process_out outchan) out_read stdout stderr 896 with e -> 897 close_out outchan; 898 close out_read; 899 raise e 900 end; 901 close out_read; 902 outchan 903 904let open_process cmd = 905 let (in_read, in_write) = pipe ~cloexec:true () in 906 let (out_read, out_write) = 907 try pipe ~cloexec:true () 908 with e -> close in_read; close in_write; raise e in 909 let inchan = in_channel_of_descr in_read in 910 let outchan = out_channel_of_descr out_write in 911 begin 912 try 913 open_proc cmd None (Process(inchan, outchan)) out_read in_write stderr 914 with e -> 915 close out_read; close out_write; 916 close in_read; close in_write; 917 raise e 918 end; 919 close out_read; 920 close in_write; 921 (inchan, outchan) 922 923let open_process_full cmd env = 924 let (in_read, in_write) = pipe ~cloexec:true () in 925 let (out_read, out_write) = 926 try pipe ~cloexec:true () 927 with e -> close in_read; close in_write; raise e in 928 let (err_read, err_write) = 929 try pipe ~cloexec:true () 930 with e -> close in_read; close in_write; 931 close out_read; close out_write; raise e in 932 let inchan = in_channel_of_descr in_read in 933 let outchan = out_channel_of_descr out_write in 934 let errchan = in_channel_of_descr err_read in 935 begin 936 try 937 open_proc cmd (Some (make_process_env env)) 938 (Process_full(inchan, outchan, errchan)) 939 out_read in_write err_write 940 with e -> 941 close out_read; close out_write; 942 close in_read; close in_write; 943 close err_read; close err_write; 944 raise e 945 end; 946 close out_read; 947 close in_write; 948 close err_write; 949 (inchan, outchan, errchan) 950 951let find_proc_id fun_name proc = 952 try 953 let pid = Hashtbl.find popen_processes proc in 954 Hashtbl.remove popen_processes proc; 955 pid 956 with Not_found -> 957 raise(Unix_error(EBADF, fun_name, "")) 958 959let close_process_in inchan = 960 let pid = find_proc_id "close_process_in" (Process_in inchan) in 961 close_in inchan; 962 snd(waitpid [] pid) 963 964let close_process_out outchan = 965 let pid = find_proc_id "close_process_out" (Process_out outchan) in 966 close_out outchan; 967 snd(waitpid [] pid) 968 969let close_process (inchan, outchan) = 970 let pid = find_proc_id "close_process" (Process(inchan, outchan)) in 971 close_in inchan; close_out outchan; 972 snd(waitpid [] pid) 973 974let close_process_full (inchan, outchan, errchan) = 975 let pid = 976 find_proc_id "close_process_full" 977 (Process_full(inchan, outchan, errchan)) in 978 close_in inchan; close_out outchan; close_in errchan; 979 snd(waitpid [] pid) 980 981(* Polling *) 982 983external select : 984 file_descr list -> file_descr list -> file_descr list -> float -> 985 file_descr list * file_descr list * file_descr list = "unix_select" 986 987(* High-level network functions *) 988 989let open_connection sockaddr = 990 let sock = 991 socket ~cloexec:true (domain_of_sockaddr sockaddr) SOCK_STREAM 0 in 992 try 993 connect sock sockaddr; 994 (in_channel_of_descr sock, out_channel_of_descr sock) 995 with exn -> 996 close sock; raise exn 997 998let shutdown_connection inchan = 999 shutdown (descr_of_in_channel inchan) SHUTDOWN_SEND 1000 1001let establish_server _server_fun _sockaddr = 1002 invalid_arg "Unix.establish_server not implemented" 1003 1004(* Terminal interface *) 1005 1006type terminal_io = { 1007 mutable c_ignbrk: bool; 1008 mutable c_brkint: bool; 1009 mutable c_ignpar: bool; 1010 mutable c_parmrk: bool; 1011 mutable c_inpck: bool; 1012 mutable c_istrip: bool; 1013 mutable c_inlcr: bool; 1014 mutable c_igncr: bool; 1015 mutable c_icrnl: bool; 1016 mutable c_ixon: bool; 1017 mutable c_ixoff: bool; 1018 mutable c_opost: bool; 1019 mutable c_obaud: int; 1020 mutable c_ibaud: int; 1021 mutable c_csize: int; 1022 mutable c_cstopb: int; 1023 mutable c_cread: bool; 1024 mutable c_parenb: bool; 1025 mutable c_parodd: bool; 1026 mutable c_hupcl: bool; 1027 mutable c_clocal: bool; 1028 mutable c_isig: bool; 1029 mutable c_icanon: bool; 1030 mutable c_noflsh: bool; 1031 mutable c_echo: bool; 1032 mutable c_echoe: bool; 1033 mutable c_echok: bool; 1034 mutable c_echonl: bool; 1035 mutable c_vintr: char; 1036 mutable c_vquit: char; 1037 mutable c_verase: char; 1038 mutable c_vkill: char; 1039 mutable c_veof: char; 1040 mutable c_veol: char; 1041 mutable c_vmin: int; 1042 mutable c_vtime: int; 1043 mutable c_vstart: char; 1044 mutable c_vstop: char 1045 } 1046 1047type setattr_when = TCSANOW | TCSADRAIN | TCSAFLUSH 1048 1049let tcgetattr _fd = invalid_arg "Unix.tcgetattr not implemented" 1050let tcsetattr _fd _wh = invalid_arg "Unix.tcsetattr not implemented" 1051let tcsendbreak _fd _n = invalid_arg "Unix.tcsendbreak not implemented" 1052let tcdrain _fd = invalid_arg "Unix.tcdrain not implemented" 1053 1054type flush_queue = TCIFLUSH | TCOFLUSH | TCIOFLUSH 1055let tcflush _fd _q = invalid_arg "Unix.tcflush not implemented" 1056type flow_action = TCOOFF | TCOON | TCIOFF | TCION 1057let tcflow _fd _fl = invalid_arg "Unix.tcflow not implemented" 1058let setsid () = invalid_arg "Unix.setsid not implemented" 1059